From 294c8e19b136f06ca7fa1bb4e4d109e90e2bb033 Mon Sep 17 00:00:00 2001 From: Ben Sima Date: Sat, 23 Nov 2019 16:38:47 -0800 Subject: Add Com.MusicMeetsComics --- Com/MusicMeetsComics/Server/Config.hs | 131 ++++++++++++++++++++++++++++++++++ Com/MusicMeetsComics/Server/Init.hs | 49 +++++++++++++ Com/MusicMeetsComics/Server/Logger.hs | 48 +++++++++++++ 3 files changed, 228 insertions(+) create mode 100644 Com/MusicMeetsComics/Server/Config.hs create mode 100644 Com/MusicMeetsComics/Server/Init.hs create mode 100644 Com/MusicMeetsComics/Server/Logger.hs (limited to 'Com/MusicMeetsComics/Server') 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] diff --git a/Com/MusicMeetsComics/Server/Init.hs b/Com/MusicMeetsComics/Server/Init.hs new file mode 100644 index 0000000..7ad3ebf --- /dev/null +++ b/Com/MusicMeetsComics/Server/Init.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Com.MusicMeetsComics.Server.Init where + +import qualified Com.MusicMeetsComics.Server.Config as Config +import Control.Concurrent (killThread) +import Control.Exception (bracket) +import qualified Control.Monad.Metrics as M +import qualified Katip +import Lens.Micro ((^.)) +import Network.Wai (Application, Middleware) +import Network.Wai.Handler.Warp (run) +import Network.Wai.Metrics (metrics, registerWaiMetrics) +import Network.Wai.Middleware.Gzip +import Protolude +import qualified System.IO as IO + +-- | An action that creates a WAI 'Application' together with its resources, +-- runs it, and tears it down on exit +runApp :: (Config.Config -> Application) -> IO () +runApp app = bracket Config.acquire shutdownApp jog + where + say = IO.hPutStrLn IO.stderr + jog config = do + say $ "hero" + say $ "port: " ++ show (Config.configPort config) + run (Config.configPort config) =<< initialize app config + +-- | The 'initialize' function accepts the required environment information, +-- initializes the WAI 'Application' and returns it +initialize :: (Config.Config -> Application) -> Config.Config -> IO Application +initialize app cfg = do + waiMetrics <- registerWaiMetrics (Config.configMetrics cfg ^. M.metricsStore) + let logger = Config.setLogger (Config.configEnv cfg) + -- generateJavaScript + pure . logger . metrics waiMetrics . app $ cfg + +compress :: Middleware +compress = gzip def { gzipFiles = GzipCompress } + +-- | Takes care of cleaning up 'Config.Config' resources +shutdownApp :: Config.Config -> IO () +shutdownApp cfg = do + _ <- Katip.closeScribes (Config.configLogEnv cfg) + -- Monad.Metrics does not provide a function to destroy metrics store + -- so, it'll hopefully get torn down when async exception gets thrown + -- at metrics server process + killThread (Config.configEkgServer cfg) + pure () diff --git a/Com/MusicMeetsComics/Server/Logger.hs b/Com/MusicMeetsComics/Server/Logger.hs new file mode 100644 index 0000000..eb37ef6 --- /dev/null +++ b/Com/MusicMeetsComics/Server/Logger.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Com.MusicMeetsComics.Server.Logger + ( adapt + , defaultLogEnv + , logMsg + , runKatipT + , KatipT(..) + , Katip(..) + , LogEnv + , Severity(..) + ) where + +import Control.Monad.Logger +import qualified Control.Monad.Logger as Logger +import Katip +import Protolude +import qualified System.IO as IO +import qualified System.Log.FastLogger as FastLogger + +defaultLogEnv :: IO LogEnv +defaultLogEnv = do + handleScribe <- mkHandleScribe ColorIfTerminal IO.stdout DebugS V2 + env <- initLogEnv "hero" "production" + registerScribe "stdout" handleScribe defaultScribeSettings env + +fromLevel :: LogLevel -> Severity +fromLevel LevelDebug = DebugS +fromLevel LevelInfo = InfoS +fromLevel LevelWarn = WarningS +fromLevel LevelError = ErrorS +fromLevel (LevelOther _) = NoticeS + +-- | Transforms Katip logMsg into monadLoggerLog to be used inside +-- MonadLogger monad +adapt :: + (ToLogStr msg, Applicative m, Katip m) + => (Namespace -> Severity -> Katip.LogStr -> m ()) + -> Loc + -> LogSource + -> LogLevel + -> msg + -> m () +adapt f _ src lvl msg = f ns (fromLevel lvl) $ logStr' msg + where + ns = Namespace [src] + -- not sure how fast this is going to be + logStr' = Katip.logStr . FastLogger.fromLogStr . Logger.toLogStr -- cgit v1.2.3