app/Main.hs

@@ -1,19 +1,14 @@
 {-# 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 ((//), (/:))
@@ -37,7 +32,6 @@ import Servant
   , (:>)
   , pattern MkHandler
   )
-import System.Exit (exitFailure)
 import System.FilePath ((</>))
 import Text.Blaze.Html.Renderer.Utf8 (renderHtml)
 import Text.Blaze.Html5 ((!))
@@ -53,7 +47,6 @@ 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)
@@ -62,46 +55,27 @@ import qualified Envy
 import qualified Yore.DB as DB
 import qualified Yore.Log as Log
 
-newtype ConnectionString = ConnectionString String
+data Config f = Config
-  deriving (Show)
+  { port :: Envy.Env f (Envy.Optional Integer 3000)
-
+  , downloadDir :: Envy.Env f (Envy.Optional String "download")
-instance Envy.ReadEnvVar ConnectionString where
+  , factor :: Envy.Env f (Envy.Required Rational)
-  readEnvVar = fmap ConnectionString . Envy.readEnvVar
+  , factorFallback :: Envy.Env f (Envy.Optional Rational '(1, 1))
-
-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
-  cfg <-
+  print . port =<< Envy.load @Config
-    Envy.load @ConfigT >>= \case
+  print . downloadDir =<< Envy.load @Config
-      Left err -> do
+  print . factor =<< Envy.load @Config
-        Log.error $ printf "failed to read config: %s" err
-        exitFailure
-      Right c ->
-        pure c
-
   let
     settings =
-      foldr
+      Warp.setLogger logger $
-        ($)
+        Warp.setPort 3000 $
-        Warp.defaultSettings
+          Warp.setOnException onException 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 cfg.yoreDb
+  db <- DB.initDB "host=localhost user=yore-test port=5433 dbname=yore-test"
-  Warp.runSettings settings $ serve (Proxy @API) $ hoistServer (Proxy @API) nt $ server cfg db
+  Warp.runSettings settings $ serve (Proxy :: Proxy API) $ hoistServer (Proxy :: Proxy API) nt $ server db
   where
     logger req status _ = do
       Log.info $
@@ -158,8 +132,8 @@ handlerToRaw handler = Tagged $ \_ respond -> do
     Right response ->
       respond response
 
-server :: Config -> DB.DB -> ServerT API (ExceptT Error IO)
+server :: DB.DB -> ServerT API (ExceptT Error IO)
-server cfg db = rootR :<|> todayR :<|> apiTodayR
+server db = rootR :<|> todayR :<|> apiTodayR
   where
     rootR = todayR 0
 
@@ -172,7 +146,7 @@ server cfg db = rootR :<|> todayR :<|> apiTodayR
     apiTodayR issue = handlerToRaw $ do
       dateThen <- ExceptT get100YearsAgo
       dayFile <- ExceptT $ DB.withConn db $ DB.getDayFileByIssue dateThen issue
-      let fullPath = cfg.yoreDownloadDir </> dayFile.relative_path
+      let fullPath = "download" </> dayFile.relative_path
       secondsUntilMidnight <- liftIO getSecondsUntilMidnight
       pure $
         responseFile

src/Envy.hs

@@ -1,83 +1,53 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE UndecidableInstances #-}
 
-module Envy
+module Envy (Env, Required, Optional, load) where
-  ( 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, type (<=))
+import GHC.TypeLits (KnownNat, KnownSymbol, natVal, symbolVal)
 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 v =@@ t :: Type where
+type family Env v t :: Type where
-  Spec =@@ t = t
+  Env Spec t = t
-  Value =@@ (Required t) = t
+  Env Value (Required t) = t
-  Value =@@ (Optional t d) = t
+  Env 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)
+  :: forall (m :: ConfigVariant -> Type). (Generic (m Value), GFromEnv (Rep (m Spec)) (Rep (m Value))) => IO (m Value)
-   . (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)] -> Either String (value c)
+  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
+  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)
@@ -85,17 +55,18 @@ instance
       (M1 S (MetaSel (Just sym) su ss lz) (Rec0 s))
       (M1 S meta2 (Rec0 t))
   where
-  gFromEnv Proxy env =
+  gFromEnv Proxy env = case decodeEnvVar @s @t Proxy varName $ lookup varName env of
-    M1 . K1 <$> decodeEnvVar @s @t Proxy varName (lookup varName env)
+    Left err -> error err
+    Right value -> M1 $ K1 value
     where
-      varName = selectorNameToEnvVarName $ symbolVal $ Proxy @sym
+      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 "env var %s is missing" varName
+    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
@@ -110,7 +81,7 @@ readEnvVarWithContext :: forall t. (Typeable t, ReadEnvVar t) => String -> Strin
 readEnvVarWithContext varName str =
   first (context ++) $ readEnvVar str
   where
-    context = printf "env var %s='%s' is not a valid %s: " varName str (show $ typeRep $ Proxy @t)
+    context = printf "%s='%s' is not a valid %s: " varName str (show $ typeRep $ Proxy @t)
 
 class ProvidesDefault t d where
   getDefault :: Proxy d -> t
@@ -118,60 +89,17 @@ 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) level location msg
+  printf "(%s) (%s) (%s) %s\n" (iso8601Show now) location level msg
   where
     getLocation :: [(String, SrcLoc)] -> String
     -- First entry is always a function from this module, skip it