From 02015edc87f3caa8661c16aee6973e6b1cafc783 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 18 Feb 2016 15:26:15 +0100 Subject: Enriched Client interface --- client/src/Thermoprint/Client.hs | 52 ++++++++++++++++++++++++++-------------- client/thermoprint-client.cabal | 2 ++ client/thermoprint-client.nix | 9 +++---- 3 files changed, 41 insertions(+), 22 deletions(-) (limited to 'client') diff --git a/client/src/Thermoprint/Client.hs b/client/src/Thermoprint/Client.hs index 2b99e7e..758a256 100644 --- a/client/src/Thermoprint/Client.hs +++ b/client/src/Thermoprint/Client.hs @@ -6,7 +6,8 @@ -- | A client library for 'Thermoprint.API' module Thermoprint.Client ( Client(..) - , mkClient + , mkClient, mkClient' + , throwNat, ioNat -- = Reexports , ServantError(..) , module Servant.Common.BaseUrl @@ -26,53 +27,58 @@ import Servant.API import Servant.Server.Internal.Enter import Control.Monad.Trans.Either +import Control.Monad.Catch (Exception, MonadThrow(..)) +import Control.Monad.IO.Class (MonadIO(..)) + +import Control.Monad import Control.Category import Prelude hiding (id, (.)) +instance Exception ServantError + -- | All 'ThermoprintAPI'-functions as a record -- -- Use like this: -- -- > import Control.Category -- > import Prelude hiding (id, (.)) --- > import Data.Either -- > -- > main :: IO () -- > -- ^ Display a list of printers with their status --- > main = either print print =<< runEitherT printers --- > where Client{..} = mkClient id $ Http "localhost" 3000 +-- > main = print =<< printers +-- > where Client{..} = mkClient' $ Http "localhost" 3000 data Client m = Client - { printers :: EitherT ServantError m (Map PrinterId PrinterStatus) + { printers :: m (Map PrinterId PrinterStatus) -- ^ List all printers , jobs :: Maybe PrinterId -> Maybe (Range (JobId)) -> Maybe (Range (UTCTime)) - -> EitherT ServantError m (Seq (JobId, UTCTime, JobStatus)) + -> m (Seq (JobId, UTCTime, JobStatus)) -- ^ @jobs p minId maxId minTime maxTime@ lists a selection of jobs - , jobCreate :: Maybe PrinterId -> Printout -> EitherT ServantError m JobId + , jobCreate :: Maybe PrinterId -> Printout -> m JobId -- ^ Send a 'Printout' to be queued - , job :: JobId -> EitherT ServantError m Printout + , job :: JobId -> m Printout -- ^ Retrieve the contents of a job - , jobStatus :: JobId -> EitherT ServantError m JobStatus + , jobStatus :: JobId -> m JobStatus -- ^ Query a jobs status - , jobDelete :: JobId -> EitherT ServantError m () + , jobDelete :: JobId -> m () -- ^ Delete a job from the queue (not from history or while it is being printed) - , drafts :: EitherT ServantError m (Map DraftId (Maybe DraftTitle)) + , drafts :: m (Map DraftId (Maybe DraftTitle)) -- ^ List all saved drafts , draftCreate :: Maybe DraftTitle -> Printout - -> EitherT ServantError m DraftId + -> m DraftId -- ^ Create a new draft , draftReplace :: DraftId -> Maybe DraftTitle -> Printout - -> EitherT ServantError m () + -> m () -- ^ Replace the contents and title of an existing draft - , draft :: DraftId -> EitherT ServantError m (Maybe DraftTitle, Printout) + , draft :: DraftId -> m (Maybe DraftTitle, Printout) -- ^ Retrieve the contents and title of a draft - , draftDelete :: DraftId -> EitherT ServantError m () + , draftDelete :: DraftId -> m () -- ^ Delete a draft - , draftPrint :: DraftId -> Maybe PrinterId -> EitherT ServantError m JobId + , draftPrint :: DraftId -> Maybe PrinterId -> m JobId -- ^ Send a draft to be printed } @@ -80,7 +86,7 @@ withArgs :: (x -> a :<|> b) -> ((x -> a) :<|> (x -> b)) -- ^ Undo factoring of APIs withArgs subAPI = (\(a :<|> _) -> a) . subAPI :<|> (\(_ :<|> b) -> b) . subAPI -mkClient :: (IO :~> m) -- ^ A monad functor ('Nat') used to make the api functions work in any monad which can be constructed from 'IO' +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 -> BaseUrl -> Client m -- ^ Generate a 'Client' @@ -91,4 +97,14 @@ mkClient n url = Client{..} :<|> (withArgs -> job :<|> (withArgs -> jobStatus :<|> jobDelete)) :<|> (drafts :<|> draftCreate) :<|> (withArgs -> draftReplace :<|> (withArgs -> draft :<|> (withArgs -> draftDelete :<|> draftPrint))) - = enter (hoistNat n) $ client thermoprintAPI url + = enter n $ client thermoprintAPI url + +mkClient' :: (MonadThrow m, MonadIO m) => BaseUrl -> Client m +-- ^ @mkClient' = mkClient $ ioNat . throwNat@ +mkClient' = mkClient $ ioNat . throwNat + +throwNat :: (Exception e, MonadThrow m) => EitherT e m :~> m +throwNat = Nat $ either throwM return <=< runEitherT + +ioNat :: MonadIO m => IO :~> m +ioNat = Nat liftIO diff --git a/client/thermoprint-client.cabal b/client/thermoprint-client.cabal index 39e2622..69091fd 100644 --- a/client/thermoprint-client.cabal +++ b/client/thermoprint-client.cabal @@ -28,5 +28,7 @@ library , containers >=0.5.6 && <1 , either >=4.4.1 && <5 , time >=1.5.0 && <2 + , exceptions >=0.8.2 && <1 + , transformers >=0.4.2 && <1 hs-source-dirs: src default-language: Haskell2010 diff --git a/client/thermoprint-client.nix b/client/thermoprint-client.nix index e424403..6471b06 100644 --- a/client/thermoprint-client.nix +++ b/client/thermoprint-client.nix @@ -1,13 +1,14 @@ -{ mkDerivation, base, containers, either, servant, servant-client -, servant-server, stdenv, thermoprint-spec +{ mkDerivation, base, containers, either, exceptions, servant +, servant-client, servant-server, stdenv, thermoprint-spec, time +, transformers }: mkDerivation { pname = "thermoprint-client"; version = "0.0.0"; src = ./.; libraryHaskellDepends = [ - base containers either servant servant-client servant-server - thermoprint-spec + base containers either exceptions servant servant-client + servant-server thermoprint-spec time transformers ]; homepage = "http://dirty-haskell.org/tags/thermoprint.html"; description = "Client for thermoprint-spec"; -- cgit v1.2.3