diff --git a/app/Main.hs b/app/Main.hs index d990862..d373052 100644 --- a/app/Main.hs +++ b/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 ((//), (/:)) @@ -47,6 +52,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 +61,41 @@ 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)) +newtype ConnectionString = ConnectionString String + deriving (Show) + +instance Envy.ReadEnvVar ConnectionString where + 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 - print . downloadDir =<< Envy.load @Config - print . factor =<< Envy.load @Config + cfg <- Envy.load @ConfigT + -- _ <- exitSuccess + let settings = - Warp.setLogger logger $ - Warp.setPort 3000 $ - Warp.setOnException onException Warp.defaultSettings + foldr + ($) + 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" - Warp.runSettings settings $ serve (Proxy :: Proxy API) $ hoistServer (Proxy :: Proxy API) nt $ server db + db <- DB.initDB cfg.yoreDb + Warp.runSettings settings $ serve (Proxy :: Proxy API) $ hoistServer (Proxy :: Proxy API) nt $ server cfg db where logger req status _ = do Log.info $ @@ -132,8 +152,8 @@ handlerToRaw handler = Tagged $ \_ respond -> do Right response -> respond response -server :: DB.DB -> ServerT API (ExceptT Error IO) -server db = rootR :<|> todayR :<|> apiTodayR +server :: Config -> DB.DB -> ServerT API (ExceptT Error IO) +server cfg db = rootR :<|> todayR :<|> apiTodayR where rootR = todayR 0 @@ -146,7 +166,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 diff --git a/src/Yore/Log.hs b/src/Yore/Log.hs index 8b4705b..0cd7b57 100644 --- a/src/Yore/Log.hs +++ b/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