better config system

4 files changed, 40 insertions, 42 deletions

diff --git a/fastbangs.cabal b/fastbangs.cabal
index a5b8a22..e103e10 100644
--- a/fastbangs.cabal
+++ b/fastbangs.cabal
@@ -41,7 +41,6 @@ executable fastbangs
     , resourcet
     , stm
     , text
-    , time
     , warp
     , yesod
   default-language: Haskell2010
diff --git a/package.yaml b/package.yaml
index d9f955e..95a8de7 100644
--- a/package.yaml
+++ b/package.yaml
@@ -15,7 +15,6 @@ dependencies:
 - yesod
 - aeson
 - bytestring
-- time
 - http-conduit
 - containers
 - text
diff --git a/src/Config.hs b/src/Config.hs
index 45f9808..b0c7670 100644
--- a/src/Config.hs
+++ b/src/Config.hs
@@ -1,44 +1,44 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module Config (
-    getPort,
-    getHost,
-    getBaseUrl,
+    Config(..),
+    getConfig,
     makeOpenSearch
 ) where
 
 import Data.Maybe (fromMaybe)
-import Data.String (fromString, IsString)
+import Data.String (fromString)
+import Data.Text (Text)
 import Network.Wai.Handler.Warp (HostPreference)
 import System.Environment (lookupEnv)
 
-getPort :: IO Int
-getPort = (read . fromMaybe "20546") <$> lookupEnv "PORT"
+data Config = Config {
+    confPort :: Int,
+    confHost :: HostPreference,
+    confBaseUrl :: Text,
+    confFavicon :: Text
+} deriving (Show, Eq)
 
--- currently, "*" seems to bind only to ipv4 while "*6" binds to both
-getHost :: IO HostPreference
-getHost = (fromString . fromMaybe "*6") <$> lookupEnv "BIND_ADDR"
+getConfig :: IO Config
+getConfig = do
+    port <- (read . fromMaybe "20546") <$> lookupEnv "PORT"
+    host <- (fromString . fromMaybe "*6") <$> lookupEnv "BIND_ADDR"
+    baseUrl <- (fromString . fromMaybe "http://localhost:20546") <$> lookupEnv "BASE_URL"
+    favicon <- (fromString . fromMaybe "https://69owo.de/favicon.ico") <$> lookupEnv "FAVICON_URL"
 
-getBaseUrl :: IsString s => IO s
-getBaseUrl = (fromString . fromMaybe "http://localhost:20546") <$> lookupEnv "BASE_URL"
+    return $ Config port host baseUrl favicon
 
-faviconUrl :: IsString s => IO s
-faviconUrl = (fromString . fromMaybe "https://69owo.de/favicon.ico")
-    <$> lookupEnv "FAVICON_URL"
+makeOpenSearch :: Config -> Maybe Text -> Text
+makeOpenSearch cfg defBang =
+       "<OpenSearchDescription xmlns=\"http://a9.com/-/spec/opensearch/1.1/\"\n"
+    <> "                       xmlns:moz=\"http://www.mozilla.org/2006/browser/search/\">\n"
+    <> "    <ShortName>" <> name <> "</ShortName>\n"
+    <> "    <Description>Handles search bangs (mostly) locally.</Description>\n"
+    <> "    <InputEncoding>UTF-8</InputEncoding>\n"
+    <> "    <Image width=\"16\" height=\"16\" type=\"image/x-icon\">" <> confFavicon cfg <> "</Image>\n"
+    <> "    <Url type=\"text/html\" template=\"" <> searchUrl <> "\"/>\n"
+    <> "</OpenSearchDescription>\n"
 
-makeOpenSearch :: (IsString s, Semigroup s) => Maybe s -> IO s
-makeOpenSearch defBang = do
-    favicon <- faviconUrl
-    bp <- getBaseUrl
-    let (searchUrl, name) = case defBang of
-            Nothing -> (bp <> "/#{searchTerms}", "FastBangs")
-            Just b  -> (bp <> "/#" <> b <> "#{searchTerms}", "FastBangs (" <> b <> ")")
-
-    return $ "<OpenSearchDescription xmlns=\"http://a9.com/-/spec/opensearch/1.1/\"\n"
-          <> "                       xmlns:moz=\"http://www.mozilla.org/2006/browser/search/\">\n"
-          <> "    <ShortName>" <> name <> "</ShortName>\n"
-          <> "    <Description>Handles search bangs (mostly) locally.</Description>\n"
-          <> "    <InputEncoding>UTF-8</InputEncoding>\n"
-          <> "    <Image width=\"16\" height=\"16\" type=\"image/x-icon\">" <> favicon <> "</Image>\n"
-          <> "    <Url type=\"text/html\" template=\"" <> searchUrl <> "\"/>\n"
-          <> "</OpenSearchDescription>\n"
+  where (searchUrl, name) = case defBang of
+            Nothing -> (confBaseUrl cfg <> "/#{searchTerms}", "FastBangs")
+            Just b  -> (confBaseUrl cfg <> "/#" <> b <> "#{searchTerms}", "FastBangs (" <> b <> ")")
diff --git a/src/Main.hs b/src/Main.hs
index b5b35a1..3474040 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -54,7 +54,8 @@ instance FromJSON PendingBang where
 
 data Search = Search {
     bangState :: BangState,
-    sqlPool :: ConnectionPool
+    sqlPool :: ConnectionPool,
+    config :: Config
 }
 
 mkYesod "Search" [parseRoutes|
@@ -123,7 +124,8 @@ getOpenSearchR :: Handler TypedContent
 getOpenSearchR = do
     neverExpires
 
-    resXml <- liftIO . makeOpenSearch =<< lookupGetParam "default"
+    cfg <- config <$> getYesod
+    resXml <- makeOpenSearch cfg <$> lookupGetParam "default"
     return $ TypedContent "application/opensearchdescription+xml" $ toContent resXml
 
 postVerdictR :: Bool -> Handler ()
@@ -155,15 +157,13 @@ main :: IO ()
 main = runStdoutLoggingT $ withSqlitePool "banger.db" 2 $ \pool -> do
     runResourceT $ flip runSqlPool pool $ runMigration migrateAll
 
-    s <- Search
-        <$> liftIO initBangState
-        <*> pure pool
-    sApp <- liftIO $ toWaiApp s -- includes middlewares
+    bs <- liftIO initBangState
+    cfg <- liftIO getConfig
+
+    sApp <- liftIO $ toWaiApp $ Search bs pool cfg -- includes middlewares
 
-    host <- liftIO getHost
-    port <- liftIO getPort
     let settings = defaultSettings
-            & setHost host
-            & setPort port
+            & setHost (confHost cfg)
+            & setPort (confPort cfg)
 
     liftIO $ runSettings settings sApp