diff options
| -rw-r--r-- | src/Auth.hs | 11 | ||||
| -rw-r--r-- | src/Config.hs | 22 | ||||
| -rw-r--r-- | src/Main.hs | 4 |
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]) |