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/default-conf/Main.hs | 17 ++++ server/src/Main.hs | 6 -- server/src/Thermoprint/Server.hs | 166 ++++++++++++++++++++++++++++++++++----- server/thermoprint-server.cabal | 25 +++++- server/thermoprint-server.nix | 16 ++-- 5 files changed, 198 insertions(+), 32 deletions(-) create mode 100644 server/default-conf/Main.hs delete mode 100644 server/src/Main.hs diff --git a/server/default-conf/Main.hs b/server/default-conf/Main.hs new file mode 100644 index 0000000..0aa7d91 --- /dev/null +++ b/server/default-conf/Main.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) where + +import Thermoprint.Server + +import Control.Monad.Trans.Resource +import Control.Monad.Logger +import Control.Monad.Reader + +import Database.Persist.Sqlite + +main :: IO () +main = thermoprintServer (Nat runSqlite) def + where + runSqlite :: ReaderT ConnectionPool (LoggingT (ResourceT IO)) a -> IO a + runSqlite = runResourceT . runStderrLoggingT . withSqlitePool ":memory:" 1 . runReaderT 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 diff --git a/server/thermoprint-server.cabal b/server/thermoprint-server.cabal index c8586ae..0aa1870 100644 --- a/server/thermoprint-server.cabal +++ b/server/thermoprint-server.cabal @@ -16,16 +16,35 @@ build-type: Simple -- extra-source-files: cabal-version: >=1.10 -executable thermoprint-server - main-is: Main.hs +library + exposed-modules: Thermoprint.Server -- other-modules: -- other-extensions: - build-depends: base >=4.8 && <4.9 + build-depends: base >=4.8 && <5 , thermoprint-spec ==3.0.* , dyre >=0.8.12 && <1 , data-default-class >=0.0.1 && <1 , wai >=3.0.4 && <4 , servant-server >=0.4.4 && <1 , warp >=3.1.9 && <4 + , persistent >=2.2 && <3 + , persistent-template >=2.1.4 && <3 + , transformers >=0.3.0 && <1 + , mtl >=2.2.1 && <3 + , resourcet >=1.1.7 && <2 + , monad-logger >=0.3.13 && <1 + , containers >=0.5.6 && <1 + , either >=4.4.1 && <5 hs-source-dirs: src + default-language: Haskell2010 + +executable thermoprint-server + main-is: Main.hs + build-depends: base >=4.8 && <5 + , thermoprint-server -any + , persistent-sqlite >=2.2 && <3 + , mtl >=2.2.1 && <3 + , resourcet >=1.1.7 && <2 + , monad-logger >=0.3.13 && <1 + hs-source-dirs: default-conf default-language: Haskell2010 \ No newline at end of file diff --git a/server/thermoprint-server.nix b/server/thermoprint-server.nix index 7154dc3..c6a6224 100644 --- a/server/thermoprint-server.nix +++ b/server/thermoprint-server.nix @@ -1,15 +1,21 @@ -{ mkDerivation, base, data-default-class, dyre, servant-server -, stdenv, thermoprint-spec, wai, warp +{ mkDerivation, base, containers, data-default-class, dyre, either +, monad-logger, mtl, persistent, persistent-sqlite +, persistent-template, resourcet, servant-server, stdenv +, thermoprint-spec, transformers, wai, warp }: mkDerivation { pname = "thermoprint-server"; version = "0.0.0"; src = ./.; - isLibrary = false; + isLibrary = true; isExecutable = true; + libraryHaskellDepends = [ + base containers data-default-class dyre either monad-logger mtl + persistent persistent-template resourcet servant-server + thermoprint-spec transformers wai warp + ]; executableHaskellDepends = [ - base data-default-class dyre servant-server thermoprint-spec wai - warp + base monad-logger mtl persistent-sqlite resourcet ]; homepage = "http://dirty-haskell.org/tags/thermoprint.html"; description = "Server for thermoprint-spec"; -- cgit v1.2.3