dbmate changes

app/Main.hs

@@ -17,10 +17,10 @@ import Control.Monad.Trans.Except (ExceptT (..), catchE, runExceptT)
 import Data.Bifunctor (Bifunctor (..))
 import Data.Proxy (Proxy (..))
 import Data.Text (Text)
-import Data.Time (Day, LocalTime (..), TimeOfDay (..), ZonedTime (..), addDays, toGregorian)
+import Data.Time (Day, LocalTime (..), TimeOfDay (..), ZonedTime (..), addDays, nominalDiffTimeToSeconds, toGregorian)
 import GHC.Generics (Generic)
 import Network.HTTP.Types (Status (..))
-import Network.Wai (Request (..))
+import Network.Wai (Middleware, Request (..), responseStatus)
 import Servant
   ( Capture
   , Get
@@ -60,6 +60,8 @@ import Yore.Scrape (Issue (..), getIssuesByDay)
 import Yore.Servant (GetSendfile, HTML, Sendfile (..))
 import Yore.Time (addYears, getCurrentDay, getSecondsUntilMidnight)
 
+import Data.Fixed (Pico)
+import Data.Time.Clock.POSIX (getPOSIXTime)
 import qualified Envy
 import qualified Yore.DB as DB
 import qualified Yore.Log as Log
@@ -79,8 +81,8 @@ main :: IO ()
 main = do
   cfg <-
     Envy.load @ConfigT >>= \case
-      Left err -> do
-        Log.error $ printf "failed to read config: %s" err
+      Left errs -> do
+        forM_ errs $ Log.error . printf "failed to read config: %s"
         exitFailure
       Right c ->
         pure c
@@ -112,24 +114,29 @@ doIndex cfg db =
 
 runServer :: Config -> DB -> IO ()
 runServer cfg db =
-  Warp.runSettings settings $ serve (Proxy @API) $ hoistServer (Proxy @API) nt $ server cfg db
+  Warp.runSettings settings $ loggerMiddleware $ serve (Proxy @API) $ hoistServer (Proxy @API) nt $ server cfg db
   where
     settings =
       foldr
         ($)
         Warp.defaultSettings
-        [ Warp.setLogger logger
-        , Warp.setPort cfg.yorePort
+        [ Warp.setPort cfg.yorePort
         , Warp.setBeforeMainLoop $ Log.info $ printf "listening on port %d" cfg.yorePort
         , Warp.setOnException onException
         ]
 
-    logger req status _ = do
-      Log.info $
-        printf
-          "%d %s"
-          (statusCode status)
-          (requestLine req)
+    logger :: Request -> Status -> Pico -> IO ()
+    logger req status s = do
+      Log.info $ printf "%d %s %ss" (statusCode status) (requestLine req) (formatMetric s)
+
+    loggerMiddleware :: Middleware
+    loggerMiddleware app req respond = do
+      begin <- getPOSIXTime
+      app req $ \res -> do
+        rr <- respond res
+        end <- getPOSIXTime
+        logger req (responseStatus res) (nominalDiffTimeToSeconds (end - begin))
+        pure rr
 
     onException mbReq ex = do
       Log.error $ printf "unhandled exception%s: %s%s" (maybe "" ((" in " ++) . requestLine) mbReq) (show ex)
@@ -141,6 +148,18 @@ runServer cfg db =
         (BS8.unpack $ requestMethod req)
         (BS8.unpack $ rawPathInfo req <> rawQueryString req)
 
+formatMetric :: Pico -> String
+formatMetric x = go (-9) prefixes
+  where
+    prefixes = ["p", "n", "u", "m", "", "k", "M", "G"]
+
+    go :: Int -> [String] -> String
+    go _ [] = show x
+    go e (p : ps)
+      | x < 10 ^^ e =
+          show @Int (floor $ x * 10 ^^ (-e + 3)) ++ p
+      | otherwise = go (e + 3) ps
+
 nt :: ExceptT Error IO a -> Handler a
 nt action = MkHandler $ do
   res <- runExceptT action

db/schema.sql

@@ -1,4 +1,4 @@
-\restrict VcBcXJr0fe2fRf2im7J0PCentZxDeYMChdNcReN5LtHeQrg2nXyh5MelIBAiGsO
+\restrict CAC30PXzQJosjH02Spia1vzj9Ui3LB1Cq2HI8r0A4eu33HP8ngxbbM2SzRfTj0c
 
 -- Dumped from database version 17.6
 -- Dumped by pg_dump version 17.6
@@ -129,7 +129,7 @@ ALTER TABLE ONLY yore.day_file
 -- PostgreSQL database dump complete
 --
 
-\unrestrict VcBcXJr0fe2fRf2im7J0PCentZxDeYMChdNcReN5LtHeQrg2nXyh5MelIBAiGsO
+\unrestrict CAC30PXzQJosjH02Spia1vzj9Ui3LB1Cq2HI8r0A4eu33HP8ngxbbM2SzRfTj0c
 
 
 --

src/Envy.hs

@@ -56,13 +56,13 @@ type t ? d = Optional t d
 load
   :: forall (m :: ConfigVariant -> Type)
    . (Generic (m Value), GFromEnv (Rep (m Spec)) (Rep (m Value)))
-  => IO (Either String (m Value))
+  => IO (Either [String] (m Value))
 load = do
   env <- getEnvironment
   pure $ to <$> gFromEnv @(Rep (m Spec)) @(Rep (m Value)) Proxy env
 
 class GFromEnv spec value where
-  gFromEnv :: Proxy (spec c) -> [(String, String)] -> Either String (value c)
+  gFromEnv :: Proxy (spec c) -> [(String, String)] -> Either [String] (value c)
 
 instance
   (GFromEnv i o)
@@ -77,7 +77,15 @@ instance
   gFromEnv Proxy env = M1 <$> gFromEnv @i @o Proxy env
 
 instance (GFromEnv i1 o1, GFromEnv i2 o2) => GFromEnv (i1 :*: i2) (o1 :*: o2) where
-  gFromEnv Proxy env = (:*:) <$> gFromEnv @i1 @o1 Proxy env <*> gFromEnv @i2 @o2 Proxy env
+  gFromEnv Proxy env =
+    case (eLhs, eRhs) of
+      (Left errs1, Right _) -> Left errs1
+      (Right _, Left errs2) -> Left errs2
+      (Left errs1, Left errs2) -> Left $ errs1 ++ errs2
+      (Right lhs, Right rhs) -> Right $ lhs :*: rhs
+    where
+      eLhs = gFromEnv @i1 @o1 Proxy env
+      eRhs = gFromEnv @i2 @o2 Proxy env
 
 instance
   (KnownSymbol sym, EnvVarSpec s t)
@@ -86,7 +94,7 @@ instance
       (M1 S meta2 (Rec0 t))
   where
   gFromEnv Proxy env =
-    M1 . K1 <$> decodeEnvVar @s @t Proxy varName (lookup varName env)
+    M1 . K1 <$> first (: []) (decodeEnvVar @s @t Proxy varName (lookup varName env))
     where
       varName = selectorNameToEnvVarName $ symbolVal $ Proxy @sym