diff options
| -rw-r--r-- | .envrc | 7 | ||||
| -rw-r--r-- | Com/MusicMeetsComics/Server.hs | 62 | ||||
| -rw-r--r-- | Com/MusicMeetsComics/Server/Config.hs | 143 | ||||
| -rw-r--r-- | Com/MusicMeetsComics/Server/Init.hs | 49 | ||||
| -rw-r--r-- | Com/MusicMeetsComics/Server/Logger.hs | 51 | ||||
| -rw-r--r-- | Com/MusicMeetsComics/Service.nix | 4 | ||||
| -rw-r--r-- | deps.nix | 1 |
7 files changed, 49 insertions, 268 deletions
@@ -1,4 +1,11 @@ +# idk if these work export GUILE_LOAD_PATH=$PWD export NIX_PATH=$PWD:$NIX_PATH + +# tooling for bild/repl/push scripts export PATH=$PWD:$PATH export BIZ_ROOT=$PWD + +# defaults for doing dev stuff +export HERO_PORT=3000 +export HERO_CLIENT=$PWD/_bild/Com.MusicMeetsComics.Client/static diff --git a/Com/MusicMeetsComics/Server.hs b/Com/MusicMeetsComics/Server.hs index 5736688..a1a9981 100644 --- a/Com/MusicMeetsComics/Server.hs +++ b/Com/MusicMeetsComics/Server.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -16,26 +17,21 @@ -- : dep aeson -- : dep clay -- : dep containers --- : dep miso --- : dep protolude --- : dep servant --- : dep split --- : dep string-quote --- : dep text -- : dep dhall --- : dep ekg --- : dep fast-logger +-- : dep envy -- : dep http-types --- : dep katip -- : dep lucid --- : dep monad-logger --- : dep monad-metrics +-- : dep miso -- : dep mtl -- : dep network-uri --- : dep safe +-- : dep protolude +-- : dep servant -- : dep servant-lucid -- : dep servant-server -- : dep split +-- : dep split +-- : dep string-quote +-- : dep text -- : dep wai -- : dep wai-app-static -- : dep wai-extra @@ -47,10 +43,6 @@ import qualified Clay import Com.MusicMeetsComics.App import qualified Com.MusicMeetsComics.Assets as Assets import qualified Com.MusicMeetsComics.Database as Database -import qualified Com.MusicMeetsComics.Server.Config - as Config -import qualified Com.MusicMeetsComics.Server.Init - as Init import qualified Com.MusicMeetsComics.Look as Look import qualified Com.MusicMeetsComics.Look.Typography as Typography @@ -70,16 +62,41 @@ import Network.HTTP.Media ( (//) import Network.HTTP.Types hiding ( Header ) import Network.Wai import Network.Wai.Application.Static +import qualified Network.Wai.Handler.Warp as Warp import Protolude import Servant +import qualified System.Envy as Envy +import qualified System.Exit as Exit +import qualified System.IO as IO main :: IO () -main = do - db <- Database.dummy - Init.runApp (app db) - -app :: Database.ComicDB -> Config.Config -> Application +main = bracket startup shutdown run + where + say = IO.hPutStrLn IO.stderr + startup = Envy.decodeEnv >>= \case + Left e -> Exit.die e + Right c -> do + db <- Database.dummy + say $ "hero" + say $ "port: " ++ (show $ heroPort c) + say $ "client: " ++ heroClient c + return (db, c) + shutdown :: a -> IO a + shutdown = pure . identity + run (db, config) = Warp.run (heroPort config) (app db config) + +data Config = Config + { heroPort :: Warp.Port -- ^ HERO_PORT + , heroClient :: FilePath -- ^ HERO_CLIENT + } deriving (Generic, Show) + +instance Envy.DefConfig Config where + defConfig = Config 3000 "_bild/Com.MusicMeetsComics.Client/static" + +instance Envy.FromEnv Config + +app :: Database.ComicDB -> Config -> Application app db cfg = serve (Proxy @AllRoutes) ( static @@ -89,8 +106,7 @@ app db cfg = serve :<|> pure heroManifest :<|> Tagged handle404 ) - where - static = serveDirectoryWith $ defaultWebAppSettings $ Config.configClient cfg + where static = serveDirectoryWith $ defaultWebAppSettings $ heroClient cfg -- | HtmlPage for setting HTML doctype and header 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 diff --git a/Com/MusicMeetsComics/Service.nix b/Com/MusicMeetsComics/Service.nix index 9b8d91d..f0f4227 100644 --- a/Com/MusicMeetsComics/Service.nix +++ b/Com/MusicMeetsComics/Service.nix @@ -48,8 +48,8 @@ in serviceConfig = { KillSignal = "INT"; Environment = [ - "CLIENT_DIR=${cfg.client}/static" - "PORT=${toString cfg.port}" + "HERO_CLIENT=${cfg.client}/static" + "HERO_PORT=${toString cfg.port}" ]; Type = "simple"; Restart = "on-abort"; @@ -8,6 +8,7 @@ "containers" "dhall" "ekg" + "envy" "fast-logger" "ghcjs-base" "http-types" |