Request credentials on password-related failures

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