From d776f630c6bf60a14e496694bcb502e93f215a41 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sat, 23 Jan 2016 11:26:50 +0000 Subject: Split out Thermoprint.Server.API --- server/src/Thermoprint/Server.hs | 105 ++++------------------------------- server/src/Thermoprint/Server/API.hs | 104 ++++++++++++++++++++++++++++++++++ server/thermoprint-server.cabal | 1 + 3 files changed, 117 insertions(+), 93 deletions(-) create mode 100644 server/src/Thermoprint/Server/API.hs (limited to 'server') diff --git a/server/src/Thermoprint/Server.hs b/server/src/Thermoprint/Server.hs index d1ee6ee..419679c 100644 --- a/server/src/Thermoprint/Server.hs +++ b/server/src/Thermoprint/Server.hs @@ -14,47 +14,34 @@ module Thermoprint.Server import Data.Default.Class import qualified Config.Dyre as Dyre -import System.IO (hPutStrLn, stderr) -import System.Exit (exitFailure) - -import Control.Monad ((<=<), mapM_, liftM2) -import Prelude hiding ((.), id) -import Control.Category +import Control.Monad (mapM_) import Data.Maybe (maybe) +import Control.Monad.Trans.Resource import Control.Monad.Logger import Control.Monad.Reader -import Control.Monad.Trans.Resource -import Control.Monad.Trans.Either import Control.Monad.IO.Class - -import Data.Functor.Compose - -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 Data.Text (Text) import qualified Data.Text as T (pack) import qualified Network.Wai.Handler.Warp as Warp import Network.Wai (Application) -import Servant -import Servant.Server -import Servant.Server.Internal.Enter +import Servant.Server (serve) +import Servant.Server.Internal.Enter (enter, (:~>)(..)) import Database.Persist.Sql (runMigrationSilent, ConnectionPool, runSqlPool) +import Thermoprint.API (thermoprintAPI) + import Thermoprint.Server.Database +import qualified Thermoprint.Server.API as API (thermoprintServer) +import Thermoprint.Server.API hiding (thermoprintServer) + data Config = Config { dyreError :: Maybe String -- ^ Set by 'Dyre' -- sent to log as an error , warpSettings :: Warp.Settings -- ^ Configure 'Warp's behaviour } @@ -64,9 +51,6 @@ instance Default Config where , warpSettings = Warp.defaultSettings } -data HandlerInput = HandlerInput { sqlPool :: ConnectionPool - } - thermoprintServer :: ( MonadLoggerIO m , MonadIO m @@ -82,70 +66,5 @@ thermoprintServer io = Dyre.wrapMain $ Dyre.defaultParams where realMain Config{..} = unNat io $ do maybe (return ()) ($(logErrorS) "Dyre" . T.pack) dyreError - - sqlPool <- ask - logFunc <- askLoggerIO - - runSqlPool (runMigrationSilent migrateAll) sqlPool >>= mapM_ ($(logWarnS) "DB") - - let - handlerInput = HandlerInput - { sqlPool = sqlPool - } - io' :: ProtoHandler :~> IO - io' = Nat (($ logFunc) . runLoggingT) . runReaderTNat handlerInput - liftIO . Warp.runSettings warpSettings . serve thermoprintAPI $ enter (hoistNat io') thermoprintServer' - -type ProtoHandler = ReaderT HandlerInput (LoggingT IO) -type Handler = EitherT ServantErr ProtoHandler - -(<||>) :: Monad m => m a -> m b -> m (a :<|> b) -(<||>) = liftM2 (:<|>) -infixr 9 <||> - -thermoprintServer' :: ServerT ThermoprintAPI Handler -thermoprintServer' = listPrinters - :<|> (listJobs :<|> queueJob) - :<|> getJob <||> jobStatus <||> deleteJob - :<|> (listDrafts :<|> addDraft) - :<|> updateDraft <||> getDraft <||> deleteDraft <||> printDraft - - -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 + mapM_ ($(logWarnS) "DB") =<< runSqlPool (runMigrationSilent migrateAll) =<< ask + liftIO . Warp.runSettings warpSettings . serve thermoprintAPI . flip enter API.thermoprintServer =<< handlerNat 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 diff --git a/server/thermoprint-server.cabal b/server/thermoprint-server.cabal index 45e57a6..45f24d3 100644 --- a/server/thermoprint-server.cabal +++ b/server/thermoprint-server.cabal @@ -19,6 +19,7 @@ cabal-version: >=1.10 library exposed-modules: Thermoprint.Server , Thermoprint.Server.Database + , Thermoprint.Server.API -- other-modules: -- other-extensions: build-depends: base >=4.8 && <5 -- cgit v1.2.3