diff options
author | Gregor Kleen <gkleen@yggdrasil.li> | 2016-02-18 17:45:30 +0000 |
---|---|---|
committer | Gregor Kleen <gkleen@yggdrasil.li> | 2016-02-18 17:45:30 +0000 |
commit | a9bf3d917961509ffbb6eada729621970b5131d9 (patch) | |
tree | bbed91c81157cf1649ec9469ca72a76fb85335e9 /provider | |
parent | 50c7bbc2c82ab31ab49e2bb3a2b25e116fb67062 (diff) | |
download | dirty-haskell.org-a9bf3d917961509ffbb6eada729621970b5131d9.tar dirty-haskell.org-a9bf3d917961509ffbb6eada729621970b5131d9.tar.gz dirty-haskell.org-a9bf3d917961509ffbb6eada729621970b5131d9.tar.bz2 dirty-haskell.org-a9bf3d917961509ffbb6eada729621970b5131d9.tar.xz dirty-haskell.org-a9bf3d917961509ffbb6eada729621970b5131d9.zip |
thermoprint-6
Diffstat (limited to 'provider')
-rw-r--r-- | provider/posts/thermoprint-6.lhs | 142 |
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 | --- | ||
2 | title: Deriving a Client Library for Interacting with Character-Oriented Printers | ||
3 | tags: Thermoprint | ||
4 | published: 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 | |||
45 | We encapsulate all api operations in a single record parametrized over the monad we intend to use | ||
46 | them in. | ||
47 | Construction of such a record is pure since all we require to do so is a `BaseUrl`{.haskell}. | ||
48 | Using 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) | ||
96 | advises factoring out apis to make the specification more concise. | ||
97 | We are rightly advised that doing so has an effect on the types of the | ||
98 | corresponding `Server`{.haskell}s and `Client`{.haskell}s. | ||
99 | To cope with this we introduce a helper function that allows us, when | ||
100 | used 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 | ||
107 | doesn't handle more than one occurence of `:<|>`{.haskell}. | ||
108 | We 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 | |||
116 | RecordWildCards also allows us to construct a record from components | ||
117 | in 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 | |||
128 | We also provide some additional convenience functions so the user | ||
129 | doesn't have to construct their own `Nat`{.haskell}ural | ||
130 | transformations. | ||
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 | ||