From d19ac5b4d7629fba6184f4bc00843979b083465b Mon Sep 17 00:00:00 2001 From: Paul Brinkmeier Date: Sun, 14 Sep 2025 11:07:05 +0200 Subject: [PATCH] Implement envy --- app/Main.hs | 31 +++++++------ src/Envy.hs | 105 +++++++++++++++++++++++++++++++++++++++++++++ src/Yore/Config.hs | 92 --------------------------------------- yore.cabal | 2 +- 4 files changed, 125 insertions(+), 105 deletions(-) create mode 100644 src/Envy.hs delete mode 100644 src/Yore/Config.hs diff --git a/app/Main.hs b/app/Main.hs index e7f8f35..d990862 100644 --- a/app/Main.hs +++ b/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 - Left err -> do - Log.error err - exitWith $ ExitFailure 1 - Right cfg -> - pure cfg + print . port =<< Envy.load @Config + print . downloadDir =<< Envy.load @Config + print . factor =<< Envy.load @Config + let + settings = + 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 diff --git a/src/Envy.hs b/src/Envy.hs new file mode 100644 index 0000000..103d9b2 --- /dev/null +++ b/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) diff --git a/src/Yore/Config.hs b/src/Yore/Config.hs deleted file mode 100644 index cde2a3c..0000000 --- a/src/Yore/Config.hs +++ /dev/null @@ -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 diff --git a/yore.cabal b/yore.cabal index 790c949..f8dcbbb 100644 --- a/yore.cabal +++ b/yore.cabal @@ -33,7 +33,7 @@ common shared-options library import: shared-options exposed-modules: - Yore.Config + Envy , Yore.DB , Yore.Download , Yore.Error