diff options
| author | Gregor Kleen <gkleen@yggdrasil.li> | 2016-01-23 11:42:45 +0000 |
|---|---|---|
| committer | Gregor Kleen <gkleen@yggdrasil.li> | 2016-01-23 11:42:45 +0000 |
| commit | 6348b2fb57b291b925ce27e9070eecc10d560608 (patch) | |
| tree | 227654643df6d2f9f75b65f72a097aed6343f1a7 | |
| parent | d776f630c6bf60a14e496694bcb502e93f215a41 (diff) | |
| download | thermoprint-6348b2fb57b291b925ce27e9070eecc10d560608.tar thermoprint-6348b2fb57b291b925ce27e9070eecc10d560608.tar.gz thermoprint-6348b2fb57b291b925ce27e9070eecc10d560608.tar.bz2 thermoprint-6348b2fb57b291b925ce27e9070eecc10d560608.tar.xz thermoprint-6348b2fb57b291b925ce27e9070eecc10d560608.zip | |
additional documentation
| -rw-r--r-- | server/src/Thermoprint/Server.hs | 5 | ||||
| -rw-r--r-- | server/src/Thermoprint/Server/API.hs | 7 |
2 files changed, 9 insertions, 3 deletions
diff --git a/server/src/Thermoprint/Server.hs b/server/src/Thermoprint/Server.hs index 419679c..0d96de0 100644 --- a/server/src/Thermoprint/Server.hs +++ b/server/src/Thermoprint/Server.hs | |||
| @@ -41,7 +41,7 @@ import Thermoprint.Server.Database | |||
| 41 | import qualified Thermoprint.Server.API as API (thermoprintServer) | 41 | import qualified Thermoprint.Server.API as API (thermoprintServer) |
| 42 | import Thermoprint.Server.API hiding (thermoprintServer) | 42 | import Thermoprint.Server.API hiding (thermoprintServer) |
| 43 | 43 | ||
| 44 | 44 | -- | Compile-time configuration for 'thermoprintServer' | |
| 45 | data Config = Config { dyreError :: Maybe String -- ^ Set by 'Dyre' -- sent to log as an error | 45 | data Config = Config { dyreError :: Maybe String -- ^ Set by 'Dyre' -- sent to log as an error |
| 46 | , warpSettings :: Warp.Settings -- ^ Configure 'Warp's behaviour | 46 | , warpSettings :: Warp.Settings -- ^ Configure 'Warp's behaviour |
| 47 | } | 47 | } |
| @@ -56,7 +56,8 @@ thermoprintServer :: ( MonadLoggerIO m | |||
| 56 | , MonadIO m | 56 | , MonadIO m |
| 57 | , MonadBaseControl IO m | 57 | , MonadBaseControl IO m |
| 58 | , MonadReader ConnectionPool m | 58 | , MonadReader ConnectionPool m |
| 59 | ) => (m :~> IO) -> Config -> IO () | 59 | ) => (m :~> IO) -- ^ 'dyre' controls the base of the monad-transformer-stack ('IO') but we let the user specify the rest of it. Therefore we require a specification of how to enter the stack. |
| 60 | -> Config -> IO () | ||
| 60 | -- ^ Run the server | 61 | -- ^ Run the server |
| 61 | thermoprintServer io = Dyre.wrapMain $ Dyre.defaultParams | 62 | thermoprintServer io = Dyre.wrapMain $ Dyre.defaultParams |
| 62 | { Dyre.projectName = "thermoprint-server" | 63 | { Dyre.projectName = "thermoprint-server" |
diff --git a/server/src/Thermoprint/Server/API.hs b/server/src/Thermoprint/Server/API.hs index 9559ad1..e147ac3 100644 --- a/server/src/Thermoprint/Server/API.hs +++ b/server/src/Thermoprint/Server/API.hs | |||
| @@ -36,12 +36,16 @@ import Database.Persist.Sql | |||
| 36 | type ProtoHandler = ReaderT HandlerInput (LoggingT IO) | 36 | type ProtoHandler = ReaderT HandlerInput (LoggingT IO) |
| 37 | type Handler = EitherT ServantErr ProtoHandler | 37 | type Handler = EitherT ServantErr ProtoHandler |
| 38 | 38 | ||
| 39 | data HandlerInput = HandlerInput { sqlPool :: ConnectionPool | 39 | -- ^ Runtime configuration of our handlers |
| 40 | data HandlerInput = HandlerInput { sqlPool :: ConnectionPool -- ^ How to interact with 'persistent' storage | ||
| 40 | } | 41 | } |
| 41 | 42 | ||
| 42 | handlerNat :: ( MonadReader ConnectionPool m | 43 | handlerNat :: ( MonadReader ConnectionPool m |
| 43 | , MonadLoggerIO m | 44 | , MonadLoggerIO m |
| 44 | ) => m (Handler :~> EitherT ServantErr IO) | 45 | ) => m (Handler :~> EitherT ServantErr IO) |
| 46 | -- ^ Servant requires its handlers to be 'EitherT ServantErr IO' | ||
| 47 | -- | ||
| 48 | -- This generates a 'Nat'ural transformation for squashing the monad-transformer-stack we use in our handlers to the monad 'servant-server' wants | ||
| 45 | handlerNat = do | 49 | handlerNat = do |
| 46 | sqlPool <- ask | 50 | sqlPool <- ask |
| 47 | logFunc <- askLoggerIO | 51 | logFunc <- askLoggerIO |
| @@ -54,6 +58,7 @@ handlerNat = do | |||
| 54 | return $ hoistNat protoNat | 58 | return $ hoistNat protoNat |
| 55 | 59 | ||
| 56 | thermoprintServer :: ServerT ThermoprintAPI Handler | 60 | thermoprintServer :: ServerT ThermoprintAPI Handler |
| 61 | -- ^ A 'servant-server' for 'ThermoprintAPI' | ||
| 57 | thermoprintServer = listPrinters | 62 | thermoprintServer = listPrinters |
| 58 | :<|> (listJobs :<|> queueJob) | 63 | :<|> (listJobs :<|> queueJob) |
| 59 | :<|> getJob <||> jobStatus <||> deleteJob | 64 | :<|> getJob <||> jobStatus <||> deleteJob |
