Fix internal server error on invalid credentials

backend/src/Datarekisteri/Backend.hs

@@ -150,12 +150,16 @@ authBasic (Just basic) m = do
 
 verifyBasic :: BasicAuth -> ActionT LText APIM (DBUser APIM)
 verifyBasic BasicAuth {..} = do
-    Right user@DBUser {..} <- lift $ dbGetUserByEmail emailAddress
-    correctPassword <- checkPassword password <$> lift dbUserPasswordHash
-    if correctPassword
-       then pure user
-       else do setHeader "WWW-Authenticate" "Basic realm=\"GraphQL API\", Bearer realm=\"GraphQL API\""
+    maybeUser <- lift $ dbGetUserByEmail emailAddress
+    let unauthorized = do
+            setHeader "WWW-Authenticate" "Basic realm=\"GraphQL API\", Bearer realm=\"GraphQL API\""
             raiseStatus status401 "Wrong password or email"
+    case maybeUser of
+      Left _ -> unauthorized
+      Right user@DBUser {..} -> do
+          correctPassword <- checkPassword password <$> lift dbUserPasswordHash
+          unless correctPassword unauthorized
+          pure user
 
 newtype APIM a = APIM (ReaderT RequestState IO a)
     deriving (Functor, Applicative, Monad, MonadIO, MonadReader RequestState)

frontend/datarekisteri-frontend.cabal

@@ -14,6 +14,8 @@ executable datarekisteri-frontend
     base64,
     datarekisteri-core,
     email-validate,
+    http-client,
+    http-types,
     memory,
     monad-logger,
     morpheus-graphql,
@@ -24,6 +26,7 @@ executable datarekisteri-frontend
     optparse-applicative,
     process,
     relude,
+    req,
     text,
     time,
     yesod,

frontend/src/Datarekisteri/Frontend/ApiRequests.hs

@@ -13,8 +13,12 @@ module Datarekisteri.Frontend.ApiRequests where
 
 import Relude
 
+import Control.Exception (handle, throwIO)
 import Data.Aeson (ToJSON, FromJSON)
 import Data.Morpheus.Client (RequestType, RequestArgs, Args, GQLClientResult, FetchError(..), single, request, withHeaders)
+import Network.HTTP.Client (HttpException(..), HttpExceptionContent(..), responseStatus)
+import Network.HTTP.Types.Status (status401)
+import Network.HTTP.Req (HttpException(..))
 import Yesod (HandlerFor, getYesod, liftHandler)
 import Yesod.Auth (YesodAuth, AuthId, requireAuthId, maybeAuthId)
 
@@ -36,15 +40,22 @@ apiRequest' :: RequestConstraint a site => [Header] -> Bool -> Args a -> Handler
 apiRequest' extraHeaders authRequired args = do
     yesod <- liftHandler getYesod
     auth <- fmap (authIdToAuthorization yesod) <$> if authRequired then Just <$> requireAuthId else maybeAuthId
-    apiRequestAuth extraHeaders (("Bearer " <>) <$> auth) args >>= handleErrors
+    maybeResult <- apiRequestAuth extraHeaders (("Bearer " <>) <$> auth) args
+    case maybeResult of
+      Just result -> handleErrors result
+      Nothing ->  error "Unauthorized"
 
 apiRequestAuth :: RequestConstraint a site =>
-    [Header] -> Maybe Authorization -> Args a -> HandlerFor site (GQLClientResult a)
+    [Header] -> Maybe Authorization -> Args a -> HandlerFor site (Maybe (GQLClientResult a))
 apiRequestAuth extraHeaders auth args = do
     apiUrl <- getApiUrl
-    stream <- liftIO $ request (fromString (toString apiUrl) `withHeaders` headers) args
-    single stream
-        where headers = maybe [] (\x -> [("Authorization", x)]) auth <> extraHeaders
+    let headers = maybe [] (\x -> [("Authorization", x)]) auth <> extraHeaders
+        handleUnauthorized e@(VanillaHttpException (HttpExceptionRequest _ (StatusCodeException response _)))
+              | responseStatus response == status401 = pure Nothing
+              | otherwise = throwIO e
+        handleUnauthorized e = throwIO e
+    liftIO $ handle handleUnauthorized $
+        request (fromString (toString apiUrl) `withHeaders` headers) args >>= fmap Just . single
 
 apiRequest :: RequestConstraint a site => Bool -> Args a -> HandlerFor site a
 apiRequest authRequired = apiRequest' [] authRequired

frontend/src/Datarekisteri/Frontend/Types.hs

@@ -90,11 +90,9 @@ instance YesodAuth DataIdClient where
     maybeAuthId = lookupSession credsKey
     loginDest = const HomeR
     logoutDest = const HomeR
-    authPlugins = const $
-        [ authExternalBasic $
-            fmap (fmap (tokenData . newToken) . rightToMaybe) .
-                flip (apiRequestAuth @GetWebUIToken []) () . Just
-        ]
+    authPlugins = const $ [authExternalBasic getToken]
+        where getToken auth = (>>= fmap (tokenData . newToken) . rightToMaybe) <$>
+                      apiRequestAuth @GetWebUIToken [] (Just auth) ()
     authenticate = pure . Authenticated . credsIdent
 
 withAuthenticated :: (AuthId DataIdClient -> Handler AuthResult) -> Handler AuthResult