From d27690786ed2056d64c882ac72825755110d4870 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 20 Jan 2016 19:57:15 +0000 Subject: Nonfunctional API framework for server --- server/src/Main.hs | 6 -- server/src/Thermoprint/Server.hs | 166 ++++++++++++++++++++++++++++++++++----- 2 files changed, 148 insertions(+), 24 deletions(-) delete mode 100644 server/src/Main.hs (limited to 'server/src') diff --git a/server/src/Main.hs b/server/src/Main.hs deleted file mode 100644 index e392fe1..0000000 --- a/server/src/Main.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Main (main) where - -import Thermoprint.Server - -main :: IO () -main = thermoprintServer def diff --git a/server/src/Thermoprint/Server.hs b/server/src/Thermoprint/Server.hs index 9b8d719..4018d17 100644 --- a/server/src/Thermoprint/Server.hs +++ b/server/src/Thermoprint/Server.hs @@ -1,8 +1,20 @@ -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} module Thermoprint.Server ( thermoprintServer , module Data.Default.Class + , module Servant.Server.Internal.Enter ) where import Data.Default.Class @@ -11,42 +23,160 @@ import qualified Config.Dyre as Dyre import System.IO (hPutStrLn, stderr) import System.Exit (exitFailure) -import Control.Monad ((<=<)) +import Control.Monad ((<=<), mapM_, liftM2) +import Prelude hiding ((.), id) +import Control.Category + +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 qualified Network.Wai.Handler.Warp as Warp import Network.Wai (Application) +import Servant import Servant.Server +import Servant.Server.Internal.Enter -import Thermoprint.API +import Database.Persist +import Database.Persist.Sql +import Database.Persist.TH data Config = Config { dyreError :: Maybe String , warpSettings :: Warp.Settings } instance Default Config where - def = Config { dyreError = Nothing + def = Config { dyreError = Nothing , warpSettings = Warp.defaultSettings } -thermoprintServer :: Config -> IO () -thermoprintServer = Dyre.wrapMain $ Dyre.defaultParams + +share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| +Job + content Printout +Draft + content Printout +|] + + +thermoprintServer :: ( MonadLogger m + , MonadIO m + , MonadBaseControl IO m + , MonadReader ConnectionPool m + ) => (m :~> IO) -> Config -> IO () +thermoprintServer io = Dyre.wrapMain $ Dyre.defaultParams { Dyre.projectName = "thermoprint-server" , Dyre.realMain = realMain <=< handleDyreErrors , Dyre.showError = (\cfg msg -> cfg { dyreError = Just msg }) } + where + handleDyreErrors cfg@(Config{..}) + | Just msg <- dyreError = do + hPutStrLn stderr msg + exitFailure + undefined + | otherwise = return cfg + + realMain (Config{..}) = enter io $ do + runSqlPool' (runMigrationSilent migrateAll) >>= mapM_ $(logWarn) + liftIO . Warp.runSettings warpSettings . serve thermoprintAPI $ enter (hoistNat io) thermoprintServer' + + +runSqlPool' :: ( MonadBaseControl IO m + , MonadReader ConnectionPool m + ) => SqlPersistT m a -> m a +runSqlPool' a = runSqlPool a =<< ask + +(<||>) :: Monad m => m a -> m b -> m (a :<|> b) +(<||>) = liftM2 (:<|>) +infixr 9 <||> + + +thermoprintServer' :: ( Monad m + ) => ServerT ThermoprintAPI (EitherT ServantErr m) +thermoprintServer' = listPrinters + :<|> queueJob <||> printerStatus + :<|> listJobs + :<|> getJob <||> jobStatus <||> getJobPrinter <||> deleteJob + :<|> (listDrafts :<|> addDraft) + :<|> updateDraft <||> getDraft <||> deleteDraft + + +listPrinters :: ( Monad m + ) => EitherT ServantErr m (Set PrinterId) +listPrinters = return Set.empty + +queueJob :: ( Monad m + ) => PrinterId + -> Printout + -> EitherT ServantErr m API.JobId +queueJob = return undefined + +printerStatus :: ( Monad m + ) => PrinterId + -> EitherT ServantErr m PrinterStatus +printerStatus = return undefined + +listJobs :: ( Monad m + ) => Maybe PrinterId + -> Maybe API.JobId + -> Maybe API.JobId + -> EitherT ServantErr m (Seq API.JobId) +listJobs = return undefined + +getJob :: ( Monad m + ) => API.JobId + -> EitherT ServantErr m Printout +getJob = return undefined + +jobStatus :: ( Monad m + ) => API.JobId + -> EitherT ServantErr m JobStatus +jobStatus = return undefined + +getJobPrinter :: ( Monad m + ) => API.JobId + -> EitherT ServantErr m PrinterId +getJobPrinter = return undefined + +deleteJob :: ( Monad m + ) => API.JobId + -> EitherT ServantErr m () +deleteJob = return undefined + +listDrafts :: ( Monad m + ) => EitherT ServantErr m (Set API.DraftId) +listDrafts = return undefined + +addDraft :: ( Monad m + ) => Printout + -> EitherT ServantErr m API.DraftId +addDraft = return undefined -handleDyreErrors :: Config -> IO Config -handleDyreErrors cfg - | Just msg <- dyreError cfg = do - hPutStrLn stderr msg - exitFailure - return undefined - | otherwise = return cfg - +updateDraft :: ( Monad m + ) => API.DraftId + -> Printout + -> EitherT ServantErr m () +updateDraft = return undefined -realMain :: Config -> IO () -realMain cfg@(Config{..}) = Warp.runSettings warpSettings $ serve thermoprintAPI thermoprintServer' +getDraft :: ( Monad m + ) => API.DraftId + -> EitherT ServantErr m Printout +getDraft = return undefined -thermoprintServer :: Server ThermoprintAPI -thermoprintServer = undefined +deleteDraft :: ( Monad m + ) => API.DraftId + -> EitherT ServantErr m () +deleteDraft = return undefined -- cgit v1.2.3