summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--provider/posts/thermoprint-6.lhs142
1 files changed, 142 insertions, 0 deletions
diff --git a/provider/posts/thermoprint-6.lhs b/provider/posts/thermoprint-6.lhs
new file mode 100644
index 0000000..9182427
--- /dev/null
+++ b/provider/posts/thermoprint-6.lhs
@@ -0,0 +1,142 @@
1---
2title: Deriving a Client Library for Interacting with Character-Oriented Printers
3tags: Thermoprint
4published: 2016-02-18
5---
6
7> {-# LANGUAGE DataKinds #-}
8> {-# LANGUAGE TypeOperators #-}
9> {-# LANGUAGE ViewPatterns #-}
10> {-# LANGUAGE RecordWildCards #-}
11>
12> -- | A client library for 'Thermoprint.API'
13> module Thermoprint.Client
14> ( Client(..)
15> , mkClient, mkClient'
16> , throwNat, ioNat
17> -- = Reexports
18> , ServantError(..)
19> , module Servant.Common.BaseUrl
20> , module Control.Monad.Trans.Either
21> , module Servant.Server.Internal.Enter
22> ) where
23>
24> import Thermoprint.API
25> import Data.Map (Map)
26> import Data.Sequence (Seq)
27> import Data.Time (UTCTime)
28>
29> import Servant.Client hiding (HasClient(..))
30> import qualified Servant.Client as S
31> import Servant.Common.BaseUrl
32> import Servant.API
33> import Servant.Server.Internal.Enter
34> import Control.Monad.Trans.Either
35>
36> import Control.Monad.Catch (Exception, MonadThrow(..))
37> import Control.Monad.IO.Class (MonadIO(..))
38>
39> import Control.Monad
40> import Control.Category
41> import Prelude hiding (id, (.))
42>
43> instance Exception ServantError
44
45We encapsulate all api operations in a single record parametrized over the monad we intend to use
46them in.
47Construction of such a record is pure since all we require to do so is a `BaseUrl`{.haskell}.
48Using RecordWildCards we can bring all operations into scope with extreme ease.
49
50> -- | All 'ThermoprintAPI'-functions as a record
51> --
52> -- Use like this:
53> --
54> -- > {-# LANGUAGE RecordWildCards #-}
55> -- >
56> -- > main :: IO ()
57> -- > -- ^ Display a list of printers with their status
58> -- > main = print =<< printers
59> -- > where Client{..} = mkClient' $ Http "localhost" 3000
60> data Client m = Client
61> { printers :: m (Map PrinterId PrinterStatus)
62> -- ^ List all printers
63> , jobs :: Maybe PrinterId
64> -> Maybe (Range (JobId))
65> -> Maybe (Range (UTCTime))
66> -> m (Seq (JobId, UTCTime, JobStatus))
67> -- ^ List a selection of jobs
68> , jobCreate :: Maybe PrinterId -> Printout -> m JobId
69> -- ^ Send a 'Printout' to be queued
70> , job :: JobId -> m Printout
71> -- ^ Retrieve the contents of a job
72> , jobStatus :: JobId -> m JobStatus
73> -- ^ Query a jobs status
74> , jobDelete :: JobId -> m ()
75> -- ^ Delete a job from the queue (not from history or while it is being printed)
76> , drafts :: m (Map DraftId (Maybe DraftTitle))
77> -- ^ List all saved drafts
78> , draftCreate :: Maybe DraftTitle
79> -> Printout
80> -> m DraftId
81> -- ^ Create a new draft
82> , draftReplace :: DraftId
83> -> Maybe DraftTitle
84> -> Printout
85> -> m ()
86> -- ^ Replace the contents and title of an existing draft
87> , draft :: DraftId -> m (Maybe DraftTitle, Printout)
88> -- ^ Retrieve the contents and title of a draft
89> , draftDelete :: DraftId -> m ()
90> -- ^ Delete a draft
91> , draftPrint :: DraftId -> Maybe PrinterId -> m JobId
92> -- ^ Send a draft to be printed
93> }
94
95[servant documentation](https://haskell-servant.github.io/tutorial/server.html#nested-apis)
96advises factoring out apis to make the specification more concise.
97We are rightly advised that doing so has an effect on the types of the
98corresponding `Server`{.haskell}s and `Client`{.haskell}s.
99To cope with this we introduce a helper function that allows us, when
100used with ViewPatterns, to nontheless simply pattern match on `client`{.haskell}.
101
102> withArgs :: (x -> a :<|> b) -> ((x -> a) :<|> (x -> b))
103> -- ^ Undo factoring of APIs
104> withArgs subAPI = (\(a :<|> _) -> a) . subAPI :<|> (\(_ :<|> b) -> b) . subAPI
105
106`withArgs`{.haskell} as presented here does not recurse and thus
107doesn't handle more than one occurence of `:<|>`{.haskell}.
108We have to to so ourselves using nested ViewPatterns (see
109`mkClient`{.haskell}).
110
111> mkClient :: (EitherT ServantError IO :~> m) -- ^ A monad functor ('Nat') used to make the api functions work in any monad which can do 'IO' and handle errors
112> -> BaseUrl
113> -> Client m
114> -- ^ Generate a 'Client'
115
116RecordWildCards also allows us to construct a record from components
117in scope.
118
119> mkClient n url = Client{..}
120> where
121> printers
122> :<|> (jobs :<|> jobCreate)
123> :<|> (withArgs -> job :<|> (withArgs -> jobStatus :<|> jobDelete))
124> :<|> (drafts :<|> draftCreate)
125> :<|> (withArgs -> draftReplace :<|> (withArgs -> draft :<|> (withArgs -> draftDelete :<|> draftPrint)))
126> = enter n $ client thermoprintAPI url
127
128We also provide some additional convenience functions so the user
129doesn't have to construct their own `Nat`{.haskell}ural
130transformations.
131
132> mkClient' :: (MonadThrow m, MonadIO m) => BaseUrl -> Client m
133> -- ^ @mkClient' = mkClient $ ioNat . throwNat@
134> mkClient' = mkClient $ ioNat . throwNat
135>
136> throwNat :: (Exception e, MonadThrow m) => EitherT e m :~> m
137> -- ^ Squash a layer of 'EitherT' into the underlying monad supporting 'throwM'
138> throwNat = Nat $ either throwM return <=< runEitherT
139>
140> ioNat :: MonadIO m => IO :~> m
141> -- ^ @ioNat = Nat liftIO@
142> ioNat = Nat liftIO
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-25 17:51:54 +0000