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 /server/src | |
parent | d776f630c6bf60a14e496694bcb502e93f215a41 (diff) | |
download | thermoprint-6348b2fb57b291b925ce27e9070eecc10d560608.tar thermoprint-6348b2fb57b291b925ce27e9070eecc10d560608.tar.gz thermoprint-6348b2fb57b291b925ce27e9070eecc10d560608.tar.bz2 thermoprint-6348b2fb57b291b925ce27e9070eecc10d560608.tar.xz thermoprint-6348b2fb57b291b925ce27e9070eecc10d560608.zip |
additional documentation
Diffstat (limited to 'server/src')
-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 |