aboutsummaryrefslogtreecommitdiff
path: root/server/src
diff options
context:
space:
mode:
authorGregor Kleen <gkleen@yggdrasil.li>2016-01-23 11:42:45 +0000
committerGregor Kleen <gkleen@yggdrasil.li>2016-01-23 11:42:45 +0000
commit6348b2fb57b291b925ce27e9070eecc10d560608 (patch)
tree227654643df6d2f9f75b65f72a097aed6343f1a7 /server/src
parentd776f630c6bf60a14e496694bcb502e93f215a41 (diff)
downloadthermoprint-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.hs5
-rw-r--r--server/src/Thermoprint/Server/API.hs7
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
41import qualified Thermoprint.Server.API as API (thermoprintServer) 41import qualified Thermoprint.Server.API as API (thermoprintServer)
42import Thermoprint.Server.API hiding (thermoprintServer) 42import Thermoprint.Server.API hiding (thermoprintServer)
43 43
44 44-- | Compile-time configuration for 'thermoprintServer'
45data Config = Config { dyreError :: Maybe String -- ^ Set by 'Dyre' -- sent to log as an error 45data 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
61thermoprintServer io = Dyre.wrapMain $ Dyre.defaultParams 62thermoprintServer 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
36type ProtoHandler = ReaderT HandlerInput (LoggingT IO) 36type ProtoHandler = ReaderT HandlerInput (LoggingT IO)
37type Handler = EitherT ServantErr ProtoHandler 37type Handler = EitherT ServantErr ProtoHandler
38 38
39data HandlerInput = HandlerInput { sqlPool :: ConnectionPool 39-- ^ Runtime configuration of our handlers
40data HandlerInput = HandlerInput { sqlPool :: ConnectionPool -- ^ How to interact with 'persistent' storage
40 } 41 }
41 42
42handlerNat :: ( MonadReader ConnectionPool m 43handlerNat :: ( 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
45handlerNat = do 49handlerNat = 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
56thermoprintServer :: ServerT ThermoprintAPI Handler 60thermoprintServer :: ServerT ThermoprintAPI Handler
61-- ^ A 'servant-server' for 'ThermoprintAPI'
57thermoprintServer = listPrinters 62thermoprintServer = listPrinters
58 :<|> (listJobs :<|> queueJob) 63 :<|> (listJobs :<|> queueJob)
59 :<|> getJob <||> jobStatus <||> deleteJob 64 :<|> getJob <||> jobStatus <||> deleteJob