Split out Thermoprint.Server.API

1 files changed, 104 insertions, 0 deletions

diff --git a/server/src/Thermoprint/Server/API.hs b/server/src/Thermoprint/Server/API.hs
new file mode 100644
index 0000000..9559ad1
--- /dev/null
+++ b/server/src/Thermoprint/Server/API.hs
@@ -0,0 +1,104 @@
+{-# LANGUAGE TypeOperators    #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TemplateHaskell  #-}
+
+module Thermoprint.Server.API
+       ( ProtoHandler, Handler
+       , thermoprintServer
+       , handlerNat
+       ) where
+
+import Thermoprint.API hiding (JobId(..), DraftId(..))
+import qualified Thermoprint.API as API (JobId(..), DraftId(..))
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Data.Sequence (Seq)
+import qualified Data.Sequence as Seq
+import Data.Map (Map)
+import qualified Data.Map as Map
+
+import Servant
+import Servant.Server
+import Servant.Server.Internal.Enter
+
+import Control.Monad.Logger
+import Control.Monad.Reader
+import Control.Monad.Trans.Either
+import Control.Monad.IO.Class
+
+import Control.Monad ((<=<), liftM2)
+import Prelude hiding ((.), id)
+import Control.Category
+
+import Database.Persist
+import Database.Persist.Sql
+
+type ProtoHandler = ReaderT HandlerInput (LoggingT IO)
+type Handler      = EitherT ServantErr ProtoHandler
+
+data HandlerInput = HandlerInput { sqlPool :: ConnectionPool
+                                 }
+
+handlerNat :: ( MonadReader ConnectionPool m
+              , MonadLoggerIO m
+              ) => m (Handler :~> EitherT ServantErr IO)
+handlerNat = do
+  sqlPool <- ask
+  logFunc <- askLoggerIO
+  let
+    handlerInput = HandlerInput
+      { sqlPool = sqlPool
+      }
+    protoNat :: ProtoHandler :~> IO
+    protoNat = Nat (($ logFunc) . runLoggingT) . runReaderTNat handlerInput
+  return $ hoistNat protoNat
+
+thermoprintServer :: ServerT ThermoprintAPI Handler
+thermoprintServer = listPrinters
+                     :<|> (listJobs :<|> queueJob)
+                     :<|> getJob <||> jobStatus <||> deleteJob
+                     :<|> (listDrafts :<|> addDraft)
+                     :<|> updateDraft <||> getDraft <||> deleteDraft <||> printDraft
+  where
+    (<||>) :: Monad m => m a -> m b -> m (a :<|> b)
+    (<||>) = liftM2 (:<|>)
+    infixr 9 <||>
+
+listPrinters :: Handler (Map PrinterId PrinterStatus)
+listPrinters = return $ Map.fromList [(1, Available), (7, Available), (3, Available)]
+
+queueJob :: Maybe PrinterId -> Printout -> Handler API.JobId
+queueJob = return undefined
+
+printerStatus :: PrinterId -> Handler PrinterStatus
+printerStatus = return undefined
+
+listJobs :: Maybe PrinterId -> Maybe API.JobId -> Maybe API.JobId -> Handler (Seq (API.JobId, JobStatus))
+listJobs = return undefined
+
+getJob :: API.JobId -> Handler Printout
+getJob = return undefined
+
+jobStatus :: API.JobId -> Handler JobStatus
+jobStatus = return undefined
+
+deleteJob :: API.JobId -> Handler ()
+deleteJob = return undefined
+
+listDrafts :: Handler (Map API.DraftId (Maybe DraftTitle))
+listDrafts = return undefined
+
+addDraft :: Maybe DraftTitle -> Printout -> Handler API.DraftId
+addDraft = return undefined
+
+updateDraft :: API.DraftId -> Maybe DraftTitle -> Printout -> Handler ()
+updateDraft = return undefined
+
+getDraft :: API.DraftId -> Handler (Maybe DraftTitle, Printout)
+getDraft = return undefined
+
+deleteDraft :: API.DraftId -> Handler ()
+deleteDraft = return undefined
+
+printDraft :: API.DraftId -> Maybe PrinterId -> Handler API.JobId
+printDraft = return undefined