Enriched Client interface

3 files changed, 41 insertions, 22 deletions

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