diff options
author | defanor <defanor@uberspace.net> | 2019-02-16 10:41:13 +0300 |
---|---|---|
committer | defanor <defanor@uberspace.net> | 2019-02-16 10:41:13 +0300 |
commit | 3c00d9f42a26808c6c1763f93f78371b318c5b06 (patch) | |
tree | c78bf463b0bbc58ce1514f7ee598fbf6b52c1276 /Main.hsc | |
parent | d13259f1d4d78a4fd5c5873275416516d6e7d65b (diff) |
Request credentials on password-related failures
Diffstat (limited to 'Main.hsc')
-rw-r--r-- | Main.hsc | 16 |
1 files changed, 11 insertions, 5 deletions
@@ -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) |