make admin user/password configurable with env vars instead of recompilation

3 files changed, 20 insertions, 17 deletions

diff --git a/src/Auth.hs b/src/Auth.hs
index df97e8b..98b4932 100644
--- a/src/Auth.hs
+++ b/src/Auth.hs
@@ -7,14 +7,13 @@ module Auth (
 import Control.Monad (unless)
 import Crypto.Hash (hash, Digest, SHA512)
 import Data.ByteArray.Encoding (convertToBase, Base(Base64))
-import Data.ByteString (ByteString)
 import Data.Text.Encoding (encodeUtf8)
 import Yesod
 
-ensureAuth :: MonadHandler m => m ()
-ensureAuth = lookupBasicAuth >>= \case
+import Config
+
+ensureAuth :: MonadHandler m => Config -> m ()
+ensureAuth cfg = lookupBasicAuth >>= \case
     Nothing -> notAuthenticated
-    Just (user, pw) -> unless (hashSha512 pw == hardcodedPw && user == "bleb") $ permissionDenied "Wrong username/password"
+    Just (user, pw) -> unless (hashSha512 pw == encodeUtf8 (confPwHash cfg) && user == confUser cfg) $ permissionDenied "Wrong username/password"
   where hashSha512 pw = convertToBase Base64 $ (hash $ encodeUtf8 pw :: Digest SHA512)
-        hardcodedPw :: ByteString
-        hardcodedPw = "l2gTDo5UCimSIQcdK4IrAvJtCIE7KPB7IyS5N7EN4ic78/1mI+8pikPTQTn06+W1XTOk39TgqGEX5KfpAQVm4w=="
diff --git a/src/Config.hs b/src/Config.hs
index b0c7670..d494477 100644
--- a/src/Config.hs
+++ b/src/Config.hs
@@ -7,7 +7,7 @@ module Config (
 ) where
 
 import Data.Maybe (fromMaybe)
-import Data.String (fromString)
+import Data.String (fromString, IsString)
 import Data.Text (Text)
 import Network.Wai.Handler.Warp (HostPreference)
 import System.Environment (lookupEnv)
@@ -16,17 +16,21 @@ data Config = Config {
     confPort :: Int,
     confHost :: HostPreference,
     confBaseUrl :: Text,
-    confFavicon :: Text
+    confFavicon :: Text,
+    confUser :: Text,
+    confPwHash :: Text
 } deriving (Show, Eq)
 
 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"
-
-    return $ Config port host baseUrl favicon
+getConfig = Config
+    <$> (read <$> getEnvOr "PORT" "20546")
+    <*> getEnvOr "BIND_ADDR" "*6"
+    <*> getEnvOr "BASE_URL" "http://localhost:20546"
+    <*> getEnvOr "FAVICON_URL" "https://69owo.de/favicon.ico"
+    <*> getEnvOr "ADMIN_USER" "bleb"
+    <*> getEnvOr "ADMIN_PW_HASH" "" -- prevent login without manual pw
+  where getEnvOr :: IsString s => String -> s -> IO s
+        getEnvOr q def = fromMaybe def . fmap fromString <$> lookupEnv q
 
 makeOpenSearch :: Config -> Maybe Text -> Text
 makeOpenSearch cfg defBang =
diff --git a/src/Main.hs b/src/Main.hs
index 3474040..540db63 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -130,7 +130,7 @@ getOpenSearchR = do
 
 postVerdictR :: Bool -> Handler ()
 postVerdictR b = do
-    ensureAuth
+    ensureAuth . config =<< getYesod
 
     (PendingBang n u dp mayEm) <- requireCheckJsonBody
     -- NOTE: known race condition: the bang bang may be deleted from the database
@@ -148,7 +148,7 @@ postRejectR = postVerdictR False
 
 getPendingR :: Handler Value
 getPendingR = do
-    ensureAuth
+    ensureAuth . config =<< getYesod
 
     pendingBangs <- runDB $ selectList [] []
     return $ toJSON $ map entityVal (pendingBangs :: [Entity PendingBang])