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, nominalDiffTimeToSeconds, toGregorian)
+import Data.Time (Day, LocalTime (..), TimeOfDay (..), ZonedTime (..), addDays, toGregorian)
 import GHC.Generics (Generic)
 import Network.HTTP.Types (Status (..))
-import Network.Wai (Middleware, Request (..), responseStatus)
+import Network.Wai (Request (..))
 import Servant
   ( Capture
   , Get
@@ -60,8 +60,6 @@ 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
@@ -81,8 +79,8 @@ main :: IO ()
 main = do
   cfg <-
     Envy.load @ConfigT >>= \case
-      Left errs -> do
-        forM_ errs $ Log.error . printf "failed to read config: %s"
+      Left err -> do
+        Log.error $ printf "failed to read config: %s" err
         exitFailure
       Right c ->
         pure c
@@ -114,29 +112,24 @@ doIndex cfg db =
 
 runServer :: Config -> DB -> IO ()
 runServer cfg db =
-  Warp.runSettings settings $ loggerMiddleware $ serve (Proxy @API) $ hoistServer (Proxy @API) nt $ server cfg db
+  Warp.runSettings settings $ serve (Proxy @API) $ hoistServer (Proxy @API) nt $ server cfg db
   where
     settings =
       foldr
         ($)
         Warp.defaultSettings
-        [ Warp.setPort cfg.yorePort
+        [ Warp.setLogger logger
+        , Warp.setPort cfg.yorePort
         , Warp.setBeforeMainLoop $ Log.info $ printf "listening on port %d" cfg.yorePort
         , Warp.setOnException onException
         ]
 
-    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
+    logger req status _ = do
+      Log.info $
+        printf
+          "%d %s"
+          (statusCode status)
+          (requestLine req)
 
     onException mbReq ex = do
       Log.error $ printf "unhandled exception%s: %s%s" (maybe "" ((" in " ++) . requestLine) mbReq) (show ex)
@@ -148,18 +141,6 @@ 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 CAC30PXzQJosjH02Spia1vzj9Ui3LB1Cq2HI8r0A4eu33HP8ngxbbM2SzRfTj0c
+\restrict VcBcXJr0fe2fRf2im7J0PCentZxDeYMChdNcReN5LtHeQrg2nXyh5MelIBAiGsO
 
 -- 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 CAC30PXzQJosjH02Spia1vzj9Ui3LB1Cq2HI8r0A4eu33HP8ngxbbM2SzRfTj0c
+\unrestrict VcBcXJr0fe2fRf2im7J0PCentZxDeYMChdNcReN5LtHeQrg2nXyh5MelIBAiGsO
 
 
 --

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,15 +77,7 @@ 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 =
-    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
+  gFromEnv Proxy env = (:*:) <$> gFromEnv @i1 @o1 Proxy env <*> gFromEnv @i2 @o2 Proxy env
 
 instance
   (KnownSymbol sym, EnvVarSpec s t)
@@ -94,7 +86,7 @@ instance
       (M1 S meta2 (Rec0 t))
   where
   gFromEnv Proxy env =
-    M1 . K1 <$> first (: []) (decodeEnvVar @s @t Proxy varName (lookup varName env))
+    M1 . K1 <$> decodeEnvVar @s @t Proxy varName (lookup varName env)
     where
       varName = selectorNameToEnvVarName $ symbolVal $ Proxy @sym