{-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE UndecidableInstances #-} -- | A client library for 'Thermoprint.API' module Thermoprint.Client ( Client(..) , mkClient, mkClient' -- = Reexports , ServantError(..) , module Thermoprint.API , module Servant.Client , module Control.Monad.Except , module Control.Natural ) where import Thermoprint.API import Data.Map (Map) import Data.Sequence (Seq) import Data.Time (UTCTime) import Servant.Client hiding (HasClient(..), mkClient) import qualified Servant.Client as S import Network.HTTP.Client (Manager, ManagerSettings, newManager, defaultManagerSettings) import Servant.API -- import Servant.Utils.Enter import Control.Natural ((:~>)(..)) import Control.Monad.Except (ExceptT(..), runExceptT) import Control.Monad.Reader (ReaderT, runReaderT, ask) import Control.Monad.Catch (Exception, MonadThrow(..)) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans (lift) import Control.Concurrent.STM.TVar (newTVarIO) import Control.Monad import Control.Category import Prelude hiding (id, (.)) class Enter typ mod ret | typ mod -> ret, typ ret -> mod, mod ret -> typ where enter :: mod -> typ -> ret instance Enter (m a) (m :~> n) (n a) where enter (NT f) = f instance (Enter typ1 mod1 ret1, Enter typ2 mod2 ret2, mod1 ~ mod2) => Enter (typ1 :<|> typ2) mod1 (ret1 :<|> ret2) where enter mod (a :<|> b) = enter mod a :<|> enter mod b instance Enter typ mod ret => Enter (r -> typ) mod (r -> ret) where enter mod = (enter mod .) -- | 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' defaultManagerSettings $ 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 } withArgs :: (x -> a :<|> b) -> ((x -> a) :<|> (x -> b)) -- ^ Undo factoring of APIs withArgs subAPI = (\(a :<|> _) -> a) . subAPI :<|> (\(_ :<|> b) -> b) . subAPI mkClientS :: Monad m => (ClientM :~> m) -- ^ A monad functor ('Nat') used to make the api functions work in any monad which can do 'IO' and handle errors -> Client m -- ^ Generate a 'Client' mkClientS n = Client{..} where printers :<|> (jobs :<|> jobCreate) :<|> (withArgs -> job :<|> (withArgs -> jobStatus :<|> jobDelete)) :<|> (drafts :<|> draftCreate) :<|> (withArgs -> draftReplace :<|> (withArgs -> draft :<|> (withArgs -> draftDelete :<|> draftPrint))) = enter n $ client thermoprintAPI mkClient :: (MonadThrow m, MonadIO m) => ManagerSettings -> BaseUrl -> Client m mkClient mSettings url = mkClientS clientNat where clientNat :: forall m. (MonadThrow m, MonadIO m) => ClientM :~> m clientNat = NT $ \cAct -> do mgr <- liftIO $ newManager mSettings cjar <- liftIO $ newTVarIO mempty either throwM return =<< liftIO (runClientM cAct . ClientEnv mgr url $ Just cjar) mkClient' :: (MonadThrow m, MonadIO m) => BaseUrl -> Client m -- ^ @mkClient' = mkClient defaultManagerSettings mkClient' = mkClient defaultManagerSettings