diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Config.hs | 60 | ||||
| -rw-r--r-- | src/Main.hs | 20 |
2 files changed, 40 insertions, 40 deletions
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 |