Fix internal server error on invalid credentials

This commit is contained in:
Saku Laesvuori 2023-11-01 18:33:21 +02:00
parent 34f4df608c
commit e5dc50195f
Signed by: slaesvuo
GPG Key ID: 257D284A2A1D3A32
4 changed files with 32 additions and 16 deletions

View File

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

View File

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

View File

@ -13,8 +13,12 @@ module Datarekisteri.Frontend.ApiRequests where
import Relude import Relude
import Control.Exception (handle, throwIO)
import Data.Aeson (ToJSON, FromJSON) import Data.Aeson (ToJSON, FromJSON)
import Data.Morpheus.Client (RequestType, RequestArgs, Args, GQLClientResult, FetchError(..), single, request, withHeaders) 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 (HandlerFor, getYesod, liftHandler)
import Yesod.Auth (YesodAuth, AuthId, requireAuthId, maybeAuthId) 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 apiRequest' extraHeaders authRequired args = do
yesod <- liftHandler getYesod yesod <- liftHandler getYesod
auth <- fmap (authIdToAuthorization yesod) <$> if authRequired then Just <$> requireAuthId else maybeAuthId 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 => 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 apiRequestAuth extraHeaders auth args = do
apiUrl <- getApiUrl apiUrl <- getApiUrl
stream <- liftIO $ request (fromString (toString apiUrl) `withHeaders` headers) args let headers = maybe [] (\x -> [("Authorization", x)]) auth <> extraHeaders
single stream handleUnauthorized e@(VanillaHttpException (HttpExceptionRequest _ (StatusCodeException response _)))
where headers = maybe [] (\x -> [("Authorization", x)]) auth <> extraHeaders | 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 :: RequestConstraint a site => Bool -> Args a -> HandlerFor site a
apiRequest authRequired = apiRequest' [] authRequired apiRequest authRequired = apiRequest' [] authRequired

View File

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