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