1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
|
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
module Thermoprint.Server
( thermoprintServer
, Config(..)
, module Data.Default.Class
, module Servant.Server.Internal.Enter
) where
import Data.Default.Class
import qualified Config.Dyre as Dyre
import Control.Monad (mapM_)
import Data.Maybe (maybe)
import Control.Monad.Trans.Resource
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.IO.Class
import Data.Text (Text)
import qualified Data.Text as T (pack)
import qualified Network.Wai.Handler.Warp as Warp
import Network.Wai (Application)
import Servant.Server (serve)
import Servant.Server.Internal.Enter (enter, (:~>)(..))
import Database.Persist.Sql (runMigrationSilent, ConnectionPool, runSqlPool)
import Thermoprint.API (thermoprintAPI)
import Thermoprint.Server.Database
import qualified Thermoprint.Server.API as API (thermoprintServer)
import Thermoprint.Server.API hiding (thermoprintServer)
-- | Compile-time configuration for 'thermoprintServer'
data Config = Config { dyreError :: Maybe String -- ^ Set by 'Dyre' -- sent to log as an error
, warpSettings :: Warp.Settings -- ^ Configure 'Warp's behaviour
}
instance Default Config where
def = Config { dyreError = Nothing
, warpSettings = Warp.defaultSettings
}
thermoprintServer :: ( MonadLoggerIO m
, MonadIO m
, MonadBaseControl IO m
, MonadReader ConnectionPool m
) => (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.
-> Config -> IO ()
-- ^ Run the server
thermoprintServer io = Dyre.wrapMain $ Dyre.defaultParams
{ Dyre.projectName = "thermoprint-server"
, Dyre.realMain = realMain
, Dyre.showError = (\cfg msg -> cfg { dyreError = Just msg })
}
where
realMain Config{..} = unNat io $ do
maybe (return ()) ($(logErrorS) "Dyre" . T.pack) dyreError
mapM_ ($(logWarnS) "DB") =<< runSqlPool (runMigrationSilent migrateAll) =<< ask
liftIO . Warp.runSettings warpSettings . serve thermoprintAPI . flip enter API.thermoprintServer =<< handlerNat
|
