thermoprint-6

1 files changed, 142 insertions, 0 deletions

diff --git a/provider/posts/thermoprint-6.lhs b/provider/posts/thermoprint-6.lhs
new file mode 100644
index 0000000..9182427
--- /dev/null
+++ b/provider/posts/thermoprint-6.lhs
@@ -0,0 +1,142 @@
+---
+title: Deriving a Client Library for Interacting with Character-Oriented Printers
+tags: Thermoprint
+published: 2016-02-18
+---
+
+> {-# 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