diff --git a/app/Main.hs b/app/Main.hs index 9dce148..e7f8f35 100644 --- a/app/Main.hs +++ b/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 diff --git a/src/Yore/Config.hs b/src/Yore/Config.hs new file mode 100644 index 0000000..cde2a3c --- /dev/null +++ b/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 diff --git a/yore.cabal b/yore.cabal index f26cb0c..790c949 100644 --- a/yore.cabal +++ b/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