diff options
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 |
