diff options
author | Gregor Kleen <gkleen@yggdrasil.li> | 2017-03-07 14:16:21 +0100 |
---|---|---|
committer | Gregor Kleen <gkleen@yggdrasil.li> | 2017-03-07 14:16:21 +0100 |
commit | 7065a8cc1b8b01cd32d4b1d5317b323fec5238bd (patch) | |
tree | d6608f463b066aa6caf33357fd9ae0e508e49084 /client | |
parent | 75d9fe614dca572aa1d7cfa53553e9c103eb2dd0 (diff) | |
download | thermoprint-7065a8cc1b8b01cd32d4b1d5317b323fec5238bd.tar thermoprint-7065a8cc1b8b01cd32d4b1d5317b323fec5238bd.tar.gz thermoprint-7065a8cc1b8b01cd32d4b1d5317b323fec5238bd.tar.bz2 thermoprint-7065a8cc1b8b01cd32d4b1d5317b323fec5238bd.tar.xz thermoprint-7065a8cc1b8b01cd32d4b1d5317b323fec5238bd.zip |
Bump versions
Diffstat (limited to 'client')
-rw-r--r-- | client/src/Thermoprint/Client.hs | 55 | ||||
-rw-r--r-- | client/thermoprint-client.cabal | 4 | ||||
-rw-r--r-- | client/thermoprint-client.nix | 2 |
3 files changed, 17 insertions, 44 deletions
diff --git a/client/src/Thermoprint/Client.hs b/client/src/Thermoprint/Client.hs index 448a912..46f6073 100644 --- a/client/src/Thermoprint/Client.hs +++ b/client/src/Thermoprint/Client.hs | |||
@@ -5,12 +5,12 @@ | |||
5 | {-# LANGUAGE RecordWildCards #-} | 5 | {-# LANGUAGE RecordWildCards #-} |
6 | {-# LANGUAGE FlexibleContexts #-} | 6 | {-# LANGUAGE FlexibleContexts #-} |
7 | {-# LANGUAGE FlexibleInstances #-} | 7 | {-# LANGUAGE FlexibleInstances #-} |
8 | {-# LANGUAGE RankNTypes #-} | ||
8 | 9 | ||
9 | -- | A client library for 'Thermoprint.API' | 10 | -- | A client library for 'Thermoprint.API' |
10 | module Thermoprint.Client | 11 | module Thermoprint.Client |
11 | ( Client(..) | 12 | ( Client(..) |
12 | , mkClient, mkClient' | 13 | , mkClient, mkClient' |
13 | , throwNat, ioNat | ||
14 | -- = Reexports | 14 | -- = Reexports |
15 | , ServantError(..) | 15 | , ServantError(..) |
16 | , module Thermoprint.API | 16 | , module Thermoprint.API |
@@ -27,10 +27,11 @@ import Data.Time (UTCTime) | |||
27 | import Servant.Client hiding (HasClient(..)) | 27 | import Servant.Client hiding (HasClient(..)) |
28 | import qualified Servant.Client as S | 28 | import qualified Servant.Client as S |
29 | import Servant.Common.BaseUrl | 29 | import Servant.Common.BaseUrl |
30 | import Servant.Common.Req | ||
30 | import Network.HTTP.Client (Manager, ManagerSettings, newManager, defaultManagerSettings) | 31 | import Network.HTTP.Client (Manager, ManagerSettings, newManager, defaultManagerSettings) |
31 | import Servant.API | 32 | import Servant.API |
32 | import Servant.Utils.Enter | 33 | import Servant.Utils.Enter |
33 | import Control.Monad.Except (ExceptT, runExceptT) | 34 | import Control.Monad.Except (ExceptT(..), runExceptT) |
34 | 35 | ||
35 | import Control.Monad.Reader (ReaderT, runReaderT, ask) | 36 | import Control.Monad.Reader (ReaderT, runReaderT, ask) |
36 | import Control.Monad.Catch (Exception, MonadThrow(..)) | 37 | import Control.Monad.Catch (Exception, MonadThrow(..)) |
@@ -92,29 +93,10 @@ withArgs subAPI = (\(a :<|> _) -> a) . subAPI :<|> (\(_ :<|> b) -> b) . subAPI | |||
92 | 93 | ||
93 | mkClientS :: Monad m | 94 | mkClientS :: Monad m |
94 | => (ClientM :~> m) -- ^ A monad functor ('Nat') used to make the api functions work in any monad which can do 'IO' and handle errors | 95 | => (ClientM :~> m) -- ^ A monad functor ('Nat') used to make the api functions work in any monad which can do 'IO' and handle errors |
95 | -> ManagerSettings | ||
96 | -> BaseUrl | ||
97 | -> Client m | 96 | -> Client m |
98 | -- ^ Generate a 'Client' | 97 | -- ^ Generate a 'Client' |
99 | mkClientS n mgrS url = Client | 98 | mkClientS n = Client{..} |
100 | { printers = clientF n printers | ||
101 | , jobs = \a b c -> clientF n $ jobs a b c | ||
102 | , jobCreate = \a b -> clientF n $ jobCreate a b | ||
103 | , job = \a -> clientF n $ job a | ||
104 | , jobStatus = \a -> clientF n $ jobStatus a | ||
105 | , jobDelete = \a -> clientF n $ jobDelete a | ||
106 | , drafts = clientF n drafts | ||
107 | , draftCreate = \a b -> clientF n $ draftCreate a b | ||
108 | , draftReplace = \a b c -> clientF n $ draftReplace a b c | ||
109 | , draft = \a -> clientF n $ draft a | ||
110 | , draftDelete = \a -> clientF n $ draftDelete a | ||
111 | , draftPrint = \a b -> clientF n $ draftPrint a b | ||
112 | } | ||
113 | where | 99 | where |
114 | clientF :: Monad m => (ClientM :~> m) -> (Manager -> BaseUrl -> m a) -> m a | ||
115 | clientF n f = do | ||
116 | mgr <- unNat n $ (liftIO $ newManager mgrS :: ClientM Manager) | ||
117 | f mgr url | ||
118 | printers | 100 | printers |
119 | :<|> (jobs :<|> jobCreate) | 101 | :<|> (jobs :<|> jobCreate) |
120 | :<|> (withArgs -> job :<|> (withArgs -> jobStatus :<|> jobDelete)) | 102 | :<|> (withArgs -> job :<|> (withArgs -> jobStatus :<|> jobDelete)) |
@@ -122,23 +104,14 @@ mkClientS n mgrS url = Client | |||
122 | :<|> (withArgs -> draftReplace :<|> (withArgs -> draft :<|> (withArgs -> draftDelete :<|> draftPrint))) | 104 | :<|> (withArgs -> draftReplace :<|> (withArgs -> draft :<|> (withArgs -> draftDelete :<|> draftPrint))) |
123 | = enter n $ client thermoprintAPI | 105 | = enter n $ client thermoprintAPI |
124 | 106 | ||
125 | mkClient :: Monad m | 107 | mkClient :: (MonadThrow m, MonadIO m) => ManagerSettings -> BaseUrl -> Client m |
126 | => (ClientM :~> m) -- ^ A monad functor ('Nat') used to make the api functions work in any monad which can do 'IO' and handle errors | 108 | mkClient mSettings url = mkClientS $ Nat clientNat |
127 | -> BaseUrl | 109 | where |
128 | -> Client m | 110 | clientNat :: forall m a. (MonadThrow m, MonadIO m) => ClientM a -> m a |
129 | mkClient n url = mkClientS n defaultManagerSettings url | 111 | clientNat cAct = do |
130 | 112 | mgr <- liftIO $ newManager mSettings | |
131 | mkClient' :: (MonadThrow m, MonadIO m) => BaseUrl -> Client m | 113 | either throwM return =<< liftIO (runClientM cAct $ ClientEnv mgr url) |
132 | -- ^ @mkClient' = mkClient $ ioNat . throwNat@ | ||
133 | mkClient' = mkClient $ ioNat . throwNat | ||
134 | |||
135 | throwNat :: (Exception e, MonadThrow m) => ExceptT e m :~> m | ||
136 | -- ^ Squash a layer of 'EitherT' into the underlying monad supporting 'throwM' | ||
137 | throwNat = Nat $ either throwM return <=< runExceptT | ||
138 | |||
139 | ioNat :: MonadIO m => IO :~> m | ||
140 | -- ^ @ioNat = Nat liftIO@ | ||
141 | ioNat = Nat liftIO | ||
142 | 114 | ||
143 | readerNat :: a -> ReaderT a m :~> m | 115 | mkClient' :: (MonadThrow m, MonadIO m) => BaseUrl -> Client m |
144 | readerNat a = Nat $ flip runReaderT a | 116 | -- ^ @mkClient' = mkClient defaultManagerSettings |
117 | mkClient' = mkClient defaultManagerSettings | ||
diff --git a/client/thermoprint-client.cabal b/client/thermoprint-client.cabal index 0920773..1306542 100644 --- a/client/thermoprint-client.cabal +++ b/client/thermoprint-client.cabal | |||
@@ -2,7 +2,7 @@ | |||
2 | -- documentation, see http://haskell.org/cabal/users-guide/ | 2 | -- documentation, see http://haskell.org/cabal/users-guide/ |
3 | 3 | ||
4 | name: thermoprint-client | 4 | name: thermoprint-client |
5 | version: 1.0.1 | 5 | version: 2.0.0 |
6 | synopsis: Client for thermoprint-spec | 6 | synopsis: Client for thermoprint-spec |
7 | -- description: | 7 | -- description: |
8 | homepage: http://dirty-haskell.org/tags/thermoprint.html | 8 | homepage: http://dirty-haskell.org/tags/thermoprint.html |
@@ -21,7 +21,7 @@ library | |||
21 | -- other-modules: | 21 | -- other-modules: |
22 | -- other-extensions: | 22 | -- other-extensions: |
23 | build-depends: base >=4.8 && <5 | 23 | build-depends: base >=4.8 && <5 |
24 | , thermoprint-spec ==5.0.* | 24 | , thermoprint-spec ==6.0.* |
25 | , servant >=0.4.4 && <1 | 25 | , servant >=0.4.4 && <1 |
26 | , servant-client >=0.4.4 && <1 | 26 | , servant-client >=0.4.4 && <1 |
27 | , servant-server >=0.4.4 && <1 | 27 | , servant-server >=0.4.4 && <1 |
diff --git a/client/thermoprint-client.nix b/client/thermoprint-client.nix index 8aadafb..7f83630 100644 --- a/client/thermoprint-client.nix +++ b/client/thermoprint-client.nix | |||
@@ -4,7 +4,7 @@ | |||
4 | }: | 4 | }: |
5 | mkDerivation { | 5 | mkDerivation { |
6 | pname = "thermoprint-client"; | 6 | pname = "thermoprint-client"; |
7 | version = "1.0.1"; | 7 | version = "2.0.0"; |
8 | src = ./.; | 8 | src = ./.; |
9 | libraryHaskellDepends = [ | 9 | libraryHaskellDepends = [ |
10 | base containers either exceptions http-client mtl servant | 10 | base containers either exceptions http-client mtl servant |