Implement envy

app/Main.hs

@@ -10,6 +10,7 @@ import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Trans.Except (ExceptT (..), runExceptT)
 import Data.Proxy (Proxy (..))
 import Data.Time (Day, toGregorian)
+import GHC.Generics (Generic)
 import Network.HTTP.Media ((//), (/:))
 import Network.HTTP.Types (Status (..), mkStatus, status200)
 import Servant
@@ -31,7 +32,6 @@ import Servant
   , (:>)
   , pattern MkHandler
   )
-import System.Exit (exitWith, ExitCode (..))
 import System.FilePath ((</>))
 import Text.Blaze.Html.Renderer.Utf8 (renderHtml)
 import Text.Blaze.Html5 ((!))
@@ -51,25 +51,32 @@ import Yore.DB (DayFile (..))
 import Yore.Error (Error (..))
 import Yore.Time (addYears, getCurrentDay, getSecondsUntilMidnight)
 
-import qualified Yore.Config as Config
+import qualified Envy
 import qualified Yore.DB as DB
 import qualified Yore.Log as Log
 
+data Config f = Config
+  { port :: Envy.Env f (Envy.Optional Integer 3000)
+  , downloadDir :: Envy.Env f (Envy.Optional String "download")
+  , factor :: Envy.Env f (Envy.Required Rational)
+  , factorFallback :: Envy.Env f (Envy.Optional Rational '(1, 1))
+  }
+  deriving (Generic)
+
 main :: IO ()
 main = do
-  cfg <- Config.load @Config.Config >>= \case
+  print . port =<< Envy.load @Config
-    Left err -> do
+  print . downloadDir =<< Envy.load @Config
-      Log.error err
+  print . factor =<< Envy.load @Config
-      exitWith $ ExitFailure 1
+  let
-    Right cfg ->
+    settings =
-      pure cfg
+      Warp.setLogger logger $
+        Warp.setPort 3000 $
+          Warp.setOnException onException Warp.defaultSettings
+
   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
-    settings =
-      Warp.setLogger logger $
-        Warp.setOnException onException Warp.defaultSettings
-
     logger req status _ = do
       Log.info $
         printf

src/Envy.hs

@@ -0,0 +1,105 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Envy (Env, Required, Optional, load) where
+
+import Data.Bifunctor (first)
+import Data.Kind (Type)
+import Data.Proxy (Proxy (..))
+import Data.Ratio ((%))
+import Data.Typeable (Typeable, typeRep)
+import GHC.Generics (C, D, Generic, K1 (..), M1 (..), Meta (..), Rec0, Rep, S, to, (:*:) (..))
+import GHC.TypeLits (KnownNat, KnownSymbol, natVal, symbolVal)
+import System.Environment (getEnvironment)
+import Text.Printf (printf)
+import Text.Read (readEither)
+
+data ConfigVariant = Spec | Value
+
+data Required t
+data Optional t d
+
+type family Env v t :: Type where
+  Env Spec t = t
+  Env Value (Required t) = t
+  Env Value (Optional t d) = t
+
+load
+  :: forall (m :: ConfigVariant -> Type). (Generic (m Value), GFromEnv (Rep (m Spec)) (Rep (m Value))) => IO (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)] -> value c
+
+instance
+  (GFromEnv i o)
+  => GFromEnv (M1 D b i) (M1 D d o)
+  where
+  gFromEnv Proxy env = M1 $ gFromEnv @i @o Proxy env
+
+instance
+  (GFromEnv i o)
+  => GFromEnv (M1 C b i) (M1 C d o)
+  where
+  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
+
+instance
+  (KnownSymbol sym, EnvVarSpec s t)
+  => GFromEnv
+      (M1 S (MetaSel (Just sym) su ss lz) (Rec0 s))
+      (M1 S meta2 (Rec0 t))
+  where
+  gFromEnv Proxy env = case decodeEnvVar @s @t Proxy varName $ lookup varName env of
+    Left err -> error err
+    Right value -> M1 $ K1 value
+    where
+      varName = symbolVal $ Proxy @sym
+
+class EnvVarSpec specTy valueTy where
+  decodeEnvVar :: Proxy specTy -> String -> Maybe String -> Either String valueTy
+
+instance (Typeable t, ReadEnvVar t) => EnvVarSpec (Required t) t where
+  decodeEnvVar Proxy varName = \case
+    Nothing -> Left $ printf "%s is missing" varName
+    Just str -> readEnvVarWithContext varName str
+
+instance (Typeable t, ReadEnvVar t, ProvidesDefault t d) => EnvVarSpec (Optional t d) t where
+  decodeEnvVar Proxy varName = \case
+    Nothing -> Right $ getDefault (Proxy @d)
+    Just str -> readEnvVarWithContext varName str
+
+class ReadEnvVar t where
+  readEnvVar :: String -> Either String t
+
+readEnvVarWithContext :: forall t. (Typeable t, ReadEnvVar t) => String -> String -> Either String t
+readEnvVarWithContext varName str =
+  first (context ++) $ readEnvVar str
+  where
+    context = printf "%s='%s' is not a valid %s: " varName str (show $ typeRep $ Proxy @t)
+
+class ProvidesDefault t d where
+  getDefault :: Proxy d -> t
+
+instance ReadEnvVar Integer where
+  readEnvVar = readEither
+
+instance (KnownNat n) => ProvidesDefault Integer n where
+  getDefault Proxy = natVal (Proxy @n)
+
+instance ReadEnvVar String where
+  readEnvVar = Right
+
+instance (KnownSymbol s) => ProvidesDefault String s where
+  getDefault Proxy = symbolVal (Proxy @s)
+
+instance ReadEnvVar Rational where
+  readEnvVar = readEither
+
+instance (KnownNat num, KnownNat denom) => ProvidesDefault Rational '(num, denom) where
+  getDefault Proxy = natVal (Proxy @num) % natVal (Proxy @denom)

src/Yore/Config.hs

@@ -1,92 +0,0 @@
-{-# 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,7 @@ common shared-options
 library
   import: shared-options
   exposed-modules:
-      Yore.Config
+      Envy
     , Yore.DB
     , Yore.Download
     , Yore.Error