backend/src/Datarekisteri/Backend.hs

@@ -150,16 +150,12 @@ authBasic (Just basic) m = do
 
 verifyBasic :: BasicAuth -> ActionT LText APIM (DBUser APIM)
 verifyBasic BasicAuth {..} = do
-    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
+    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\""
+               raiseStatus status401 "Wrong password or email"
 
 newtype APIM a = APIM (ReaderT RequestState IO a)
     deriving (Functor, Applicative, Monad, MonadIO, MonadReader RequestState)

frontend/datarekisteri-frontend.cabal

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

frontend/src/Datarekisteri/Frontend/ApiRequests.hs

@@ -13,12 +13,8 @@ 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)
 
@@ -40,22 +36,15 @@ 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
-    maybeResult <- apiRequestAuth extraHeaders (("Bearer " <>) <$> auth) args
-    case maybeResult of
-      Just result -> handleErrors result
-      Nothing ->  error "Unauthorized"
+    apiRequestAuth extraHeaders (("Bearer " <>) <$> auth) args >>= handleErrors
 
 apiRequestAuth :: RequestConstraint a site =>
-    [Header] -> Maybe Authorization -> Args a -> HandlerFor site (Maybe (GQLClientResult a))
+    [Header] -> Maybe Authorization -> Args a -> HandlerFor site (GQLClientResult a)
 apiRequestAuth extraHeaders auth args = do
     apiUrl <- getApiUrl
-    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
+    stream <- liftIO $ request (fromString (toString apiUrl) `withHeaders` headers) args
+    single stream
+        where headers = maybe [] (\x -> [("Authorization", x)]) auth <> extraHeaders
 
 apiRequest :: RequestConstraint a site => Bool -> Args a -> HandlerFor site a
 apiRequest authRequired = apiRequest' [] authRequired

frontend/src/Datarekisteri/Frontend/Auth.hs

@@ -37,7 +37,7 @@ postLoginR authReq = do
       FormSuccess auth -> do
           maybeAuth <- liftHandler $ authReq $ ("Basic " <> ) $ B64.encodeBase64 $ encodeUtf8 auth
           case maybeAuth of
-            Nothing -> loginErrorMessageI LoginR Msg.InvalidEmailPass -- invalid creds
+            Nothing -> loginErrorMessageI LoginR Msg.NoIdentifierProvided -- invalid creds
             Just txt -> do
                 setCredsRedirect Creds {credsPlugin = pluginName, credsIdent = txt, credsExtra = []}
       _ -> loginErrorMessageI LoginR Msg.NoIdentifierProvided

frontend/src/Datarekisteri/Frontend/Types.hs

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