151 lines
5.4 KiB
Haskell
151 lines
5.4 KiB
Haskell
-- SPDX-FileCopyrightText: 2023 David Mosbach <david.mosbach@uniworx.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
module Auth.OAuth2
|
|
( AzureUserException(..)
|
|
, azurePluginName
|
|
, oauth2MockServer
|
|
, mockPluginName
|
|
, queryOAuth2User
|
|
, UserDataException
|
|
) where
|
|
|
|
import Data.Maybe (fromJust)
|
|
import Data.Text
|
|
|
|
import Import.NoFoundation hiding (unpack)
|
|
|
|
import Network.HTTP.Simple (httpJSONEither, getResponseBody, JSONException)
|
|
|
|
import System.Environment (lookupEnv)
|
|
|
|
import Yesod.Auth.OAuth2
|
|
import Yesod.Auth.OAuth2.Prelude hiding (encodeUtf8)
|
|
|
|
|
|
data AzureUserException = AzureUserError
|
|
| AzureUserNoResult
|
|
| AzureUserAmbiguous -- TODO
|
|
deriving (Show, Eq, Generic)
|
|
|
|
instance Exception AzureUserException
|
|
|
|
azurePluginName :: Text
|
|
azurePluginName = "azureadv2"
|
|
|
|
-----------------------------------------------
|
|
---- OAuth2 + OIDC development auth plugin ----
|
|
-----------------------------------------------
|
|
|
|
mockPluginName :: Text
|
|
mockPluginName = "dev-oauth2-mock"
|
|
|
|
newtype UserID = UserID Text
|
|
instance FromJSON UserID where
|
|
parseJSON = withObject "UserID" $ \o ->
|
|
UserID <$> o .: "id"
|
|
|
|
oauth2MockServer :: YesodAuth m => String -> AuthPlugin m
|
|
oauth2MockServer port =
|
|
let oa = OAuth2
|
|
{ oauth2ClientId = "42"
|
|
, oauth2ClientSecret = Just "shhh"
|
|
, oauth2AuthorizeEndpoint = (fromString $ mockServerURL <> "/auth")
|
|
`withQuery` [ scopeParam " " ["openid", "profile", "email", "offline_access"] -- TODO read scopes from config
|
|
, ("response_type", "code id_token")
|
|
, ("nonce", "Foo") -- TODO generate meaningful value
|
|
]
|
|
, oauth2TokenEndpoint = fromString $ mockServerURL <> "/token"
|
|
, oauth2RedirectUri = Nothing
|
|
}
|
|
mockServerURL = "http://localhost:" <> fromString port
|
|
profileSrc = fromString $ mockServerURL <> "/users/me"
|
|
in authOAuth2 mockPluginName oa $ \manager token -> do
|
|
(UserID userID, userResponse) <- authGetProfile mockPluginName manager token profileSrc
|
|
return Creds
|
|
{ credsPlugin = mockPluginName
|
|
, credsIdent = userID
|
|
, credsExtra = setExtra token userResponse
|
|
}
|
|
|
|
----------------------
|
|
---- User Queries ----
|
|
----------------------
|
|
|
|
data UserDataException = UserDataJSONException JSONException
|
|
| UserDataInternalException Text
|
|
deriving Show
|
|
|
|
instance Exception UserDataException
|
|
|
|
queryOAuth2User :: forall j m . (FromJSON j, MonadIO m, MonadThrow m, MonadHandler m)
|
|
=> Text
|
|
-> m (Either UserDataException j)
|
|
queryOAuth2User userID = runExceptT $ do
|
|
(queryUrl, tokenUrl) <- liftIO mkBaseUrls
|
|
req <- parseRequest $ "GET " ++ queryUrl ++ unpack userID
|
|
mTokens <- lookupSessionJson SessionOAuth2Token
|
|
unless (isJust mTokens) . throwE $ UserDataInternalException "Tried to load session Oauth2 tokens, but there are none"
|
|
# ifdef DEVELOPMENT
|
|
let secure = False
|
|
# else
|
|
let secure = True
|
|
# endif
|
|
newTokens <- refreshOAuth2Token @m (fromJust mTokens) tokenUrl secure
|
|
setSessionJson SessionOAuth2Token (Just $ accessToken newTokens, refreshToken newTokens)
|
|
eResult <- lift $ getResponseBody <$> httpJSONEither @m @j (req
|
|
{ secure = secure
|
|
, requestHeaders = [("Authorization", encodeUtf8 . ("Bearer " <>) . atoken $ accessToken newTokens)]
|
|
})
|
|
case eResult of
|
|
Left x -> throwE $ UserDataJSONException x
|
|
Right x -> return x
|
|
|
|
|
|
mkBaseUrls :: IO (String, String)
|
|
mkBaseUrls = do
|
|
# ifndef DEVELOPMENT
|
|
Just tenantID <- lookupEnv "AZURE_TENANT_ID"
|
|
return ( "https://graph.microsoft.com/v1.0/users/"
|
|
, "https://login.microsoftonline.com/" ++ tenantID ++ "/oauth2/v2.0" )
|
|
# else
|
|
Just port <- lookupEnv "OAUTH2_SERVER_PORT"
|
|
let base = "http://localhost:" ++ port
|
|
return ( base ++ "/users/query?id="
|
|
, base ++ "/token" )
|
|
# endif
|
|
|
|
|
|
refreshOAuth2Token :: forall m. (MonadIO m, MonadThrow m, MonadHandler m)
|
|
=> (Maybe AccessToken, Maybe RefreshToken)
|
|
-> String
|
|
-> Bool
|
|
-> ExceptT UserDataException m OAuth2Token
|
|
refreshOAuth2Token (_, rToken) url secure
|
|
| isJust rToken = do
|
|
req <- parseRequest $ "POST " ++ url
|
|
let
|
|
body =
|
|
[ ("grant_type", "refresh_token")
|
|
, ("refresh_token", encodeUtf8 . rtoken $ fromJust rToken)
|
|
]
|
|
body' <- if secure then do
|
|
clientID <- liftIO $ fromJust <$> lookupEnv "CLIENT_ID"
|
|
clientSecret <- liftIO $ fromJust <$> lookupEnv "CLIENT_SECRET"
|
|
return $ body ++ [("client_id", fromString clientID), ("client_secret", fromString clientSecret), ("scope", "openid profile offline_access")] -- TODO read from config
|
|
else return $ ("scope", "openid profile offline_access") : body -- TODO read from config
|
|
$logErrorS "\27[31mAdmin Handler\27[0m" $ tshow (requestBody $ urlEncodedBody body' req{ secure = secure })
|
|
eResult <- lift $ getResponseBody <$> httpJSONEither @m @OAuth2Token (urlEncodedBody body' req{ secure = secure })
|
|
case eResult of
|
|
Left x -> throwE $ UserDataJSONException x
|
|
Right x -> return x
|
|
| otherwise = throwE $ UserDataInternalException "Could not refresh access token. Refresh token is missing."
|
|
|
|
instance Show RequestBody where
|
|
show (RequestBodyLBS x) = show x
|
|
show _ = error ":("
|
|
|