From 294c8e19b136f06ca7fa1bb4e4d109e90e2bb033 Mon Sep 17 00:00:00 2001
From: Ben Sima <ben@bsima.me>
Date: Sat, 23 Nov 2019 16:38:47 -0800
Subject: Add Com.MusicMeetsComics

---
 Com/MusicMeetsComics/Server/Config.hs | 131 ++++++++++++++++++++++++++++++++++
 1 file changed, 131 insertions(+)
 create mode 100644 Com/MusicMeetsComics/Server/Config.hs

(limited to 'Com/MusicMeetsComics/Server/Config.hs')

diff --git a/Com/MusicMeetsComics/Server/Config.hs b/Com/MusicMeetsComics/Server/Config.hs
new file mode 100644
index 0000000..2bbfabc
--- /dev/null
+++ b/Com/MusicMeetsComics/Server/Config.hs
@@ -0,0 +1,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 (ServantErr)
+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 ServantErr m) a
+  } deriving ( Functor
+             , Applicative
+             , Monad
+             , MonadReader Config
+             , MonadError ServantErr
+             , 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]
-- 
cgit v1.2.3