Implement envy
This commit is contained in:
Paul Brinkmeier
parent
c65d366611
commit
d19ac5b4d7
31
app/Main.hs
31
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
|
||||
|
||||
105
src/Envy.hs
Normal file
105
src/Envy.hs
Normal file
@ -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)
|
||||
@ -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
|
||||
@ -33,7 +33,7 @@ common shared-options
|
||||
library
|
||||
import: shared-options
|
||||
exposed-modules:
|
||||
Yore.Config
|
||||
Envy
|
||||
, Yore.DB
|
||||
, Yore.Download
|
||||
, Yore.Error
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user