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 {..} = 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\""
raiseStatus status401 "Wrong password or email"
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)

View File

@ -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,

View File

@ -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

View File

@ -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