Compare commits

...

3 Commits

5 changed files with 33 additions and 17 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 raiseStatus status401 "Wrong password or email"
else do setHeader "WWW-Authenticate" "Basic realm=\"GraphQL API\", Bearer realm\"GraphQL API\"" case maybeUser of
raiseStatus status401 "Wrong password or email" 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

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

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