dirty-haskell.org: Deriving a Client Library for Interacting with Character-Oriented Printers

It's not crazy — it's having fun with types.

> {-# 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. 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 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 Servers and Clients. To cope with this we introduce a helper function that allows us, when used with ViewPatterns, to nontheless simply pattern match on client.

> withArgs :: (x -> a :<|> b) -> ((x -> a) :<|> (x -> b))
> -- ^ Undo factoring of APIs
> withArgs subAPI = (\(a :<|> _) -> a) . subAPI :<|> (\(_ :<|> b) -> b) . subAPI

withArgs as presented here does not recurse and thus doesn’t handle more than one occurence of :<|>. We have to to so ourselves using nested ViewPatterns (see mkClient).

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