From ca7ac04518b57180cd6cb0d46bc12fadeb7406ee Mon Sep 17 00:00:00 2001
From: Ben Sima <ben@bsima.me>
Date: Fri, 10 Apr 2020 23:39:07 -0700
Subject: Switch que-server to envy

---
 Com/MusicMeetsComics/Server.hs |  6 +--
 Run/Que/Server.hs              | 84 ++++++++++++++++++------------------------
 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";
-- 
cgit v1.2.3