From 76112b8bd26c0e282d5479ccae9d79c4dc28c35d Mon Sep 17 00:00:00 2001 From: Ben Sima Date: Fri, 10 Apr 2020 17:49:01 -0700 Subject: Replace Config/Init/Logger with envy and simpler code Idk what I was thinking, I dodn't need any of that stuff. --- Com/MusicMeetsComics/Server/Config.hs | 143 ---------------------------------- Com/MusicMeetsComics/Server/Init.hs | 49 ------------ Com/MusicMeetsComics/Server/Logger.hs | 51 ------------ 3 files changed, 243 deletions(-) delete mode 100644 Com/MusicMeetsComics/Server/Config.hs delete mode 100644 Com/MusicMeetsComics/Server/Init.hs delete 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 deleted file mode 100644 index 0de3379..0000000 --- a/Com/MusicMeetsComics/Server/Config.hs +++ /dev/null @@ -1,143 +0,0 @@ -{-# 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 - , configClient :: FilePath - } - -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 - clientDir <- lookupSetting "CLIENT_DIR" - "_bild/Com.MusicMeetsComics.Client/static" - 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 - , configClient = clientDir - } - --- | 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 deleted file mode 100644 index 04ddc88..0000000 --- a/Com/MusicMeetsComics/Server/Init.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# 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 shutdown 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 -shutdown :: Config.Config -> IO () -shutdown 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 deleted file mode 100644 index 5091b23..0000000 --- a/Com/MusicMeetsComics/Server/Logger.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} -module Com.MusicMeetsComics.Server.Logger - ( adapt - , defaultLogEnv - , Katip.logMsg - , Katip.runKatipT - , Katip.KatipT(..) - , Katip.Katip(..) - , Katip.LogEnv - , Katip.Severity(..) - ) -where - -import qualified Control.Monad.Logger as Logger -import qualified Katip -import Protolude -import qualified System.IO as IO -import qualified System.Log.FastLogger as FastLogger - -defaultLogEnv :: IO Katip.LogEnv -defaultLogEnv = do - handleScribe <- Katip.mkHandleScribe Katip.ColorIfTerminal - IO.stdout - (Katip.permitItem Katip.DebugS) - Katip.V2 - env <- Katip.initLogEnv "hero" "production" - Katip.registerScribe "stdout" handleScribe Katip.defaultScribeSettings env - -fromLevel :: Logger.LogLevel -> Katip.Severity -fromLevel Logger.LevelDebug = Katip.DebugS -fromLevel Logger.LevelInfo = Katip.InfoS -fromLevel Logger.LevelWarn = Katip.WarningS -fromLevel Logger.LevelError = Katip.ErrorS -fromLevel (Logger.LevelOther _) = Katip.NoticeS - --- | Transforms Katip logMsg into monadLoggerLog to be used inside --- MonadLogger monad -adapt - :: (FastLogger.ToLogStr msg, Applicative m, Katip.Katip m) - => (Katip.Namespace -> Katip.Severity -> Katip.LogStr -> m ()) - -> Logger.Loc - -> Logger.LogSource - -> Logger.LogLevel - -> msg - -> m () -adapt f _ src lvl msg = f ns (fromLevel lvl) $ logStr' msg - where - ns = Katip.Namespace [src] - -- not sure how fast this is going to be - logStr' = Katip.logStr . FastLogger.fromLogStr . Logger.toLogStr -- cgit v1.2.3