Add Yore.Config

app/Main.hs

@@ -31,6 +31,7 @@ import Servant
   , (:>)
   , pattern MkHandler
   )
+import System.Exit (exitWith, ExitCode (..))
 import System.FilePath ((</>))
 import Text.Blaze.Html.Renderer.Utf8 (renderHtml)
 import Text.Blaze.Html5 ((!))
@@ -50,11 +51,18 @@ import Yore.DB (DayFile (..))
 import Yore.Error (Error (..))
 import Yore.Time (addYears, getCurrentDay, getSecondsUntilMidnight)
 
+import qualified Yore.Config as Config
 import qualified Yore.DB as DB
 import qualified Yore.Log as Log
 
 main :: IO ()
 main = do
+  cfg <- Config.load @Config.Config >>= \case
+    Left err -> do
+      Log.error err
+      exitWith $ ExitFailure 1
+    Right cfg ->
+      pure cfg
   db <- DB.initDB "host=localhost user=yore-test port=5433 dbname=yore-test"
   Warp.runSettings settings $ serve (Proxy :: Proxy API) $ hoistServer (Proxy :: Proxy API) nt $ server db
   where

src/Yore/Config.hs

@@ -0,0 +1,92 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Yore.Config (Config (..), load) where
+
+import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Trans.Except (ExceptT (..), except, runExceptT)
+import Data.Char (isLower, isUpper, toUpper)
+import Data.Kind (Type)
+import Data.Proxy (Proxy (..))
+import Data.Typeable (Typeable, typeRep)
+import GHC.Generics (C, D, Generic, K1 (..), M1 (..), Meta (..), Rec0, Rep, S, to, (:*:) (..))
+import GHC.TypeLits (KnownSymbol, symbolVal)
+import System.Environment (lookupEnv)
+import Text.Printf (printf)
+import Text.Read (readEither)
+
+data Config = Config
+  { port :: Maybe Int
+  , downloadDir :: FilePath
+  }
+  deriving (Generic, Show)
+
+instance FromEnv Config where
+  prefix _ = "YORE_"
+
+class FromEnv c where
+  prefix :: Proxy c -> String
+  prefix _ = ""
+
+  load :: IO (Either String c)
+  default load :: (Generic c, FromEnv' (Rep c)) => IO (Either String c)
+  load = runExceptT $ to <$> load' (prefix @c Proxy)
+
+class FromEnv' (f :: Type -> Type) where
+  load' :: String -> ExceptT String IO (f p)
+
+instance (FromEnv' f) => FromEnv' (M1 D c f) where
+  load' p = M1 <$> load' p
+
+instance (FromEnv' f) => FromEnv' (M1 C c f) where
+  load' p = M1 <$> load' p
+
+instance (FromEnv' f, FromEnv' g) => FromEnv' (f :*: g) where
+  load' p = (:*:) <$> load' p <*> load' p
+
+instance (KnownSymbol nameSym, FromEnvVar t) => FromEnv' (M1 S ('MetaSel ('Just nameSym) nu ns dl) (Rec0 t)) where
+  load' p = M1 . K1 <$> fromEnvVar (p ++ toEnvName (symbolVal @nameSym Proxy))
+
+class FromEnvVar t where
+  fromEnvVar :: String -> ExceptT String IO t
+
+instance {-# OVERLAPPABLE #-} (ReadEnvVar t, Typeable t) => FromEnvVar t where
+  fromEnvVar key = do
+    value <-
+      ExceptT $
+        maybe (Left $ printf "env var %s is not set, expected %s" key (show $ typeRep $ Proxy @t)) Right <$> lookupEnv key
+    let contextualize =
+          printf "env var %s is malformed: could not read %s into %s: %s" key value (show $ typeRep $ Proxy @t)
+    except $ either (Left . contextualize) Right $ readEnvVar value
+
+instance {-# OVERLAPPABLE #-} (ReadEnvVar t, Typeable t) => FromEnvVar (Maybe t) where
+  fromEnvVar key = do
+    mbValue <- liftIO $ lookupEnv key
+    case mbValue of
+      Nothing -> pure Nothing
+      Just value -> do
+        let contextualize =
+              printf
+                "optional env var %s is malformed (provide valid content or unset it): could not read %s into %s: %s"
+                key
+                value
+                (show $ typeRep $ Proxy @t)
+
+        except $ either (Left . contextualize) (Right . Just) $ readEnvVar value
+
+class ReadEnvVar t where
+  readEnvVar :: String -> Either String t
+
+instance ReadEnvVar Int where
+  readEnvVar = readEither
+
+instance ReadEnvVar String where
+  readEnvVar = Right
+
+toEnvName :: String -> String
+toEnvName "" = ""
+toEnvName (c0 : c1 : cs)
+  | isUpper c0 && isLower c1 = '_' : c0 : toEnvName (c1 : cs)
+toEnvName (c0 : cs) = toUpper c0 : toEnvName cs

yore.cabal

@@ -33,7 +33,8 @@ common shared-options
 library
   import: shared-options
   exposed-modules:
-      Yore.DB
+      Yore.Config
+    , Yore.DB
     , Yore.Download
     , Yore.Error
     , Yore.Index
@@ -57,6 +58,7 @@ library
     , resource-pool
     , text
     , time
+    , transformers
     , uuid
 
 executable yore