Add Biz.Log middleware that works with systemd

Perhaps this is not as performant as the wai-provided one, but it is *much*
simpler and follows my output format, which I think is much easier to quickly
read. Anyway I doubt logging will ever be a bottleneck, and if it is then I
should be able to create some instrument to detect that.

2 files changed, 32 insertions, 6 deletions

diff --git a/Biz/Devalloc.hs b/Biz/Devalloc.hs
index 842cf24..2efd8fb 100644
--- a/Biz/Devalloc.hs
+++ b/Biz/Devalloc.hs
@@ -101,7 +101,6 @@ import Network.HTTP.Req ((/:), (=:))
 import qualified Network.HTTP.Req as Req
 import qualified Network.Wai as Wai
 import qualified Network.Wai.Handler.Warp as Warp
-import Network.Wai.Middleware.RequestLogger (logStdout)
 import Servant
 import Servant.API.Generic (ToServantApi, genericApi, toServant, (:-))
 import qualified Servant.Auth as Auth
@@ -478,7 +477,18 @@ tidy :: Config -> IO ()
 tidy Config {..} = Directory.removeDirectoryRecursive keep
 
 run :: (Config, Wai.Application, Acid.AcidState Keep) -> IO ()
-run (cfg, app, _) = Warp.run (port cfg) (logStdout app)
+run (cfg, app, _) = Warp.run (port cfg) (logMiddleware app)
+
+logMiddleware :: Wai.Middleware
+logMiddleware app req sendResponse =
+  app req <| \res ->
+    Log.info
+      [ str <| Wai.requestMethod req,
+        show <| Wai.remoteHost req,
+        str <| Wai.rawPathInfo req
+      ]
+      >> Log.br
+      >> sendResponse res
 
 liveCookieSettings :: Auth.CookieSettings
 liveCookieSettings =
diff --git a/Biz/Log.hs b/Biz/Log.hs
index 8c7b043..9a790aa 100644
--- a/Biz/Log.hs
+++ b/Biz/Log.hs
@@ -22,15 +22,31 @@ where
 
 import Alpha hiding (pass)
 import qualified Data.Text as Text
-import Rainbow (chunk, fore, green, magenta, putChunk, red, white, yellow)
+import Rainbow (chunk, fore, green, magenta, red, white, yellow)
+import qualified Rainbow
+import qualified System.Environment as Env
+import qualified System.IO as IO
 import System.IO.Unsafe (unsafePerformIO)
 
 data Lvl = Good | Pass | Info | Warn | Fail | Mark
 
+-- | Get the environment. This should probably return 'Biz.Devalloc.Area'
+-- instead of 'String'.
+area :: String
+area =
+  Env.lookupEnv "AREA"
+    /> maybe "Test" identity
+    |> unsafePerformIO
+
 msg :: Lvl -> [Text] -> IO ()
-msg lvl labels = putChunk <| fore color <| clear <> txt <> "\r"
+msg lvl labels =
+  case area of
+    -- systemd doesn't render msgs produced by putChunk, so when live we don't
+    -- use rainbow at all
+    "Live" -> putStr txt
+    _ -> Rainbow.putChunk <| fore color <| clear <> chunk txt <> "\r"
   where
-    txt = chunk <| Text.intercalate gap (label : labels)
+    txt = Text.intercalate gap (label : labels)
     (color, label) = case lvl of
       Good -> (green, "good")
       Pass -> (green, "pass")
@@ -44,7 +60,7 @@ gap :: Text
 gap = ":  "
 
 br :: IO ()
-br = putChunk "\n"
+br = Rainbow.putChunk "\n" >> IO.hFlush stdout
 
 good, pass, info, warn, fail :: [Text] -> IO ()
 good = msg Good