From 3c00d9f42a26808c6c1763f93f78371b318c5b06 Mon Sep 17 00:00:00 2001 From: defanor Date: Sat, 16 Feb 2019 10:41:13 +0300 Subject: Request credentials on password-related failures --- Main.hsc | 16 +++++++++++----- README.md | 3 ++- 2 files changed, 13 insertions(+), 6 deletions(-) diff --git a/Main.hsc b/Main.hsc index 092fbf7..ea3d50c 100644 --- a/Main.hsc +++ b/Main.hsc @@ -253,6 +253,10 @@ respond' code headers content = do respond :: Int -> BS.ByteString -> IO () respond c = respond' c [] +requireAuth :: IO () +requireAuth = respond' 401 + ["WWW-Authenticate:Basic realm=\"Protected area\", charset=\"UTF-8\""] + "" -- * Main routines @@ -291,7 +295,12 @@ serve xsltDirectory ioc ps = case lookup "q" ps of errMsg <- maybe [] (\m -> [("message", m)]) <$> errorMessage c redb 500 $ ("exec_status", BS.pack (show rs)) : errMsg Nothing -> redb 500 [("message", "Failed to execute the query")] - _ -> redb 500 [("message", "Database connection failed")] + _ -> do + pNeeded <- connectionNeedsPassword c + pUsed <- connectionUsedPassword c + if pNeeded || pUsed + then requireAuth + else redb 500 [("message", "Database connection failed")] _ -> respError 418 [("message", "No query is provided")] where xsltPath = xsltDirectory @@ -317,8 +326,5 @@ main = do (Just "on", Just (l, p)) -> serve xsltDir (connectdb (connString [("user", l), ("password", p)])) ps - (Just "on", Nothing) -> - respond' 401 - ["WWW-Authenticate:Basic realm=\"Protected area\", charset=\"UTF-8\""] - "" + (Just "on", Nothing) -> requireAuth _ -> serve xsltDir (connectdb "") ps) diff --git a/README.md b/README.md index d0ee97e..8be957f 100644 --- a/README.md +++ b/README.md @@ -69,7 +69,8 @@ since they are of little use with HTML 5 forms. Presence of `auth=on` in the URL query requires HTTP basic authentication, and the provided credentials are used directly for -PostgreSQL authentication. +PostgreSQL authentication. HTTP authentication also gets requested if +a database failure was password-related. ### Web server -- cgit v1.2.3