Compare commits

..

No commits in common. "4a78b6f7bfc2c5a09fce0b44158db42e4698c860" and "28af340573bad840477ce171b8eb3abfd73ace9d" have entirely different histories.

5 changed files with 17 additions and 33 deletions

View File

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

View File

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

View File

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

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

View File

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