--- title: Deriving a Client Library for Interacting with Character-Oriented Printers tags: Thermoprint published: 2016-02-18 repo: https://git.yggdrasil.li/thermoprint?h=rewrite --- > {-# LANGUAGE DataKinds #-} > {-# LANGUAGE TypeOperators #-} > {-# LANGUAGE ViewPatterns #-} > {-# LANGUAGE RecordWildCards #-} > > -- | A client library for 'Thermoprint.API' > module Thermoprint.Client > ( Client(..) > , mkClient, mkClient' > , throwNat, ioNat > -- = Reexports > , ServantError(..) > , module Servant.Common.BaseUrl > , module Control.Monad.Trans.Either > , module Servant.Server.Internal.Enter > ) where > > import Thermoprint.API > import Data.Map (Map) > import Data.Sequence (Seq) > import Data.Time (UTCTime) > > import Servant.Client hiding (HasClient(..)) > import qualified Servant.Client as S > import Servant.Common.BaseUrl > 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 We encapsulate all api operations in a single record parametrized over the monad we intend to use them in. Construction of such a record is pure since all we require to do so is a `BaseUrl`{.haskell}. Using RecordWildCards we can bring all operations into scope with extreme ease. > -- | All 'ThermoprintAPI'-functions as a record > -- > -- Use like this: > -- > -- > {-# LANGUAGE RecordWildCards #-} > -- > > -- > main :: IO () > -- > -- ^ Display a list of printers with their status > -- > main = print =<< printers > -- > where Client{..} = mkClient' $ Http "localhost" 3000 > data Client m = Client > { printers :: m (Map PrinterId PrinterStatus) > -- ^ List all printers > , jobs :: Maybe PrinterId > -> Maybe (Range (JobId)) > -> Maybe (Range (UTCTime)) > -> m (Seq (JobId, UTCTime, JobStatus)) > -- ^ List a selection of jobs > , jobCreate :: Maybe PrinterId -> Printout -> m JobId > -- ^ Send a 'Printout' to be queued > , job :: JobId -> m Printout > -- ^ Retrieve the contents of a job > , jobStatus :: JobId -> m JobStatus > -- ^ Query a jobs status > , jobDelete :: JobId -> m () > -- ^ Delete a job from the queue (not from history or while it is being printed) > , drafts :: m (Map DraftId (Maybe DraftTitle)) > -- ^ List all saved drafts > , draftCreate :: Maybe DraftTitle > -> Printout > -> m DraftId > -- ^ Create a new draft > , draftReplace :: DraftId > -> Maybe DraftTitle > -> Printout > -> m () > -- ^ Replace the contents and title of an existing draft > , draft :: DraftId -> m (Maybe DraftTitle, Printout) > -- ^ Retrieve the contents and title of a draft > , draftDelete :: DraftId -> m () > -- ^ Delete a draft > , draftPrint :: DraftId -> Maybe PrinterId -> m JobId > -- ^ Send a draft to be printed > } [servant documentation](https://haskell-servant.github.io/tutorial/server.html#nested-apis) advises factoring out apis to make the specification more concise. We are rightly advised that doing so has an effect on the types of the corresponding `Server`{.haskell}s and `Client`{.haskell}s. To cope with this we introduce a helper function that allows us, when used with ViewPatterns, to nontheless simply pattern match on `client`{.haskell}. > withArgs :: (x -> a :<|> b) -> ((x -> a) :<|> (x -> b)) > -- ^ Undo factoring of APIs > withArgs subAPI = (\(a :<|> _) -> a) . subAPI :<|> (\(_ :<|> b) -> b) . subAPI `withArgs`{.haskell} as presented here does not recurse and thus doesn't handle more than one occurence of `:<|>`{.haskell}. We have to to so ourselves using nested ViewPatterns (see `mkClient`{.haskell}). > 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' RecordWildCards also allows us to construct a record from components in scope. > mkClient n url = Client{..} > where > printers > :<|> (jobs :<|> jobCreate) > :<|> (withArgs -> job :<|> (withArgs -> jobStatus :<|> jobDelete)) > :<|> (drafts :<|> draftCreate) > :<|> (withArgs -> draftReplace :<|> (withArgs -> draft :<|> (withArgs -> draftDelete :<|> draftPrint))) > = enter n $ client thermoprintAPI url We also provide some additional convenience functions so the user doesn't have to construct their own `Nat`{.haskell}ural transformations. > 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 > -- ^ Squash a layer of 'EitherT' into the underlying monad supporting 'throwM' > throwNat = Nat $ either throwM return <=< runEitherT > > ioNat :: MonadIO m => IO :~> m > -- ^ @ioNat = Nat liftIO@ > ioNat = Nat liftIO