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
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
|
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Com.MusicMeetsComics.Server.Config where
import Com.MusicMeetsComics.Server.Logger
import Control.Concurrent (ThreadId)
import Control.Monad.Except (ExceptT, MonadError)
import Control.Monad.IO.Class
import Control.Monad.Logger (MonadLogger(..))
import Control.Monad.Metrics (Metrics, MonadMetrics, getMetrics)
import qualified Control.Monad.Metrics as M
import Control.Monad.Reader (MonadIO, MonadReader, ReaderT, asks)
import Data.Text (pack)
import GHC.Base (String)
import Network.Wai (Middleware)
import Network.Wai.Handler.Warp (Port)
import Network.Wai.Middleware.RequestLogger (logStdout, logStdoutDev)
import Protolude
import Safe (readMay)
import Servant (ServerError)
import System.Environment (lookupEnv)
import System.Remote.Monitoring (forkServer, serverMetricStore, serverThreadId)
-- | This type represents the effects we want to have for our application.
-- We wrap the standard Servant monad with 'ReaderT Config', which gives us
-- access to the application configuration using the 'MonadReader'
-- interface's 'ask' function.
--
-- By encapsulating the effects in our newtype, we can add layers to the
-- monad stack without having to modify code that uses the current layout.
newtype AppT m a = AppT
{ runApp :: ReaderT Config (ExceptT ServerError m) a
} deriving ( Functor
, Applicative
, Monad
, MonadReader Config
, MonadError ServerError
, MonadIO
)
type App = AppT IO
-- | The Config for our application is (for now) the 'Environment' we're
-- running in and a Persistent 'ConnectionPool'.
data Config = Config
{ configEnv :: Environment
, configMetrics :: Metrics
, configEkgServer :: ThreadId
, configLogEnv :: LogEnv
, configPort :: Port
}
instance Monad m => MonadMetrics (AppT m) where
getMetrics = asks configMetrics
-- | Katip instance for @AppT m@
instance MonadIO m => Katip (AppT m) where
getLogEnv = asks configLogEnv
localLogEnv = panic "not implemented"
-- | MonadLogger instance to use within @AppT m@
instance MonadIO m => MonadLogger (AppT m) where
monadLoggerLog = adapt logMsg
-- | MonadLogger instance to use in @makePool@
instance MonadIO m => MonadLogger (KatipT m) where
monadLoggerLog = adapt logMsg
-- | Right now, we're distinguishing between three environments. We could
-- also add a @Staging@ environment if we needed to.
data Environment
= Development
| Test
| Production
deriving (Eq, Show, Read)
-- | This returns a 'Middleware' based on the environment that we're in.
setLogger :: Environment -> Middleware
setLogger Test = identity
setLogger Development = logStdoutDev
setLogger Production = logStdout
-- | Web request logger (currently unimplemented and unused). For inspiration
-- see ApacheLogger from wai-logger package.
katipLogger :: LogEnv -> Middleware
katipLogger env app req respond =
runKatipT env $ do
logMsg "web" InfoS "todo: received some request"
-- todo: log proper request data
liftIO $ app req respond
-- | The number of pools to use for a given environment.
envPool :: Environment -> Int
envPool Test = 1
envPool Development = 1
envPool Production = 8
-- | Allocates resources for 'Config'
acquire :: IO Config
acquire = do
port <- lookupSetting "PORT" 3001
env <- lookupSetting "ENV" Development
logEnv <- defaultLogEnv
ekgServer <- forkServer "localhost" 8000
let store = serverMetricStore ekgServer
metr <- M.initializeWith store
pure
Config
{ configEnv = env
, configMetrics = metr
, configLogEnv = logEnv
, configPort = port
, configEkgServer = serverThreadId ekgServer
}
-- | Looks up a setting in the environment, with a provided default, and
-- 'read's that information into the inferred type.
lookupSetting :: Read a => String -> a -> IO a
lookupSetting env def_ = do
maybeValue <- lookupEnv env
case maybeValue of
Nothing -> return def_
Just str -> maybe (handleFailedRead str) return (readMay str)
where
handleFailedRead str = panic
$ mconcat ["Failed to read [[", pack str, "]] for environment variable ", pack env]
|
