diff options
| -rw-r--r-- | Com/MusicMeetsComics/Server.hs | 6 | ||||
| -rw-r--r-- | Run/Que/Server.hs | 84 | ||||
| -rw-r--r-- | Run/Que/Server.nix | 3 |
3 files changed, 41 insertions, 52 deletions
diff --git a/Com/MusicMeetsComics/Server.hs b/Com/MusicMeetsComics/Server.hs index a1a9981..c173bd3 100644 --- a/Com/MusicMeetsComics/Server.hs +++ b/Com/MusicMeetsComics/Server.hs @@ -71,7 +71,7 @@ import qualified System.IO as IO main :: IO () -main = bracket startup shutdown run +main = bracket startup shutdown $ uncurry Warp.run where say = IO.hPutStrLn IO.stderr startup = Envy.decodeEnv >>= \case @@ -81,10 +81,10 @@ main = bracket startup shutdown run say $ "hero" say $ "port: " ++ (show $ heroPort c) say $ "client: " ++ heroClient c - return (db, c) + let waiapp = app db c + return (heroPort c, waiapp) 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 diff --git a/Run/Que/Server.hs b/Run/Que/Server.hs index 5973ec2..45ad1bc 100644 --- a/Run/Que/Server.hs +++ b/Run/Que/Server.hs @@ -2,11 +2,14 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DeriveGeneric #-} -- | Interprocess communication -- -- : exe que-server +-- -- : dep async +-- : dep envy -- : dep protolude -- : dep scotty -- : dep stm @@ -41,38 +44,45 @@ import qualified Network.Wai as Wai import qualified Network.Wai.Handler.Warp as Warp import Network.Wai.Middleware.RequestLogger ( logStdout ) -import qualified System.Console.GetOpt as Opt -import qualified System.Environment as Environment +import qualified System.Envy as Envy +import qualified System.Exit as Exit import qualified Web.Scotty.Trans as Scotty main :: IO () -main = Exception.bracket startup shutdown run +main = Exception.bracket startup shutdown <| uncurry Warp.run where - run (p, waiapp) = - putText ("que-server starting on port " <> show p) >> Warp.run p waiapp - startup = do - opts <- Environment.getArgs /> getOpts - sync <- STM.newTVarIO opts - let runActionToIO m = runReaderT (runApp m) sync - waiapp <- Scotty.scottyAppT runActionToIO routes - return (port opts, waiapp) + startup = Envy.decodeEnv >>= \case + Left e -> Exit.die e + Right c -> do + sync <- STM.newTVarIO initialAppState + let runActionToIO m = runReaderT (runApp m) sync + waiapp <- Scotty.scottyAppT runActionToIO routes + putText <| "port:" <> (show <| quePort c) + return (quePort c, waiapp) shutdown :: a -> IO a shutdown = pure . identity - getOpts args = case Opt.getOpt Opt.Permute options args of - ([] , [], _) -> Exception.throw ErrorParsingOptions - (opts, _ , _) -> smoosh initialAppState opts - options = - [ Opt.Option - ['p'] - ["port"] - (Opt.ReqArg (\n m -> m { port = read n :: Warp.Port }) "PORT") - "port to run on " - ] - -data Error = ErrorParsingOptions - deriving (Show) - -instance Exception.Exception Error + +newtype App a = App + { runApp :: ReaderT (STM.TVar AppState) IO a + } + deriving (Applicative, Functor, Monad, MonadIO, MonadReader + (STM.TVar AppState)) + +data AppState = AppState + { ques :: HashMap Namespace Quebase + } + +initialAppState :: AppState +initialAppState = AppState { ques = mempty } + +data Config = Config + { quePort :: Warp.Port -- ^ QUE_PORT + } deriving (Generic, Show) + +instance Envy.DefConfig Config where + defConfig = Config 3000 + +instance Envy.FromEnv Config routes :: Scotty.ScottyT Text App () routes = do @@ -191,28 +201,6 @@ extract = do path <- Scotty.param "2" return (ns, path) -newtype App a = App - { runApp :: ReaderT (STM.TVar AppState) IO a - } - deriving (Applicative, Functor, Monad, MonadIO, MonadReader - (STM.TVar AppState)) - -data AppState = AppState - { ques :: HashMap Namespace Quebase - , port :: Warp.Port - } - -initialAppState :: AppState -initialAppState = AppState { port = 80, ques = mempty } - --- | Resolve a list of 'AppState' transitions into one. -smoosh - :: AppState -- ^ Initial app state to start with - -> [AppState -> AppState] -- ^ List of functions to apply in order - -> AppState -smoosh = foldr identity --- there's gotta be a standard name for this - -- | A synonym for 'lift' in order to be explicit about when we are -- operating at the 'App' layer. app :: MonadTrans t => App a -> t App a diff --git a/Run/Que/Server.nix b/Run/Que/Server.nix index 272ea6e..e326483 100644 --- a/Run/Que/Server.nix +++ b/Run/Que/Server.nix @@ -29,12 +29,13 @@ in path = [ cfg.package ]; wantedBy = [ "multi-user.target" ]; script = '' - ${cfg.package}/bin/que-server -p ${toString cfg.port} + ${cfg.package}/bin/que-server ''; description = '' Que server ''; serviceConfig = { + Environment = ["QUE_PORT=${toString cfg.port}"]; KillSignal = "INT"; Type = "simple"; Restart = "on-abort"; |