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
|
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
module Settlr.Config
( ScriptM
, Config(..)
, ConfigException(..)
, loadConfig
, withConfig
) where
import Data.Text (Text)
import qualified Data.Text as T
import Network.CGI (getVarWithDefault, getVar, scriptName, CGIT, CGI)
import Control.Exception (Exception)
import Control.Monad.Catch (MonadThrow, throwM)
import Control.Monad.Reader (ReaderT(runReaderT))
import Network.CGI.Monad (MonadCGI(..))
import Control.Monad.Trans (lift)
type ScriptM = ReaderT Config (CGIT IO)
instance MonadCGI ScriptM where
cgiAddHeader x y = lift $ cgiAddHeader x y
cgiGet x = lift $ cgiGet x
data Config = Config
{ cfgCssPath :: !Text -- ^ $SETTLR_CSS_PATH, defaults to "/settlr.css"
, cfgScriptPath :: !Text -- ^ $SETTLR_SCRIPT_PATH, defaults to the CGI variable $SCRIPT_PATH or "/"
, cfgDataPath :: !Text -- ^ $SETTLR_DATA_PATH, required
}
data ConfigException
= CfgDataPathNotSet
instance Show ConfigException where
show CfgDataPathNotSet = "Server misconfiguration: Required environment variable SETTLR_DATA_PATH not set."
instance Exception ConfigException
loadConfig :: MonadCGI m => MonadThrow m => m Config
loadConfig = do cssPath <- getVarWithDefault "SETTLR_CSS_PATH" "/settlr.css"
scriptPath' <- scriptName
scriptPath <- getVarWithDefault "SETTLR_SCRIPT_PATH" scriptPath'
dataPath <- getVar "SETTLR_DATA_PATH" >>= \case
Nothing -> throwM CfgDataPathNotSet
Just x -> pure x
pure $ Config { cfgCssPath = T.pack cssPath
, cfgScriptPath = T.pack scriptPath
, cfgDataPath = T.pack dataPath
}
withConfig :: ScriptM a -> CGI a
withConfig x = loadConfig >>= runReaderT x
|
