Compare commits
3 Commits
28af340573
...
4a78b6f7bf
Author | SHA1 | Date |
---|---|---|
Saku Laesvuori | 4a78b6f7bf | |
Saku Laesvuori | e5dc50195f | |
Saku Laesvuori | 34f4df608c |
|
@ -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)
|
||||||
|
|
|
@ -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,
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Reference in New Issue