Use envy in Main.hs

app/Main.hs

@@ -1,14 +1,19 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ExplicitNamespaces #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeSynonymInstances #-}
 
 module Main (main) where
 
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Trans.Except (ExceptT (..), runExceptT)
 import Data.Proxy (Proxy (..))
+import Data.Text (Text)
 import Data.Time (Day, toGregorian)
 import GHC.Generics (Generic)
 import Network.HTTP.Media ((//), (/:))
@@ -47,6 +52,7 @@ import qualified Network.Wai.Handler.Warp as Warp
 import qualified Text.Blaze.Html5 as H
 import qualified Text.Blaze.Html5.Attributes as A
 
+import Envy (type (=@!), type (=@@), type (?))
 import Yore.DB (DayFile (..))
 import Yore.Error (Error (..))
 import Yore.Time (addYears, getCurrentDay, getSecondsUntilMidnight)
@@ -55,27 +61,41 @@ import qualified Envy
 import qualified Yore.DB as DB
 import qualified Yore.Log as Log
 
-data Config f = Config
+newtype ConnectionString = ConnectionString String
-  { port :: Envy.Env f (Envy.Optional Integer 3000)
+  deriving (Show)
-  , downloadDir :: Envy.Env f (Envy.Optional String "download")
+
-  , factor :: Envy.Env f (Envy.Required Rational)
+instance Envy.ReadEnvVar ConnectionString where
-  , factorFallback :: Envy.Env f (Envy.Optional Rational '(1, 1))
+  readEnvVar = fmap ConnectionString . Envy.readEnvVar
+
+data ConfigT f = Config
+  { yorePort :: f =@@ Int ? 3000
+  , yoreDownloadDir :: f =@@ FilePath ? "./download"
+  , yoreDb :: f =@! Text
   }
   deriving (Generic)
 
+type Config = ConfigT Envy.Value
+
+deriving instance Show Config
+
 main :: IO ()
 main = do
-  print . port =<< Envy.load @Config
+  cfg <- Envy.load @ConfigT
-  print . downloadDir =<< Envy.load @Config
+  -- _ <- exitSuccess
-  print . factor =<< Envy.load @Config
+
   let
     settings =
-      Warp.setLogger logger $
+      foldr
-        Warp.setPort 3000 $
+        ($)
-          Warp.setOnException onException Warp.defaultSettings
+        Warp.defaultSettings
+        [ Warp.setLogger logger
+        , Warp.setPort cfg.yorePort
+        , Warp.setBeforeMainLoop $ Log.info $ printf "listening on port %d" cfg.yorePort
+        , Warp.setOnException onException
+        ]
 
-  db <- DB.initDB "host=localhost user=yore-test port=5433 dbname=yore-test"
+  db <- DB.initDB cfg.yoreDb
-  Warp.runSettings settings $ serve (Proxy :: Proxy API) $ hoistServer (Proxy :: Proxy API) nt $ server db
+  Warp.runSettings settings $ serve (Proxy :: Proxy API) $ hoistServer (Proxy :: Proxy API) nt $ server cfg db
   where
     logger req status _ = do
       Log.info $
@@ -132,8 +152,8 @@ handlerToRaw handler = Tagged $ \_ respond -> do
     Right response ->
       respond response
 
-server :: DB.DB -> ServerT API (ExceptT Error IO)
+server :: Config -> DB.DB -> ServerT API (ExceptT Error IO)
-server db = rootR :<|> todayR :<|> apiTodayR
+server cfg db = rootR :<|> todayR :<|> apiTodayR
   where
     rootR = todayR 0
 
@@ -146,7 +166,7 @@ server db = rootR :<|> todayR :<|> apiTodayR
     apiTodayR issue = handlerToRaw $ do
       dateThen <- ExceptT get100YearsAgo
       dayFile <- ExceptT $ DB.withConn db $ DB.getDayFileByIssue dateThen issue
-      let fullPath = "download" </> dayFile.relative_path
+      let fullPath = cfg.yoreDownloadDir </> dayFile.relative_path
       secondsUntilMidnight <- liftIO getSecondsUntilMidnight
       pure $
         responseFile

src/Yore/Log.hs

@@ -15,7 +15,7 @@ doLog :: (HasCallStack) => String -> String -> IO ()
 doLog level msg = do
   now <- getZonedTime
   let location = getLocation $ getCallStack callStack
-  printf "(%s) (%s) (%s) %s\n" (iso8601Show now) location level msg
+  printf "(%s) (%s) (%s) %s\n" (iso8601Show now) level location msg
   where
     getLocation :: [(String, SrcLoc)] -> String
     -- First entry is always a function from this module, skip it