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 {..} = 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)

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

@ -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.NoIdentifierProvided -- invalid creds
Nothing -> loginErrorMessageI LoginR Msg.InvalidEmailPass -- invalid creds
Just txt -> do
setCredsRedirect Creds {credsPlugin = pluginName, credsIdent = txt, credsExtra = []}
_ -> loginErrorMessageI LoginR Msg.NoIdentifierProvided

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