Make gFromEnv return Either String (...)

app/Main.hs

@@ -1,14 +1,19 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ExplicitNamespaces #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeSynonymInstances #-}
 
 module Main (main) where
 
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Trans.Except (ExceptT (..), runExceptT)
 import Data.Proxy (Proxy (..))
+import Data.Text (Text)
 import Data.Time (Day, toGregorian)
 import GHC.Generics (Generic)
 import Network.HTTP.Media ((//), (/:))
@@ -32,6 +37,7 @@ import Servant
   , (:>)
   , pattern MkHandler
   )
+import System.Exit (exitFailure)
 import System.FilePath ((</>))
 import Text.Blaze.Html.Renderer.Utf8 (renderHtml)
 import Text.Blaze.Html5 ((!))
@@ -47,6 +53,7 @@ import qualified Network.Wai.Handler.Warp as Warp
 import qualified Text.Blaze.Html5 as H
 import qualified Text.Blaze.Html5.Attributes as A
 
+import Envy (type (=@!), type (=@@), type (?))
 import Yore.DB (DayFile (..))
 import Yore.Error (Error (..))
 import Yore.Time (addYears, getCurrentDay, getSecondsUntilMidnight)
@@ -55,27 +62,46 @@ import qualified Envy
 import qualified Yore.DB as DB
 import qualified Yore.Log as Log
 
-data Config f = Config
+newtype ConnectionString = ConnectionString String
-  { port :: Envy.Env f (Envy.Optional Integer 3000)
+  deriving (Show)
-  , downloadDir :: Envy.Env f (Envy.Optional String "download")
+
-  , factor :: Envy.Env f (Envy.Required Rational)
+instance Envy.ReadEnvVar ConnectionString where
-  , factorFallback :: Envy.Env f (Envy.Optional Rational '(1, 1))
+  readEnvVar = fmap ConnectionString . Envy.readEnvVar
+
+data ConfigT f = Config
+  { yorePort :: f =@@ Int ? 3000
+  , yoreDownloadDir :: f =@@ FilePath ? "./download"
+  , yoreDb :: f =@! Text
   }
   deriving (Generic)
 
+type Config = ConfigT Envy.Value
+
+deriving instance Show Config
+
 main :: IO ()
 main = do
-  print . port =<< Envy.load @Config
+  cfg <-
-  print . downloadDir =<< Envy.load @Config
+    Envy.load @ConfigT >>= \case
-  print . factor =<< Envy.load @Config
+      Left err -> do
+        Log.error $ printf "failed to read config: %s" err
+        exitFailure
+      Right c ->
+        pure c
+
   let
     settings =
-      Warp.setLogger logger $
+      foldr
-        Warp.setPort 3000 $
+        ($)
-          Warp.setOnException onException Warp.defaultSettings
+        Warp.defaultSettings
+        [ Warp.setLogger logger
+        , Warp.setPort cfg.yorePort
+        , Warp.setBeforeMainLoop $ Log.info $ printf "listening on port %d" cfg.yorePort
+        , Warp.setOnException onException
+        ]
 
-  db <- DB.initDB "host=localhost user=yore-test port=5433 dbname=yore-test"
+  db <- DB.initDB cfg.yoreDb
-  Warp.runSettings settings $ serve (Proxy :: Proxy API) $ hoistServer (Proxy :: Proxy API) nt $ server db
+  Warp.runSettings settings $ serve (Proxy @API) $ hoistServer (Proxy @API) nt $ server cfg db
   where
     logger req status _ = do
       Log.info $
@@ -132,8 +158,8 @@ handlerToRaw handler = Tagged $ \_ respond -> do
     Right response ->
       respond response
 
-server :: DB.DB -> ServerT API (ExceptT Error IO)
+server :: Config -> DB.DB -> ServerT API (ExceptT Error IO)
-server db = rootR :<|> todayR :<|> apiTodayR
+server cfg db = rootR :<|> todayR :<|> apiTodayR
   where
     rootR = todayR 0
 
@@ -146,7 +172,7 @@ server db = rootR :<|> todayR :<|> apiTodayR
     apiTodayR issue = handlerToRaw $ do
       dateThen <- ExceptT get100YearsAgo
       dayFile <- ExceptT $ DB.withConn db $ DB.getDayFileByIssue dateThen issue
-      let fullPath = "download" </> dayFile.relative_path
+      let fullPath = cfg.yoreDownloadDir </> dayFile.relative_path
       secondsUntilMidnight <- liftIO getSecondsUntilMidnight
       pure $
         responseFile

src/Envy.hs

@@ -1,53 +1,83 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
 
-module Envy (Env, Required, Optional, load) where
+module Envy
+  ( type (=@@)
+  , type (=@!)
+  , type (?)
+  , type (=@?)
+  , ReadEnvVar (..)
+  , Required
+  , Optional
+  , load
+  , ConfigVariant (..)
+  , MyNothing
+  , OptionalMaybe
+  ) where
 
 import Data.Bifunctor (first)
+import Data.Char (isLower, isUpper, toUpper)
 import Data.Kind (Type)
 import Data.Proxy (Proxy (..))
 import Data.Ratio ((%))
+import Data.Text (Text)
 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 GHC.TypeLits (KnownNat, KnownSymbol, natVal, symbolVal, type (<=))
 import System.Environment (getEnvironment)
 import Text.Printf (printf)
 import Text.Read (readEither)
 
+import qualified Data.Text as Text
+
 data ConfigVariant = Spec | Value
 
 data Required t
 data Optional t d
 
-type family Env v t :: Type where
+type family v =@@ t :: Type where
-  Env Spec t = t
+  Spec =@@ t = t
-  Env Value (Required t) = t
+  Value =@@ (Required t) = t
-  Env Value (Optional t d) = t
+  Value =@@ (Optional t d) = t
+
+type OptionalMaybe t = Optional (Maybe t) MyNothing
+
+-- No associativity - these are not supposed to be chained
+infix 6 =@@
+infix 7 ?
+
+type v =@! t = v =@@ Required t
+type v =@? t = v =@@ OptionalMaybe t
+type t ? d = Optional t d
 
 load
-  :: forall (m :: ConfigVariant -> Type). (Generic (m Value), GFromEnv (Rep (m Spec)) (Rep (m Value))) => IO (m Value)
+  :: forall (m :: ConfigVariant -> Type)
+   . (Generic (m Value), GFromEnv (Rep (m Spec)) (Rep (m Value)))
+  => IO (Either String (m Value))
 load = do
   env <- getEnvironment
-  pure $ to $ gFromEnv @(Rep (m Spec)) @(Rep (m Value)) Proxy env
+  pure $ to <$> gFromEnv @(Rep (m Spec)) @(Rep (m Value)) Proxy env
 
 class GFromEnv spec value where
-  gFromEnv :: Proxy (spec c) -> [(String, String)] -> value c
+  gFromEnv :: Proxy (spec c) -> [(String, String)] -> Either 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
+  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
+  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
+  gFromEnv Proxy env = (:*:) <$> gFromEnv @i1 @o1 Proxy env <*> gFromEnv @i2 @o2 Proxy env
 
 instance
   (KnownSymbol sym, EnvVarSpec s t)
@@ -55,18 +85,17 @@ instance
       (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
+  gFromEnv Proxy env =
-    Left err -> error err
+    M1 . K1 <$> decodeEnvVar @s @t Proxy varName (lookup varName env)
-    Right value -> M1 $ K1 value
     where
-      varName = symbolVal $ Proxy @sym
+      varName = selectorNameToEnvVarName $ 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
+    Nothing -> Left $ printf "env var %s is missing" varName
     Just str -> readEnvVarWithContext varName str
 
 instance (Typeable t, ReadEnvVar t, ProvidesDefault t d) => EnvVarSpec (Optional t d) t where
@@ -81,7 +110,7 @@ readEnvVarWithContext :: forall t. (Typeable t, ReadEnvVar t) => String -> Strin
 readEnvVarWithContext varName str =
   first (context ++) $ readEnvVar str
   where
-    context = printf "%s='%s' is not a valid %s: " varName str (show $ typeRep $ Proxy @t)
+    context = printf "env var %s='%s' is not a valid %s: " varName str (show $ typeRep $ Proxy @t)
 
 class ProvidesDefault t d where
   getDefault :: Proxy d -> t
@@ -89,17 +118,60 @@ class ProvidesDefault t d where
 instance ReadEnvVar Integer where
   readEnvVar = readEither
 
+-- TODO: Support negative integers (e.g. (Negate n))
 instance (KnownNat n) => ProvidesDefault Integer n where
   getDefault Proxy = natVal (Proxy @n)
 
+instance ReadEnvVar Int where
+  readEnvVar = readEither
+
+-- TODO: Support negative integers (e.g. (Negate n))
+-- This instance assumes that @Int@ is a 64-bit integer and enforces its range on the type level.
+instance (KnownNat n, n <= 9223372036854775807) => ProvidesDefault Int n where
+  getDefault Proxy = fromInteger $ natVal (Proxy @n)
+
 instance ReadEnvVar String where
   readEnvVar = Right
 
 instance (KnownSymbol s) => ProvidesDefault String s where
   getDefault Proxy = symbolVal (Proxy @s)
 
+instance ReadEnvVar Text where
+  readEnvVar = fmap Text.pack . readEnvVar
+
+instance (KnownSymbol s) => ProvidesDefault Text s where
+  getDefault Proxy = Text.pack $ getDefault (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)
+
+instance ReadEnvVar Double where
+  readEnvVar = readEither
+
+instance (KnownNat num, KnownNat denom) => ProvidesDefault Double '(num, denom) where
+  getDefault Proxy = fromRational $ getDefault @Rational @'(num, denom) Proxy
+
+instance (ReadEnvVar t) => ReadEnvVar (Maybe t) where
+  readEnvVar = fmap Just . readEnvVar
+
+instance (ProvidesDefault t d) => ProvidesDefault (Maybe t) (Just d) where
+  getDefault Proxy = Just $ getDefault @t @d Proxy
+
+data MyNothing
+
+instance ProvidesDefault (Maybe t) MyNothing where
+  getDefault Proxy = Nothing
+
+-- Converts camelCase names to UPPER_SNAKE_CASE.
+selectorNameToEnvVarName :: String -> String
+selectorNameToEnvVarName = go
+  where
+    go [] =
+      []
+    go (c0 : c1 : rest)
+      | isUpper c0 && isLower c1 = '_' : c0 : toUpper c1 : go rest
+    go (c0 : rest) =
+      toUpper c0 : go rest

src/Yore/Log.hs

@@ -15,7 +15,7 @@ doLog :: (HasCallStack) => String -> String -> IO ()
 doLog level msg = do
   now <- getZonedTime
   let location = getLocation $ getCallStack callStack
-  printf "(%s) (%s) (%s) %s\n" (iso8601Show now) location level msg
+  printf "(%s) (%s) (%s) %s\n" (iso8601Show now) level location msg
   where
     getLocation :: [(String, SrcLoc)] -> String
     -- First entry is always a function from this module, skip it