Compare commits
No commits in common. "4a78b6f7bfc2c5a09fce0b44158db42e4698c860" and "28af340573bad840477ce171b8eb3abfd73ace9d" have entirely different histories.
4a78b6f7bf
...
28af340573
|
@ -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
|
||||
Right user@DBUser {..} <- lift $ dbGetUserByEmail emailAddress
|
||||
correctPassword <- checkPassword password <$> lift dbUserPasswordHash
|
||||
unless correctPassword unauthorized
|
||||
pure user
|
||||
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)
|
||||
|
|
|
@ -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,
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue