Add Com.MusicMeetsComics

3 files changed, 228 insertions, 0 deletions

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