From 71e8f49b225d17001dd3fe4752d238b3d40c642c Mon Sep 17 00:00:00 2001 From: Marco Zocca Date: Wed, 4 Oct 2023 09:09:06 +0200 Subject: [PATCH] vendor in hoauth --- ms-auth/ms-auth.cabal | 23 +- ms-auth/src/Network/OAuth/OAuth2.hs | 19 + .../OAuth/OAuth2/AuthorizationRequest.hs | 68 ++ .../src/Network/OAuth/OAuth2/HttpClient.hs | 341 +++++++++ ms-auth/src/Network/OAuth/OAuth2/Internal.hs | 218 ++++++ .../src/Network/OAuth/OAuth2/TokenRequest.hs | 310 ++++++++ ms-auth/src/Network/OAuth2/Internal/Pkce.hs | 81 ++ ms-auth/src/Network/OAuth2/Internal/Types.hs | 694 ++++++++++++++++++ ms-auth/src/Network/OAuth2/Internal/Utils.hs | 21 + .../src/Network/OAuth2/Provider/AzureAD.hs | 2 +- .../Network/OAuth2/Provider/AzureAD/SAS.hs | 3 + .../OAuth2/Provider/AzureAD/SharedKey.hs | 137 ++++ ms-auth/src/Network/OAuth2/Session.hs | 13 +- 13 files changed, 1919 insertions(+), 11 deletions(-) create mode 100644 ms-auth/src/Network/OAuth/OAuth2.hs create mode 100644 ms-auth/src/Network/OAuth/OAuth2/AuthorizationRequest.hs create mode 100644 ms-auth/src/Network/OAuth/OAuth2/HttpClient.hs create mode 100644 ms-auth/src/Network/OAuth/OAuth2/Internal.hs create mode 100644 ms-auth/src/Network/OAuth/OAuth2/TokenRequest.hs create mode 100644 ms-auth/src/Network/OAuth2/Internal/Pkce.hs create mode 100644 ms-auth/src/Network/OAuth2/Internal/Types.hs create mode 100644 ms-auth/src/Network/OAuth2/Internal/Utils.hs create mode 100644 ms-auth/src/Network/OAuth2/Provider/AzureAD/SAS.hs create mode 100644 ms-auth/src/Network/OAuth2/Provider/AzureAD/SharedKey.hs diff --git a/ms-auth/ms-auth.cabal b/ms-auth/ms-auth.cabal index b118de0..58525cb 100644 --- a/ms-auth/ms-auth.cabal +++ b/ms-auth/ms-auth.cabal @@ -1,5 +1,5 @@ name: ms-auth -version: 0.4.0.0 +version: 0.5.0.0 synopsis: Microsoft Authentication API description: Bindings to the Microsoft Identity API / Active Directory (AD) for building applications that use either Authorization Code (User-facing) or (App-only) authorization flows. Helper functions are provided for building OAuth2 authentication flows and keep tokens transactionally secure and up to date. homepage: https://github.com/unfoldml/ms-graph-api @@ -20,18 +20,34 @@ library hs-source-dirs: src exposed-modules: MSAuth Network.OAuth2.Provider.AzureAD - other-modules: Network.OAuth2.JWT + other-modules: Network.OAuth2.Provider.AzureAD.SharedKey + Network.OAuth.OAuth2 + Network.OAuth.OAuth2.AuthorizationRequest + Network.OAuth.OAuth2.HttpClient + Network.OAuth.OAuth2.Internal + Network.OAuth.OAuth2.TokenRequest + Network.OAuth2.Internal.Pkce + Network.OAuth2.Internal.Types + Network.OAuth2.Internal.Utils + Network.OAuth2.JWT Network.OAuth2.Session build-depends: aeson , base >= 4.7 && < 5 + , binary >= 0.8 + , base64 , bytestring + , conduit >= 1.3 , containers + , cryptohash-sha256 , directory , directory >= 1.3.6.2 - , hoauth2 == 2.6.0 + , entropy + , exceptions >= 0.10 , http-client + , http-conduit >= 2.3 , http-types , jwt + , microlens >= 0.4 , scientific , scotty , text @@ -39,6 +55,7 @@ library , transformers , unliftio , uri-bytestring + , uri-bytestring-aeson >= 0.1 , validation-micro ghc-options: -Wall -Wcompat diff --git a/ms-auth/src/Network/OAuth/OAuth2.hs b/ms-auth/src/Network/OAuth/OAuth2.hs new file mode 100644 index 0000000..51bba24 --- /dev/null +++ b/ms-auth/src/Network/OAuth/OAuth2.hs @@ -0,0 +1,19 @@ +-- | A lightweight oauth2 Haskell binding. +-- See Readme for more details +-- +module Network.OAuth.OAuth2 + ( module Network.OAuth.OAuth2.HttpClient, + module Network.OAuth.OAuth2.AuthorizationRequest, + module Network.OAuth.OAuth2.TokenRequest, + module Network.OAuth.OAuth2.Internal, + ) +where + +{- + Hiding Errors data type from default. + Shall qualified import given the naming collision. +-} +import Network.OAuth.OAuth2.AuthorizationRequest hiding (Errors(..)) +import Network.OAuth.OAuth2.HttpClient +import Network.OAuth.OAuth2.Internal +import Network.OAuth.OAuth2.TokenRequest hiding (Errors(..)) diff --git a/ms-auth/src/Network/OAuth/OAuth2/AuthorizationRequest.hs b/ms-auth/src/Network/OAuth/OAuth2/AuthorizationRequest.hs new file mode 100644 index 0000000..757722f --- /dev/null +++ b/ms-auth/src/Network/OAuth/OAuth2/AuthorizationRequest.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Bindings Authorization part of The OAuth 2.0 Authorization Framework +-- RFC6749 +module Network.OAuth.OAuth2.AuthorizationRequest where + +import Data.Aeson +import Data.Function (on) +import qualified Data.List as List +import qualified Data.Text.Encoding as T +import GHC.Generics (Generic) +import Lens.Micro (over) +import Network.OAuth.OAuth2.Internal +import URI.ByteString + +-------------------------------------------------- + +-- * Errors + +-------------------------------------------------- + +instance FromJSON Errors where + parseJSON = genericParseJSON defaultOptions {constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True} + +instance ToJSON Errors where + toEncoding = genericToEncoding defaultOptions {constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True} + +-- | Authorization Code Grant Error Responses https://tools.ietf.org/html/rfc6749#section-4.1.2.1 +-- I found hard time to figure a way to test the authorization error flow +-- When anything wrong in @/authorize@ request (redirect to OAuth2 provider), +-- it will end-up at the Provider page hence no way for this library to parse error response. +-- In other words, @/authorize@ ends up with 4xx or 5xx. +-- Revisit this whenever find a case OAuth2 provider redirects back to Relying party with errors. +data Errors + = InvalidRequest + | UnauthorizedClient + | AccessDenied + | UnsupportedResponseType + | InvalidScope + | ServerError + | TemporarilyUnavailable + deriving (Show, Eq, Generic) + +-------------------------------------------------- + +-- * URLs + +-------------------------------------------------- + +-- | See 'authorizationUrlWithParams' +authorizationUrl :: OAuth2 -> URI +authorizationUrl = authorizationUrlWithParams [] + +-- | Prepare the authorization URL. Redirect to this URL +-- asking for user interactive authentication. +-- +-- @since 2.6.0 +authorizationUrlWithParams :: QueryParams -> OAuth2 -> URI +authorizationUrlWithParams qs oa = over (queryL . queryPairsL) (++ queryParts) (oauth2AuthorizeEndpoint oa) + where + queryParts = + List.nubBy ((==) `on` fst) $ + qs + ++ [ ("client_id", T.encodeUtf8 $ oauth2ClientId oa), + ("response_type", "code"), + ("redirect_uri", serializeURIRef' $ oauth2RedirectUri oa) + ] diff --git a/ms-auth/src/Network/OAuth/OAuth2/HttpClient.hs b/ms-auth/src/Network/OAuth/OAuth2/HttpClient.hs new file mode 100644 index 0000000..3708e52 --- /dev/null +++ b/ms-auth/src/Network/OAuth/OAuth2/HttpClient.hs @@ -0,0 +1,341 @@ +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Bindings for The OAuth 2.0 Authorization Framework: Bearer Token Usage +-- RFC6750 +module Network.OAuth.OAuth2.HttpClient + ( -- * AUTH requests + authGetJSON, + authGetBS, + authGetBS2, + authGetJSONWithAuthMethod, + authGetJSONInternal, + authGetBSWithAuthMethod, + authGetBSInternal, + authPostJSON, + authPostBS, + authPostBS2, + authPostBS3, + authPostJSONWithAuthMethod, + authPostJSONInternal, + authPostBSWithAuthMethod, + authPostBSInternal, + + -- * Types + APIAuthenticationMethod (..), + ) +where + +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Trans.Except (ExceptT (..), throwE) +import Data.Aeson (FromJSON, eitherDecode) +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy.Char8 as BSL +import Data.Maybe (fromJust, isJust) +import qualified Data.Text.Encoding as T +import Lens.Micro (over) +import Network.HTTP.Conduit +import qualified Network.HTTP.Types as HT +import Network.OAuth.OAuth2.Internal +import URI.ByteString (URI, URIRef, queryL, queryPairsL) + +-------------------------------------------------- + +-- * AUTH requests + +-- Making request with Access Token appended to Header, Request body or query string. +-- +-------------------------------------------------- + +-- | Conduct an authorized GET request and return response as JSON. +-- Inject Access Token to Authorization Header. +authGetJSON :: + (FromJSON a, MonadIO m) => + -- | HTTP connection manager. + Manager -> + AccessToken -> + URI -> + -- | Response as JSON + ExceptT BSL.ByteString m a +authGetJSON = authGetJSONWithAuthMethod AuthInRequestHeader + +authGetJSONInternal :: + (FromJSON a, MonadIO m) => + APIAuthenticationMethod -> + -- | HTTP connection manager. + Manager -> + AccessToken -> + URI -> + -- | Response as JSON + ExceptT BSL.ByteString m a +authGetJSONInternal = authGetJSONWithAuthMethod +{-# DEPRECATED authGetJSONInternal "use authGetJSONWithAuthMethod" #-} + +-- | Conduct an authorized GET request and return response as JSON. +-- Allow to specify how to append AccessToken. +-- +-- @since 2.6.0 +authGetJSONWithAuthMethod :: + (MonadIO m, FromJSON a) => + APIAuthenticationMethod -> + -- | HTTP connection manager. + Manager -> + AccessToken -> + URI -> + -- | Response as JSON + ExceptT BSL.ByteString m a +authGetJSONWithAuthMethod authTypes manager t uri = do + resp <- authGetBSWithAuthMethod authTypes manager t uri + either (throwE . BSL.pack) return (eitherDecode resp) + +-- | Conduct an authorized GET request. +-- Inject Access Token to Authorization Header. +authGetBS :: + (MonadIO m) => + -- | HTTP connection manager. + Manager -> + AccessToken -> + URI -> + -- | Response as ByteString + ExceptT BSL.ByteString m BSL.ByteString +authGetBS = authGetBSWithAuthMethod AuthInRequestHeader + +-- | Same to 'authGetBS' but set access token to query parameter rather than header +authGetBS2 :: + (MonadIO m) => + -- | HTTP connection manager. + Manager -> + AccessToken -> + URI -> + -- | Response as ByteString + ExceptT BSL.ByteString m BSL.ByteString +authGetBS2 = authGetBSWithAuthMethod AuthInRequestQuery +{-# DEPRECATED authGetBS2 "use authGetBSWithAuthMethod" #-} + +authGetBSInternal :: + (MonadIO m) => + APIAuthenticationMethod -> + -- | HTTP connection manager. + Manager -> + AccessToken -> + URI -> + -- | Response as ByteString + ExceptT BSL.ByteString m BSL.ByteString +authGetBSInternal = authGetBSWithAuthMethod +{-# DEPRECATED authGetBSInternal "use authGetBSWithAuthMethod" #-} + +-- | Conduct an authorized GET request and return response as ByteString. +-- Allow to specify how to append AccessToken. +-- +-- @since 2.6.0 +authGetBSWithAuthMethod :: + (MonadIO m) => + -- | Specify the way that how to append the 'AccessToken' in the request + APIAuthenticationMethod -> + -- | HTTP connection manager. + Manager -> + AccessToken -> + URI -> + -- | Response as ByteString + ExceptT BSL.ByteString m BSL.ByteString +authGetBSWithAuthMethod authTypes manager token url = do + let appendToUrl = AuthInRequestQuery == authTypes + let appendToHeader = AuthInRequestHeader == authTypes + let uri = if appendToUrl then url `appendAccessToken` token else url + let upReq = updateRequestHeaders (if appendToHeader then Just token else Nothing) . setMethod HT.GET + req <- liftIO $ uriToRequest uri + authRequest req upReq manager + +-- | Conduct POST request and return response as JSON. +-- Inject Access Token to Authorization Header. +authPostJSON :: + (FromJSON a, MonadIO m) => + -- | HTTP connection manager. + Manager -> + AccessToken -> + URI -> + PostBody -> + -- | Response as JSON + ExceptT BSL.ByteString m a +authPostJSON = authPostJSONWithAuthMethod AuthInRequestHeader + +authPostJSONInternal :: + (FromJSON a, MonadIO m) => + APIAuthenticationMethod -> + -- | HTTP connection manager. + Manager -> + AccessToken -> + URI -> + PostBody -> + -- | Response as ByteString + ExceptT BSL.ByteString m a +authPostJSONInternal = authPostJSONWithAuthMethod +{-# DEPRECATED authPostJSONInternal "use 'authPostJSONWithAuthMethod'" #-} + +-- | Conduct POST request and return response as JSON. +-- Allow to specify how to append AccessToken. +-- +-- @since 2.6.0 +authPostJSONWithAuthMethod :: + (FromJSON a, MonadIO m) => + APIAuthenticationMethod -> + -- | HTTP connection manager. + Manager -> + AccessToken -> + URI -> + PostBody -> + -- | Response as ByteString + ExceptT BSL.ByteString m a +authPostJSONWithAuthMethod authTypes manager token url body = do + resp <- authPostBSWithAuthMethod authTypes manager token url body + either (throwE . BSL.pack) return (eitherDecode resp) + +-- | Conduct POST request. +-- Inject Access Token to http header (Authorization) +authPostBS :: + (MonadIO m) => + -- | HTTP connection manager. + Manager -> + AccessToken -> + URI -> + PostBody -> + -- | Response as ByteString + ExceptT BSL.ByteString m BSL.ByteString +authPostBS = authPostBSWithAuthMethod AuthInRequestHeader + +-- | Conduct POST request with access token only in the request body but header. +authPostBS2 :: + (MonadIO m) => + -- | HTTP connection manager. + Manager -> + AccessToken -> + URI -> + PostBody -> + -- | Response as ByteString + ExceptT BSL.ByteString m BSL.ByteString +authPostBS2 = authPostBSWithAuthMethod AuthInRequestBody +{-# DEPRECATED authPostBS2 "use 'authPostBSWithAuthMethod'" #-} + +-- | Conduct POST request with access token only in the header and not in body +authPostBS3 :: + (MonadIO m) => + -- | HTTP connection manager. + Manager -> + AccessToken -> + URI -> + PostBody -> + -- | Response as ByteString + ExceptT BSL.ByteString m BSL.ByteString +authPostBS3 = authPostBSWithAuthMethod AuthInRequestHeader +{-# DEPRECATED authPostBS3 "use 'authPostBSWithAuthMethod'" #-} + +authPostBSInternal :: + (MonadIO m) => + APIAuthenticationMethod -> + -- | HTTP connection manager. + Manager -> + AccessToken -> + URI -> + PostBody -> + -- | Response as ByteString + ExceptT BSL.ByteString m BSL.ByteString +authPostBSInternal = authPostBSWithAuthMethod +{-# DEPRECATED authPostBSInternal "use 'authPostBSWithAuthMethod'" #-} + +-- | Conduct POST request and return response as ByteString. +-- Allow to specify how to append AccessToken. +-- +-- @since 2.6.0 +authPostBSWithAuthMethod :: + (MonadIO m) => + APIAuthenticationMethod -> + -- | HTTP connection manager. + Manager -> + AccessToken -> + URI -> + PostBody -> + -- | Response as ByteString + ExceptT BSL.ByteString m BSL.ByteString +authPostBSWithAuthMethod authTypes manager token url body = do + let appendToBody = AuthInRequestBody == authTypes + let appendToHeader = AuthInRequestHeader == authTypes + let reqBody = if appendToBody then body ++ accessTokenToParam token else body + -- TODO: urlEncodedBody send request as 'application/x-www-form-urlencoded' + -- seems shall go with application/json which is more common? + let upBody = if null reqBody then id else urlEncodedBody reqBody + let upHeaders = updateRequestHeaders (if appendToHeader then Just token else Nothing) . setMethod HT.POST + let upReq = upHeaders . upBody + + req <- liftIO $ uriToRequest url + authRequest req upReq manager + +-------------------------------------------------- + +-- * Types + +-------------------------------------------------- + +-- | https://www.rfc-editor.org/rfc/rfc6750#section-2 +data APIAuthenticationMethod + = -- | Provides in Authorization header + AuthInRequestHeader + | -- | Provides in request body + AuthInRequestBody + | -- | Provides in request query parameter + AuthInRequestQuery + deriving (Eq, Ord) + +-------------------------------------------------- + +-- * Utilities + +-------------------------------------------------- + +-- | Send an HTTP request. +authRequest :: + (MonadIO m) => + -- | Request to perform + Request -> + -- | Modify request before sending + (Request -> Request) -> + -- | HTTP connection manager. + Manager -> + ExceptT BSL.ByteString m BSL.ByteString +authRequest req upReq manage = ExceptT $ handleResponse <$> httpLbs (upReq req) manage + +-- | Get response body out of a @Response@ +handleResponse :: Response BSL.ByteString -> Either BSL.ByteString BSL.ByteString +handleResponse rsp = + if HT.statusIsSuccessful (responseStatus rsp) + then Right $ responseBody rsp + else -- TODO: better to surface up entire resp so that client can decide what to do when error happens. + Left $ responseBody rsp + +-- | Set several header values: +-- + userAgennt : `hoauth2` +-- + accept : `application/json` +-- + authorization : 'Bearer' `xxxxx` if 'AccessToken' provided. +updateRequestHeaders :: Maybe AccessToken -> Request -> Request +updateRequestHeaders t req = + let bearer = [(HT.hAuthorization, "Bearer " `BS.append` T.encodeUtf8 (atoken (fromJust t))) | isJust t] + headers = bearer ++ defaultRequestHeaders ++ requestHeaders req + in req {requestHeaders = headers} + +-- | Set the HTTP method to use. +setMethod :: HT.StdMethod -> Request -> Request +setMethod m req = req {method = HT.renderStdMethod m} + +-- | For `GET` method API. +appendAccessToken :: + -- | Base URI + URIRef a -> + -- | Authorized Access Token + AccessToken -> + -- | Combined Result + URIRef a +appendAccessToken uri t = over (queryL . queryPairsL) (\query -> query ++ accessTokenToParam t) uri + +-- | Create 'QueryParams' with given access token value. +accessTokenToParam :: AccessToken -> [(BS.ByteString, BS.ByteString)] +accessTokenToParam t = [("access_token", T.encodeUtf8 $ atoken t)] diff --git a/ms-auth/src/Network/OAuth/OAuth2/Internal.hs b/ms-auth/src/Network/OAuth/OAuth2/Internal.hs new file mode 100644 index 0000000..5a738c6 --- /dev/null +++ b/ms-auth/src/Network/OAuth/OAuth2/Internal.hs @@ -0,0 +1,218 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} + +module Network.OAuth.OAuth2.Internal where + +import Control.Applicative +import Control.Arrow (second) +import Control.Monad.Catch +import Data.Aeson +import Data.Aeson.Types (Parser, explicitParseFieldMaybe) +import Data.Binary (Binary) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import Data.Maybe +import Data.Text (Text, pack, unpack) +import Data.Text.Encoding +import GHC.Generics +import Lens.Micro +import Lens.Micro.Extras +import Network.HTTP.Conduit as C +import qualified Network.HTTP.Types as H +import qualified Network.HTTP.Types as HT +import URI.ByteString +import URI.ByteString.Aeson () +import URI.ByteString.QQ + +-------------------------------------------------- + +-- * Data Types + +-------------------------------------------------- + +-- | Query Parameter Representation +data OAuth2 = OAuth2 + { oauth2ClientId :: Text, + oauth2ClientSecret :: Text, + oauth2AuthorizeEndpoint :: URIRef Absolute, + oauth2TokenEndpoint :: URIRef Absolute, + oauth2RedirectUri :: URIRef Absolute + } + deriving (Show, Eq) + +defaultOAuth2 :: OAuth2 +defaultOAuth2 = + OAuth2 + { oauth2ClientId = "", + oauth2ClientSecret = "", + oauth2AuthorizeEndpoint = [uri|https://www.example.com/|], + oauth2TokenEndpoint = [uri|https://www.example.com/|], + oauth2RedirectUri = [uri|https://www.example.com/|] + } + +newtype AccessToken = AccessToken {atoken :: Text} deriving (Binary, Eq, Show, FromJSON, ToJSON) + +newtype RefreshToken = RefreshToken {rtoken :: Text} deriving (Binary, Eq, Show, FromJSON, ToJSON) + +newtype IdToken = IdToken {idtoken :: Text} deriving (Binary, Eq, Show, FromJSON, ToJSON) + +-- | Authorization Code +newtype ExchangeToken = ExchangeToken {extoken :: Text} deriving (Show, FromJSON, ToJSON) + +-- | https://www.rfc-editor.org/rfc/rfc6749#section-4.1.4 +data OAuth2Token = OAuth2Token + { accessToken :: AccessToken, + -- | Exists when @offline_access@ scope is in the 'authorizeUrl' and the provider supports Refresh Access Token. + refreshToken :: Maybe RefreshToken, + expiresIn :: Maybe Int, + -- | See https://www.rfc-editor.org/rfc/rfc6749#section-5.1. It's required per spec. But OAuth2 provider implementation are vary. Maybe will remove 'Maybe' in future release. + tokenType :: Maybe Text, + -- | Exists when @openid@ scope is in the 'authorizeUrl' and the provider supports OpenID. + idToken :: Maybe IdToken + } + deriving (Eq, Show, Generic) + +instance Binary OAuth2Token + +-- | Parse JSON data into 'OAuth2Token' +instance FromJSON OAuth2Token where + parseJSON = withObject "OAuth2Token" $ \v -> + OAuth2Token + <$> v + .: "access_token" + <*> v + .:? "refresh_token" + <*> explicitParseFieldMaybe parseIntFlexible v "expires_in" + <*> v + .:? "token_type" + <*> v + .:? "id_token" + where + parseIntFlexible :: Value -> Parser Int + parseIntFlexible (String s) = pure . read $ unpack s + parseIntFlexible v = parseJSON v + +instance ToJSON OAuth2Token where + toJSON = genericToJSON defaultOptions {fieldLabelModifier = camelTo2 '_'} + toEncoding = genericToEncoding defaultOptions {fieldLabelModifier = camelTo2 '_'} + +data OAuth2Error a = OAuth2Error + { error :: Either Text a, + errorDescription :: Maybe Text, + errorUri :: Maybe (URIRef Absolute) + } + deriving (Show, Eq, Generic) + +instance FromJSON err => FromJSON (OAuth2Error err) where + parseJSON (Object a) = + do + err <- (a .: "error") >>= (\str -> Right <$> parseJSON str <|> Left <$> parseJSON str) + desc <- a .:? "error_description" + errorUri <- a .:? "error_uri" + return $ OAuth2Error err desc errorUri + parseJSON _ = fail "Expected an object" + +instance ToJSON err => ToJSON (OAuth2Error err) where + toJSON = genericToJSON defaultOptions {constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True} + toEncoding = genericToEncoding defaultOptions {constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True} + +parseOAuth2Error :: FromJSON err => BSL.ByteString -> OAuth2Error err +parseOAuth2Error string = + either (mkDecodeOAuth2Error string) id (eitherDecode string) + +mkDecodeOAuth2Error :: BSL.ByteString -> String -> OAuth2Error err +mkDecodeOAuth2Error response err = + OAuth2Error + (Left "Decode error") + (Just $ pack $ "Error: " <> err <> "\n Original Response:\n" <> show (decodeUtf8 $ BSL.toStrict response)) + Nothing + +-- | https://www.rfc-editor.org/rfc/rfc6749#section-2.3 +-- According to spec: +-- +-- The client MUST NOT use more than one authentication method in each request. +-- +-- Which means use Authorization header or Post body. +-- +-- However, in reality, I always have to include authentication in the header. +-- +-- In other words, 'ClientSecrectBasic' is always assured. 'ClientSecretPost' is optional. +-- +-- Maybe consider an alternative implementation that boolean kind of data type is good enough. +data ClientAuthenticationMethod + = ClientSecretBasic + | ClientSecretPost + deriving (Eq, Ord) + +-------------------------------------------------- + +-- * Types Synonym + +-------------------------------------------------- + +-- | type synonym of post body content +type PostBody = [(BS.ByteString, BS.ByteString)] + +type QueryParams = [(BS.ByteString, BS.ByteString)] + +-------------------------------------------------- + +-- * Utilies + +-------------------------------------------------- + +defaultRequestHeaders :: [(HT.HeaderName, BS.ByteString)] +defaultRequestHeaders = + [ (HT.hUserAgent, "hoauth2"), + (HT.hAccept, "application/json") + ] + +appendQueryParams :: [(BS.ByteString, BS.ByteString)] -> URIRef a -> URIRef a +appendQueryParams params = + over (queryL . queryPairsL) (params ++) + +uriToRequest :: MonadThrow m => URI -> m Request +uriToRequest auri = do + ssl <- case view (uriSchemeL . schemeBSL) auri of + "http" -> return False + "https" -> return True + s -> throwM $ InvalidUrlException (show auri) ("Invalid scheme: " ++ show s) + let query = fmap (second Just) (view (queryL . queryPairsL) auri) + hostL = authorityL . _Just . authorityHostL . hostBSL + portL = authorityL . _Just . authorityPortL . _Just . portNumberL + defaultPort = (if ssl then 443 else 80) :: Int + + req = + setQueryString query $ + defaultRequest + { secure = ssl, + path = view pathL auri + } + req2 = (over hostLens . maybe id const . preview hostL) auri req + req3 = (over portLens . (const . fromMaybe defaultPort) . preview portL) auri req2 + return req3 + +requestToUri :: Request -> URI +requestToUri req = + URI + ( Scheme + ( if secure req + then "https" + else "http" + ) + ) + (Just (Authority Nothing (Host $ host req) (Just $ Port $ port req))) + (path req) + (Query $ H.parseSimpleQuery $ queryString req) + Nothing + +hostLens :: Lens' Request BS.ByteString +hostLens f req = f (C.host req) <&> \h' -> req {C.host = h'} +{-# INLINE hostLens #-} + +portLens :: Lens' Request Int +portLens f req = f (C.port req) <&> \p' -> req {C.port = p'} +{-# INLINE portLens #-} diff --git a/ms-auth/src/Network/OAuth/OAuth2/TokenRequest.hs b/ms-auth/src/Network/OAuth/OAuth2/TokenRequest.hs new file mode 100644 index 0000000..07dd3e7 --- /dev/null +++ b/ms-auth/src/Network/OAuth/OAuth2/TokenRequest.hs @@ -0,0 +1,310 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Bindings Access Token and Refresh Token part of The OAuth 2.0 Authorization Framework +-- RFC6749 +module Network.OAuth.OAuth2.TokenRequest where + +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Trans.Except (ExceptT (..), throwE) +import Data.Aeson +import qualified Data.Aeson.Key as Key +import qualified Data.Aeson.KeyMap as KeyMap +import qualified Data.ByteString.Lazy.Char8 as BSL +import qualified Data.Text.Encoding as T +import GHC.Generics (Generic) +import Network.HTTP.Conduit +import qualified Network.HTTP.Types as HT +import Network.HTTP.Types.URI (parseQuery) +import Network.OAuth.OAuth2.Internal +import URI.ByteString (URI, serializeURIRef') + +-------------------------------------------------- + +-- * Token Request Errors + +-------------------------------------------------- + +instance FromJSON Errors where + parseJSON = genericParseJSON defaultOptions {constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True} + +instance ToJSON Errors where + toEncoding = genericToEncoding defaultOptions {constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True} + +-- | Token Error Responses https://tools.ietf.org/html/rfc6749#section-5.2 +data Errors + = InvalidRequest + | InvalidClient + | InvalidGrant + | UnauthorizedClient + | UnsupportedGrantType + | InvalidScope + deriving (Show, Eq, Generic) + +-------------------------------------------------- + +-- * URL + +-------------------------------------------------- + +-- | Prepare the URL and the request body query for fetching an access token. +accessTokenUrl :: + OAuth2 -> + -- | access code gained via authorization URL + ExchangeToken -> + -- | access token request URL plus the request body. + (URI, PostBody) +accessTokenUrl oa code = + let uri = oauth2TokenEndpoint oa + body = + [ ("code", T.encodeUtf8 $ extoken code), + ("redirect_uri", serializeURIRef' $ oauth2RedirectUri oa), + ("grant_type", "authorization_code") + ] + in (uri, body) + +-- | Obtain a new access token by sending a Refresh Token to the Authorization server. +refreshAccessTokenUrl :: + OAuth2 -> + -- | Refresh Token gained via authorization URL + RefreshToken -> + -- | Refresh Token request URL plus the request body. + (URI, PostBody) +refreshAccessTokenUrl oa token = (uri, body) + where + uri = oauth2TokenEndpoint oa + body = + [ ("grant_type", "refresh_token"), + ("refresh_token", T.encodeUtf8 $ rtoken token) + ] + +-------------------------------------------------- + +-- * Token management + +-------------------------------------------------- + +-- | Exchange @code@ for an Access Token with authenticate in request header. +fetchAccessToken :: + (MonadIO m) => + -- | HTTP connection manager + Manager -> + -- | OAuth Data + OAuth2 -> + -- | OAuth2 Code + ExchangeToken -> + -- | Access Token + ExceptT (OAuth2Error Errors) m OAuth2Token +fetchAccessToken = fetchAccessTokenWithAuthMethod ClientSecretBasic + +fetchAccessToken2 :: + (MonadIO m) => + -- | HTTP connection manager + Manager -> + -- | OAuth Data + OAuth2 -> + -- | Authorization Code + ExchangeToken -> + -- | Access Token + ExceptT (OAuth2Error Errors) m OAuth2Token +fetchAccessToken2 = fetchAccessTokenWithAuthMethod ClientSecretPost +{-# DEPRECATED fetchAccessToken2 "use 'fetchAccessTokenWithAuthMethod'" #-} + +fetchAccessTokenInternal :: + (MonadIO m) => + ClientAuthenticationMethod -> + -- | HTTP connection manager + Manager -> + -- | OAuth Data + OAuth2 -> + -- | Authorization Code + ExchangeToken -> + -- | Access Token + ExceptT (OAuth2Error Errors) m OAuth2Token +fetchAccessTokenInternal = fetchAccessTokenWithAuthMethod +{-# DEPRECATED fetchAccessTokenInternal "use 'fetchAccessTokenWithAuthMethod'" #-} + +-- | Exchange @code@ for an Access Token +-- +-- OAuth2 spec allows credential (`client_id`, `client_secret`) to be sent +-- either in the header (a.k.a 'ClientSecretBasic'). +-- or as form/url params (a.k.a 'ClientSecretPost'). +-- +-- The OAuth provider can choose to implement only one, or both. +-- Look for API document from the OAuth provider you're dealing with. +-- If you're uncertain, try 'fetchAccessToken' which sends credential +-- in authorization http header, which is common case. +-- +-- @since 2.6.0 +fetchAccessTokenWithAuthMethod :: + (MonadIO m) => + ClientAuthenticationMethod -> + -- | HTTP connection manager + Manager -> + -- | OAuth Data + OAuth2 -> + -- | Authorization Code + ExchangeToken -> + -- | Access Token + ExceptT (OAuth2Error Errors) m OAuth2Token +fetchAccessTokenWithAuthMethod authMethod manager oa code = do + let (uri, body) = accessTokenUrl oa code + let extraBody = if authMethod == ClientSecretPost then clientSecretPost oa else [] + doJSONPostRequest manager oa uri (body ++ extraBody) + +-- | Fetch a new AccessToken using the Refresh Token with authentication in request header. +refreshAccessToken :: + (MonadIO m) => + -- | HTTP connection manager. + Manager -> + -- | OAuth context + OAuth2 -> + -- | Refresh Token gained after authorization + RefreshToken -> + ExceptT (OAuth2Error Errors) m OAuth2Token +refreshAccessToken = refreshAccessTokenWithAuthMethod ClientSecretBasic + +refreshAccessToken2 :: + (MonadIO m) => + -- | HTTP connection manager. + Manager -> + -- | OAuth context + OAuth2 -> + -- | Refresh Token gained after authorization + RefreshToken -> + ExceptT (OAuth2Error Errors) m OAuth2Token +refreshAccessToken2 = refreshAccessTokenWithAuthMethod ClientSecretPost +{-# DEPRECATED refreshAccessToken2 "use 'refreshAccessTokenWithAuthMethod'" #-} + +refreshAccessTokenInternal :: + (MonadIO m) => + ClientAuthenticationMethod -> + -- | HTTP connection manager. + Manager -> + -- | OAuth context + OAuth2 -> + -- | Refresh Token gained after authorization + RefreshToken -> + ExceptT (OAuth2Error Errors) m OAuth2Token +refreshAccessTokenInternal = refreshAccessTokenWithAuthMethod +{-# DEPRECATED refreshAccessTokenInternal "use 'refreshAccessTokenWithAuthMethod'" #-} + +-- | Fetch a new AccessToken using the Refresh Token. +-- +-- OAuth2 spec allows credential (`client_id`, `client_secret`) to be sent +-- either in the header (a.k.a 'ClientSecretBasic'). +-- or as form/url params (a.k.a 'ClientSecretPost'). +-- +-- The OAuth provider can choose to implement only one, or both. +-- Look for API document from the OAuth provider you're dealing with. +-- If you're uncertain, try 'refreshAccessToken' which sends credential +-- in authorization http header, which is common case. +-- +-- @since 2.6.0 +refreshAccessTokenWithAuthMethod :: + (MonadIO m) => + ClientAuthenticationMethod -> + -- | HTTP connection manager. + Manager -> + -- | OAuth context + OAuth2 -> + -- | Refresh Token gained after authorization + RefreshToken -> + ExceptT (OAuth2Error Errors) m OAuth2Token +refreshAccessTokenWithAuthMethod authMethod manager oa token = do + let (uri, body) = refreshAccessTokenUrl oa token + let extraBody = if authMethod == ClientSecretPost then clientSecretPost oa else [] + doJSONPostRequest manager oa uri (body ++ extraBody) + +-------------------------------------------------- + +-- * Utilies + +-------------------------------------------------- + +-- | Conduct post request and return response as JSON. +doJSONPostRequest :: + (MonadIO m, FromJSON err, FromJSON a) => + -- | HTTP connection manager. + Manager -> + -- | OAuth options + OAuth2 -> + -- | The URL + URI -> + -- | request body + PostBody -> + -- | Response as JSON + ExceptT (OAuth2Error err) m a +doJSONPostRequest manager oa uri body = do + resp <- doSimplePostRequest manager oa uri body + case parseResponseFlexible resp of + Right obj -> return obj + Left e -> throwE e + +-- | Conduct post request. +doSimplePostRequest :: + (MonadIO m, FromJSON err) => + -- | HTTP connection manager. + Manager -> + -- | OAuth options + OAuth2 -> + -- | URL + URI -> + -- | Request body. + PostBody -> + -- | Response as ByteString + ExceptT (OAuth2Error err) m BSL.ByteString +doSimplePostRequest manager oa url body = + ExceptT . liftIO $ fmap handleOAuth2TokenResponse go + where + addBasicAuth = applyBasicAuth (T.encodeUtf8 $ oauth2ClientId oa) (T.encodeUtf8 $ oauth2ClientSecret oa) + go = do + req <- uriToRequest url + let req' = (addBasicAuth . addDefaultRequestHeaders) req + httpLbs (urlEncodedBody body req') manager + +-- | Gets response body from a @Response@ if 200 otherwise assume 'OAuth2Error' +handleOAuth2TokenResponse :: FromJSON err => Response BSL.ByteString -> Either (OAuth2Error err) BSL.ByteString +handleOAuth2TokenResponse rsp = + if HT.statusIsSuccessful (responseStatus rsp) + then Right $ responseBody rsp + else Left $ parseOAuth2Error (responseBody rsp) + +-- | Try to parses response as JSON, if failed, try to parse as like query string. +parseResponseFlexible :: + (FromJSON err, FromJSON a) => + BSL.ByteString -> + Either (OAuth2Error err) a +parseResponseFlexible r = case eitherDecode r of + Left _ -> parseResponseString r + Right x -> Right x + +-- | Parses the response that contains not JSON but a Query String +parseResponseString :: + (FromJSON err, FromJSON a) => + BSL.ByteString -> + Either (OAuth2Error err) a +parseResponseString b = case parseQuery $ BSL.toStrict b of + [] -> Left errorMessage + a -> case fromJSON $ queryToValue a of + Error _ -> Left errorMessage + Success x -> Right x + where + queryToValue = Object . KeyMap.fromList . map paramToPair + paramToPair (k, mv) = (Key.fromText $ T.decodeUtf8 k, maybe Null (String . T.decodeUtf8) mv) + errorMessage = parseOAuth2Error b + +-- | Set several header values: +-- + userAgennt : `hoauth2` +-- + accept : `application/json` +addDefaultRequestHeaders :: Request -> Request +addDefaultRequestHeaders req = + let headers = defaultRequestHeaders ++ requestHeaders req + in req {requestHeaders = headers} + +-- | Add Credential (client_id, client_secret) to the request post body. +clientSecretPost :: OAuth2 -> PostBody +clientSecretPost oa = + [ ("client_id", T.encodeUtf8 $ oauth2ClientId oa), + ("client_secret", T.encodeUtf8 $ oauth2ClientSecret oa) + ] diff --git a/ms-auth/src/Network/OAuth2/Internal/Pkce.hs b/ms-auth/src/Network/OAuth2/Internal/Pkce.hs new file mode 100644 index 0000000..6c5383a --- /dev/null +++ b/ms-auth/src/Network/OAuth2/Internal/Pkce.hs @@ -0,0 +1,81 @@ +module Network.OAuth2.Internal.Pkce + ( mkPkceParam, + CodeChallenge (..), + CodeVerifier (..), + CodeChallengeMethod (..), + PkceRequestParam (..), + ) +where + +import Control.Monad.IO.Class +import qualified Crypto.Hash.SHA256 as H +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64.URL as B64 +import Data.Text (Text) +import qualified Data.Text.Encoding as T +import Data.Word +import System.Entropy (getEntropy) + +newtype CodeChallenge = CodeChallenge {unCodeChallenge :: Text} + +newtype CodeVerifier = CodeVerifier {unCodeVerifier :: Text} deriving (Show) + +data CodeChallengeMethod = S256 + deriving (Show) + +data PkceRequestParam = PkceRequestParam + { codeVerifier :: CodeVerifier, + codeChallenge :: CodeChallenge, + -- | spec says optional but really it shall be s256 or can be omitted? + -- https://datatracker.ietf.org/doc/html/rfc7636#section-4.3 + codeChallengeMethod :: CodeChallengeMethod + } + +mkPkceParam :: MonadIO m => m PkceRequestParam +mkPkceParam = do + codeV <- genCodeVerifier + pure + PkceRequestParam + { codeVerifier = CodeVerifier (T.decodeUtf8 codeV), + codeChallenge = CodeChallenge (encodeCodeVerifier codeV), + codeChallengeMethod = S256 + } + +encodeCodeVerifier :: BS.ByteString -> Text +encodeCodeVerifier = B64.encodeBase64Unpadded . hashSHA256 + +genCodeVerifier :: MonadIO m => m BS.ByteString +genCodeVerifier = liftIO $ getBytesInternal BS.empty + +cvMaxLen :: Int +cvMaxLen = 128 + +-- The default 'getRandomBytes' generates bytes out of unreverved characters scope. +-- code-verifier = 43*128unreserved +-- unreserved = ALPHA / DIGIT / "-" / "." / "_" / "~" +-- ALPHA = %x41-5A / %x61-7A +-- DIGIT = %x30-39 +getBytesInternal :: BS.ByteString -> IO BS.ByteString +getBytesInternal ba + | BS.length ba >= cvMaxLen = pure (BS.take cvMaxLen ba) + | otherwise = do + bs <- getEntropy cvMaxLen + let bsUnreserved = ba `BS.append` BS.filter isUnreversed bs + getBytesInternal bsUnreserved + +hashSHA256 :: BS.ByteString -> BS.ByteString +hashSHA256 = H.hash + +isUnreversed :: Word8 -> Bool +isUnreversed w = w `BS.elem` unreverseBS + +{- +a-z: 97-122 +A-Z: 65-90 +-: 45 +.: 46 +_: 95 +~: 126 +-} +unreverseBS :: BS.ByteString +unreverseBS = BS.pack $ [97 .. 122] ++ [65 .. 90] ++ [45, 46, 95, 126] diff --git a/ms-auth/src/Network/OAuth2/Internal/Types.hs b/ms-auth/src/Network/OAuth2/Internal/Types.hs new file mode 100644 index 0000000..f53a81b --- /dev/null +++ b/ms-auth/src/Network/OAuth2/Internal/Types.hs @@ -0,0 +1,694 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# language RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Network.OAuth2.Internal.Types where + +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Trans.Except (ExceptT) +import Data.Aeson (FromJSON) +import Data.Bifunctor +import Data.ByteString.Lazy.Char8 qualified as BSL +import Data.Kind +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Set (Set) +import Data.Set qualified as Set +import Data.String +import Data.Text.Encoding qualified as T +import Data.Text.Lazy (Text) +import Data.Text.Lazy qualified as TL +import Network.HTTP.Conduit (Manager) +import Network.OAuth.OAuth2 hiding (RefreshToken) +import Network.OAuth.OAuth2 qualified as OAuth2 +import Network.OAuth.OAuth2.TokenRequest qualified as TR +import Network.OAuth2.Internal.Pkce +import Network.OAuth2.Internal.Utils +import URI.ByteString hiding (UserInfo) + +{- NOTE + 1. shall I lift the constrain of all 'a :: GrantTypeFlow' so that user has max customization/flexibility? +-} + +------------------------------------------------------------------------------- + +-- * Grant Type + +------------------------------------------------------------------------------- + +data GrantTypeFlow = AuthorizationCode | ResourceOwnerPassword | ClientCredentials + +------------------------------------------------------------------------------- + +-- * Response Type value + +------------------------------------------------------------------------------- + +class ToResponseTypeValue (a :: GrantTypeFlow) where + toResponseTypeValue :: IsString b => b + +instance ToResponseTypeValue 'AuthorizationCode where + -- https://www.rfc-editor.org/rfc/rfc6749#section-3.1.1 + -- Only support "authorization code" flow + toResponseTypeValue :: IsString b => b + toResponseTypeValue = "code" + +toResponseTypeParam :: forall a b req. (ToResponseTypeValue a, IsString b) => req a -> Map b b +toResponseTypeParam _ = Map.singleton "response_type" (toResponseTypeValue @a) + +------------------------------------------------------------------------------- + +-- * Grant Type value + +------------------------------------------------------------------------------- + +-- | Grant type query parameter has association with 'GrantTypeFlow' but not completely strict. +-- +-- e.g. Both 'AuthorizationCode' and 'ResourceOwnerPassword' flow could support refresh token flow. +data GrantTypeValue = GTAuthorizationCode | GTPassword | GTClientCredentials | GTRefreshToken + deriving (Eq, Show) + +------------------------------------------------------------------------------- + +-- * Scope + +------------------------------------------------------------------------------- + +-- TODO: following data type is not ideal as Idp would have lots of 'Custom Text' +-- +-- @ +-- data Scope = OPENID | PROFILE | EMAIL | OFFLINE_ACCESS | Custom Text +-- @ +-- +-- Would be nice to define Enum for standard Scope, plus allow user to define their own define (per Idp) and plugin somehow. +newtype Scope = Scope {unScope :: Text} + deriving (Show, Eq, Ord) + +instance IsString Scope where + fromString :: String -> Scope + fromString = Scope . TL.pack + +------------------------------------------------------------------------------- + +-- * Credentials + +------------------------------------------------------------------------------- +newtype ClientId = ClientId {unClientId :: Text} + deriving (Show, Eq, IsString) + +newtype ClientSecret = ClientSecret {unClientSecret :: Text} + deriving (Eq, IsString) + +-- | In order to reuse some methods from legacy "Network.OAuth.OAuth2". +-- Will be removed when Experiment module becomes default. +toOAuth2Key :: ClientId -> ClientSecret -> OAuth2 +toOAuth2Key cid csecret = + defaultOAuth2 + { oauth2ClientId = TL.toStrict $ unClientId cid, + oauth2ClientSecret = TL.toStrict $ unClientSecret csecret + } + +newtype RedirectUri = RedirectUri {unRedirectUri :: URI} + deriving (Eq) + +newtype AuthorizeState = AuthorizeState {unAuthorizeState :: Text} + deriving (Eq) + +instance IsString AuthorizeState where + fromString :: String -> AuthorizeState + fromString = AuthorizeState . TL.pack + +newtype Username = Username {unUsername :: Text} + deriving (Eq) + +instance IsString Username where + fromString :: String -> Username + fromString = Username . TL.pack + +newtype Password = Password {unPassword :: Text} + deriving (Eq) + +instance IsString Password where + fromString :: String -> Password + fromString = Password . TL.pack + +------------------------------------------------------------------------------- + +-- * Query parameters + +------------------------------------------------------------------------------- +class ToQueryParam a where + toQueryParam :: a -> Map Text Text + +instance ToQueryParam a => ToQueryParam (Maybe a) where + toQueryParam :: ToQueryParam a => Maybe a -> Map Text Text + toQueryParam Nothing = Map.empty + toQueryParam (Just a) = toQueryParam a + +instance ToQueryParam GrantTypeValue where + toQueryParam :: GrantTypeValue -> Map Text Text + toQueryParam x = Map.singleton "grant_type" (val x) + where + val :: GrantTypeValue -> Text + val GTAuthorizationCode = "authorization_code" + val GTPassword = "password" + val GTClientCredentials = "client_credentials" + val GTRefreshToken = "refresh_token" + +instance ToQueryParam ClientId where + toQueryParam :: ClientId -> Map Text Text + toQueryParam (ClientId i) = Map.singleton "client_id" i + +instance ToQueryParam ClientSecret where + toQueryParam :: ClientSecret -> Map Text Text + toQueryParam (ClientSecret x) = Map.singleton "client_secret" x + +instance ToQueryParam Username where + toQueryParam :: Username -> Map Text Text + toQueryParam (Username x) = Map.singleton "username" x + +instance ToQueryParam Password where + toQueryParam :: Password -> Map Text Text + toQueryParam (Password x) = Map.singleton "password" x + +instance ToQueryParam AuthorizeState where + toQueryParam :: AuthorizeState -> Map Text Text + toQueryParam (AuthorizeState x) = Map.singleton "state" x + +instance ToQueryParam RedirectUri where + toQueryParam (RedirectUri uri) = Map.singleton "redirect_uri" (bs8ToLazyText $ serializeURIRef' uri) + +instance ToQueryParam (Set Scope) where + toQueryParam :: Set Scope -> Map Text Text + toQueryParam = toScopeParam . Set.map unScope + where + toScopeParam :: (IsString a) => Set Text -> Map a Text + toScopeParam scope = Map.singleton "scope" (TL.intercalate " " $ Set.toList scope) + +instance ToQueryParam CodeVerifier where + toQueryParam :: CodeVerifier -> Map Text Text + toQueryParam (CodeVerifier x) = Map.singleton "code_verifier" (TL.fromStrict x) + +instance ToQueryParam CodeChallenge where + toQueryParam :: CodeChallenge -> Map Text Text + toQueryParam (CodeChallenge x) = Map.singleton "code_challenge" (TL.fromStrict x) + +instance ToQueryParam CodeChallengeMethod where + toQueryParam :: CodeChallengeMethod -> Map Text Text + toQueryParam x = Map.singleton "code_challenge_method" (TL.pack $ show x) + +instance ToQueryParam ExchangeToken where + toQueryParam :: ExchangeToken -> Map Text Text + toQueryParam (ExchangeToken x) = Map.singleton "code" (TL.fromStrict x) + +instance ToQueryParam OAuth2.RefreshToken where + toQueryParam :: OAuth2.RefreshToken -> Map Text Text + toQueryParam (OAuth2.RefreshToken x) = Map.singleton "refresh_token" (TL.fromStrict x) + +------------------------------------------------------------------------------- + +-- * Authorization and Token Requests types + +------------------------------------------------------------------------------- + +class HasIdpAppName (a :: GrantTypeFlow) where + getIdpAppName :: IdpApplication a i -> Text + +class HasAuthorizeRequest (a :: GrantTypeFlow) where + data AuthorizationRequest a + type MkAuthorizationRequestResponse a + mkAuthorizeRequestParameter :: IdpApplication a i -> AuthorizationRequest a + mkAuthorizeRequest :: IdpApplication a i -> MkAuthorizationRequestResponse a + +class HasTokenRequest (a :: GrantTypeFlow) where + -- | Each GrantTypeFlow has slightly different request parameter to /token endpoint. + data TokenRequest a + + -- | Only 'AuthorizationCode flow (but not resource owner password nor client credentials) will use 'ExchangeToken' in the token request + -- create type family to be explicit on it. + -- with 'type instance WithExchangeToken a b = b' implies no exchange token + -- v.s. 'type instance WithExchangeToken a b = ExchangeToken -> b' implies needing an exchange token + type WithExchangeToken a b + + mkTokenRequest :: + IdpApplication a i -> + WithExchangeToken a (TokenRequest a) + + conduitTokenRequest :: + (MonadIO m) => + IdpApplication a i -> + Manager -> + WithExchangeToken a (ExceptT (OAuth2Error TR.Errors) m OAuth2Token) + +class HasPkceAuthorizeRequest (a :: GrantTypeFlow) where + mkPkceAuthorizeRequest :: MonadIO m => IdpApplication a i -> m (TL.Text, CodeVerifier) + +class HasPkceTokenRequest (b :: GrantTypeFlow) where + conduitPkceTokenRequest :: + (MonadIO m) => + IdpApplication b i -> + Manager -> + (ExchangeToken, CodeVerifier) -> + ExceptT (OAuth2Error TR.Errors) m OAuth2Token + +class HasRefreshTokenRequest (a :: GrantTypeFlow) where + -- | https://www.rfc-editor.org/rfc/rfc6749#page-47 + data RefreshTokenRequest a + + mkRefreshTokenRequest :: IdpApplication a i -> OAuth2.RefreshToken -> RefreshTokenRequest a + conduitRefreshTokenRequest :: + (MonadIO m) => + IdpApplication a i -> + Manager -> + OAuth2.RefreshToken -> + ExceptT (OAuth2Error TR.Errors) m OAuth2Token + +------------------------------------------------------------------------------- + +-- * User Info types + +------------------------------------------------------------------------------- + +type family IdpUserInfo a + +class HasUserInfoRequest (a :: GrantTypeFlow) where + conduitUserInfoRequest :: + FromJSON (IdpUserInfo i) => + IdpApplication a i -> + Manager -> + AccessToken -> + ExceptT BSL.ByteString IO (IdpUserInfo i) + +------------------------------------------------------------------------------- + +-- * Idp App + +------------------------------------------------------------------------------- + +-- | Shall IdpApplication has a field of 'Idp a'?? +data Idp a = Idp + { idpUserInfoEndpoint :: URI, + -- NOTE: maybe worth data type to distinguish authorize and token endpoint + -- as I made mistake at passing to Authorize and Token Request + idpAuthorizeEndpoint :: URI, + idpTokenEndpoint :: URI, + idpFetchUserInfo :: + forall m. + (FromJSON (IdpUserInfo a), MonadIO m) => + Manager -> + AccessToken -> + URI -> + ExceptT BSL.ByteString m (IdpUserInfo a) + } + +------------------------------------------------------------------------------- + +-- * Idp App Config + +------------------------------------------------------------------------------- + +data family IdpApplication (a :: GrantTypeFlow) (i :: Type) + +------------------------------------------------------------------------------- + +-- * Authorization Code flow + +------------------------------------------------------------------------------- + +-- | An Application that supports "Authorization code" flow +data instance IdpApplication 'AuthorizationCode i = AuthorizationCodeIdpApplication + { idpAppName :: Text, + idpAppClientId :: ClientId, + idpAppClientSecret :: ClientSecret, + idpAppScope :: Set Scope, + idpAppRedirectUri :: URI, + idpAppAuthorizeState :: AuthorizeState, + -- | Though technically one key can have multiple value in query, but who actually does it?! + idpAppAuthorizeExtraParams :: Map Text Text, + idpAppTokenRequestAuthenticationMethod :: ClientAuthenticationMethod, + idp :: Idp i + } + +-- NOTE: maybe add function for parase authorization response +-- though seems overkill. https://github.com/freizl/hoauth2/issues/149 +-- parseAuthorizationResponse :: String -> AuthorizationResponse +-- parseAuthorizationResponse :: ( String, String ) -> AuthorizationResponse + +instance HasIdpAppName 'AuthorizationCode where + getIdpAppName :: IdpApplication 'AuthorizationCode i -> Text + getIdpAppName AuthorizationCodeIdpApplication {..} = idpAppName + +instance HasAuthorizeRequest 'AuthorizationCode where + -- \| https://www.rfc-editor.org/rfc/rfc6749#section-4.1.1 + data AuthorizationRequest 'AuthorizationCode = AuthorizationCodeAuthorizationRequest + { scope :: Set Scope, + state :: AuthorizeState, + clientId :: ClientId, + redirectUri :: Maybe RedirectUri + } + type MkAuthorizationRequestResponse 'AuthorizationCode = Text + + mkAuthorizeRequestParameter :: IdpApplication 'AuthorizationCode i -> AuthorizationRequest 'AuthorizationCode + mkAuthorizeRequestParameter AuthorizationCodeIdpApplication {..} = + AuthorizationCodeAuthorizationRequest + { scope = if null idpAppScope then Set.empty else idpAppScope, + state = idpAppAuthorizeState, + clientId = idpAppClientId, + redirectUri = Just (RedirectUri idpAppRedirectUri) + } + + mkAuthorizeRequest :: IdpApplication 'AuthorizationCode i -> Text + mkAuthorizeRequest idpAppConfig@AuthorizationCodeIdpApplication {..} = + let req = mkAuthorizeRequestParameter idpAppConfig + allParams = + map (bimap tlToBS tlToBS) $ + Map.toList $ + Map.unions [idpAppAuthorizeExtraParams, toQueryParam req] + in TL.fromStrict $ + T.decodeUtf8 $ + serializeURIRef' $ + appendQueryParams allParams $ + idpAuthorizeEndpoint idp + +instance HasTokenRequest 'AuthorizationCode where + -- \| https://www.rfc-editor.org/rfc/rfc6749#section-4.1.3 + data TokenRequest 'AuthorizationCode = AuthorizationCodeTokenRequest + { code :: ExchangeToken, + clientId :: ClientId, + grantType :: GrantTypeValue, + redirectUri :: RedirectUri + } + type WithExchangeToken 'AuthorizationCode a = ExchangeToken -> a + + mkTokenRequest :: + IdpApplication 'AuthorizationCode i -> + ExchangeToken -> + TokenRequest 'AuthorizationCode + mkTokenRequest AuthorizationCodeIdpApplication {..} authCode = + AuthorizationCodeTokenRequest + { code = authCode, + clientId = idpAppClientId, + grantType = GTAuthorizationCode, + redirectUri = RedirectUri idpAppRedirectUri + } + conduitTokenRequest :: + forall m i. + (MonadIO m) => + IdpApplication 'AuthorizationCode i -> + Manager -> + ExchangeToken -> + ExceptT (OAuth2Error TR.Errors) m OAuth2Token + conduitTokenRequest idpAppConfig@AuthorizationCodeIdpApplication {..} mgr exchangeToken = + let req = mkTokenRequest idpAppConfig exchangeToken + key = toOAuth2Key idpAppClientId idpAppClientSecret + body = + mapsToParams + [ toQueryParam req, + toQueryParam + ( if idpAppTokenRequestAuthenticationMethod == ClientSecretPost + then Just idpAppClientSecret + else Nothing + ) + ] + in doJSONPostRequest mgr key (idpTokenEndpoint idp) body + +instance HasPkceAuthorizeRequest 'AuthorizationCode where + mkPkceAuthorizeRequest :: MonadIO m => IdpApplication 'AuthorizationCode i -> m (Text, CodeVerifier) + mkPkceAuthorizeRequest idpAppConfig@AuthorizationCodeIdpApplication {..} = do + PkceRequestParam {..} <- mkPkceParam + let req = mkAuthorizeRequestParameter idpAppConfig + let allParams = + mapsToParams + [ idpAppAuthorizeExtraParams, + toQueryParam req, + toQueryParam codeChallenge, + toQueryParam codeChallengeMethod + ] + + let url = + TL.fromStrict $ + T.decodeUtf8 $ + serializeURIRef' $ + appendQueryParams allParams $ + idpAuthorizeEndpoint idp + pure (url, codeVerifier) + +instance HasPkceTokenRequest 'AuthorizationCode where + conduitPkceTokenRequest :: + MonadIO m => + IdpApplication 'AuthorizationCode i -> + Manager -> + (ExchangeToken, CodeVerifier) -> + ExceptT (OAuth2Error TR.Errors) m OAuth2Token + conduitPkceTokenRequest idpAppConfig@AuthorizationCodeIdpApplication {..} mgr (exchangeToken, codeVerifier) = + let req = mkTokenRequest idpAppConfig exchangeToken + key = toOAuth2Key idpAppClientId idpAppClientSecret + body = + mapsToParams + [ toQueryParam req, + toQueryParam codeVerifier, + toQueryParam (if idpAppTokenRequestAuthenticationMethod == ClientSecretPost then Just idpAppClientSecret else Nothing) + ] + in doJSONPostRequest mgr key (idpTokenEndpoint idp) body + +instance HasRefreshTokenRequest 'AuthorizationCode where + data RefreshTokenRequest 'AuthorizationCode = AuthorizationCodeTokenRefreshRequest + { refreshToken :: OAuth2.RefreshToken, + grantType :: GrantTypeValue, + scope :: Set Scope + } + + mkRefreshTokenRequest :: IdpApplication 'AuthorizationCode i -> OAuth2.RefreshToken -> RefreshTokenRequest 'AuthorizationCode + mkRefreshTokenRequest AuthorizationCodeIdpApplication {..} rt = + AuthorizationCodeTokenRefreshRequest + { scope = idpAppScope, + grantType = GTRefreshToken, + refreshToken = rt + } + conduitRefreshTokenRequest :: + (MonadIO m) => + IdpApplication 'AuthorizationCode i -> + Manager -> + OAuth2.RefreshToken -> + ExceptT (OAuth2Error TR.Errors) m OAuth2Token + conduitRefreshTokenRequest idpAppConfig@AuthorizationCodeIdpApplication {..} mgr rt = + let req = mkRefreshTokenRequest idpAppConfig rt + key = toOAuth2Key idpAppClientId idpAppClientSecret + body = + mapsToParams + [ toQueryParam req, + toQueryParam (if idpAppTokenRequestAuthenticationMethod == ClientSecretPost then Just idpAppClientSecret else Nothing) + ] + in doJSONPostRequest mgr key (idpTokenEndpoint idp) body + +instance HasUserInfoRequest 'AuthorizationCode where + conduitUserInfoRequest :: + FromJSON (IdpUserInfo i) => + IdpApplication 'AuthorizationCode i -> + Manager -> + AccessToken -> + ExceptT BSL.ByteString IO (IdpUserInfo i) + conduitUserInfoRequest AuthorizationCodeIdpApplication {..} mgr at = do + idpFetchUserInfo idp mgr at (idpUserInfoEndpoint idp) + +instance ToQueryParam (AuthorizationRequest 'AuthorizationCode) where + toQueryParam :: AuthorizationRequest 'AuthorizationCode -> Map Text Text + toQueryParam req@AuthorizationCodeAuthorizationRequest {..} = + Map.unions + [ toResponseTypeParam req, + toQueryParam scope, + toQueryParam clientId, + toQueryParam state, + toQueryParam redirectUri + ] + +instance ToQueryParam (TokenRequest 'AuthorizationCode) where + toQueryParam :: TokenRequest 'AuthorizationCode -> Map Text Text + toQueryParam AuthorizationCodeTokenRequest {..} = + Map.unions + [ toQueryParam grantType, + toQueryParam code, + toQueryParam redirectUri + ] + +instance ToQueryParam (RefreshTokenRequest 'AuthorizationCode) where + toQueryParam :: RefreshTokenRequest 'AuthorizationCode -> Map Text Text + toQueryParam AuthorizationCodeTokenRefreshRequest {..} = + Map.unions + [ toQueryParam grantType, + toQueryParam scope, + toQueryParam refreshToken + ] + +------------------------------------------------------------------------------- + +-- * Password flow + +------------------------------------------------------------------------------- + +-- https://www.rfc-editor.org/rfc/rfc6749#section-4.3.1 +-- 4.3.1. Authorization Request and Response (Password grant type) +-- The method through which the client obtains the resource owner +-- credentials is beyond the scope of this specification. The client +-- MUST discard the credentials once an access token has been obtained. +-- +-- Hence no AuhorizationRequest instance + +data instance IdpApplication 'ResourceOwnerPassword i = ResourceOwnerPasswordIDPAppConfig + { idpAppClientId :: ClientId, + idpAppClientSecret :: ClientSecret, + idpAppName :: Text, + idpAppScope :: Set Scope, + idpAppUserName :: Username, + idpAppPassword :: Password, + -- | Any parameter that required by your Idp and not mentioned in the OAuth2 spec + idpAppTokenRequestExtraParams :: Map Text Text, + idp :: Idp i + } + +instance HasIdpAppName 'ResourceOwnerPassword where + getIdpAppName :: IdpApplication 'ResourceOwnerPassword i -> Text + getIdpAppName ResourceOwnerPasswordIDPAppConfig {..} = idpAppName + +instance HasUserInfoRequest 'ResourceOwnerPassword where + conduitUserInfoRequest ResourceOwnerPasswordIDPAppConfig {..} mgr at = do + idpFetchUserInfo idp mgr at (idpUserInfoEndpoint idp) + +instance HasTokenRequest 'ResourceOwnerPassword where + -- \| https://www.rfc-editor.org/rfc/rfc6749#section-4.3.2 + data TokenRequest 'ResourceOwnerPassword = PasswordTokenRequest + { scope :: Set Scope, + username :: Username, + password :: Password, + grantType :: GrantTypeValue + } + type WithExchangeToken 'ResourceOwnerPassword a = a + + mkTokenRequest :: IdpApplication 'ResourceOwnerPassword i -> TokenRequest 'ResourceOwnerPassword + mkTokenRequest ResourceOwnerPasswordIDPAppConfig {..} = + PasswordTokenRequest + { username = idpAppUserName, + password = idpAppPassword, + grantType = GTPassword, + scope = idpAppScope + } + + conduitTokenRequest :: + (MonadIO m) => + IdpApplication 'ResourceOwnerPassword i -> + Manager -> + ExceptT (OAuth2Error TR.Errors) m OAuth2Token + conduitTokenRequest idpAppConfig@ResourceOwnerPasswordIDPAppConfig {..} mgr = + let req = mkTokenRequest idpAppConfig + key = toOAuth2Key idpAppClientId idpAppClientSecret + body = mapsToParams [idpAppTokenRequestExtraParams, toQueryParam req] + in doJSONPostRequest mgr key (idpTokenEndpoint idp) body + +-- | TODO: TBD +instance HasRefreshTokenRequest 'ResourceOwnerPassword where + data RefreshTokenRequest 'ResourceOwnerPassword = PasswordRefreshTokenRequest + + mkRefreshTokenRequest :: + IdpApplication 'ResourceOwnerPassword i -> + OAuth2.RefreshToken -> + RefreshTokenRequest 'ResourceOwnerPassword + mkRefreshTokenRequest = undefined + + conduitRefreshTokenRequest :: + MonadIO m => + IdpApplication 'ResourceOwnerPassword i -> + Manager -> + OAuth2.RefreshToken -> + ExceptT (OAuth2Error TR.Errors) m OAuth2Token + conduitRefreshTokenRequest = undefined + +instance ToQueryParam (TokenRequest 'ResourceOwnerPassword) where + toQueryParam :: TokenRequest 'ResourceOwnerPassword -> Map Text Text + toQueryParam PasswordTokenRequest {..} = + Map.unions + [ toQueryParam grantType, + toQueryParam scope, + toQueryParam username, + toQueryParam password + ] + +------------------------------------------------------------------------------- + +-- * Client Credentials flow + +------------------------------------------------------------------------------- + +-- https://www.rfc-editor.org/rfc/rfc6749#section-4.4.1 +-- 4.4.1. Authorization Request and Response (Client Credentials grant type) +-- Since the client authentication is used as the authorization grant, +-- no additional authorization request is needed. +-- +-- Hence no AuhorizationRequest instance + +data instance IdpApplication 'ClientCredentials i = ClientCredentialsIDPAppConfig + { idpAppClientId :: ClientId, + idpAppClientSecret :: ClientSecret, + idpAppName :: Text, + idpAppScope :: Set Scope, + -- | Any parameter that required by your Idp and not mentioned in the OAuth2 spec + idpAppTokenRequestExtraParams :: Map Text Text, + idp :: Idp i + } + +instance HasIdpAppName 'ClientCredentials where + getIdpAppName :: IdpApplication 'ClientCredentials i -> Text + getIdpAppName ClientCredentialsIDPAppConfig {..} = idpAppName + +instance HasTokenRequest 'ClientCredentials where + -- \| https://www.rfc-editor.org/rfc/rfc6749#section-4.4.2 + data TokenRequest 'ClientCredentials = ClientCredentialsTokenRequest + { scope :: Set Scope, + grantType :: GrantTypeValue + } + + type WithExchangeToken 'ClientCredentials a = a + + mkTokenRequest :: IdpApplication 'ClientCredentials i -> TokenRequest 'ClientCredentials + mkTokenRequest ClientCredentialsIDPAppConfig {..} = + ClientCredentialsTokenRequest + { scope = idpAppScope, + grantType = GTClientCredentials + } + + conduitTokenRequest :: + (MonadIO m) => + IdpApplication 'ClientCredentials i -> + Manager -> + ExceptT (OAuth2Error TR.Errors) m OAuth2Token + conduitTokenRequest idpAppConfig@ClientCredentialsIDPAppConfig {..} mgr = + let req = mkTokenRequest idpAppConfig + key = + toOAuth2Key + idpAppClientId + idpAppClientSecret + body = + mapsToParams + [ idpAppTokenRequestExtraParams, + toQueryParam req + ] + in doJSONPostRequest mgr key (idpTokenEndpoint idp) body + +instance ToQueryParam (TokenRequest 'ClientCredentials) where + toQueryParam :: TokenRequest 'ClientCredentials -> Map Text Text + toQueryParam ClientCredentialsTokenRequest {..} = + Map.unions + [ toQueryParam grantType, + toQueryParam scope + ] diff --git a/ms-auth/src/Network/OAuth2/Internal/Utils.hs b/ms-auth/src/Network/OAuth2/Internal/Utils.hs new file mode 100644 index 0000000..3625f69 --- /dev/null +++ b/ms-auth/src/Network/OAuth2/Internal/Utils.hs @@ -0,0 +1,21 @@ +module Network.OAuth2.Internal.Utils where + +import Data.Bifunctor +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS8 +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import qualified Data.Text.Encoding as TE +import qualified Data.Text.Lazy as TL + +tlToBS :: TL.Text -> ByteString +tlToBS = TE.encodeUtf8 . TL.toStrict + +bs8ToLazyText :: BS8.ByteString -> TL.Text +bs8ToLazyText = TL.pack . BS8.unpack + +mapsToParams :: [Map TL.Text TL.Text] -> [(ByteString, ByteString)] +mapsToParams = + map (bimap tlToBS tlToBS) + . Map.toList + . Map.unions diff --git a/ms-auth/src/Network/OAuth2/Provider/AzureAD.hs b/ms-auth/src/Network/OAuth2/Provider/AzureAD.hs index 88e0b1f..4953029 100644 --- a/ms-auth/src/Network/OAuth2/Provider/AzureAD.hs +++ b/ms-auth/src/Network/OAuth2/Provider/AzureAD.hs @@ -41,7 +41,7 @@ import qualified Data.Map.Strict as Map import qualified Data.Set as Set -- hoauth2 import Network.OAuth.OAuth2 (ClientAuthenticationMethod(..), authGetJSON) -import Network.OAuth2.Experiment (IdpApplication(..), Idp(..), IdpUserInfo, GrantTypeFlow(..), ClientId(..), ClientSecret(..), Scope, AuthorizeState) +import Network.OAuth2.Internal.Types (IdpApplication(..), Idp(..), IdpUserInfo, GrantTypeFlow(..), ClientId(..), ClientSecret(..), Scope, AuthorizeState) -- text import qualified Data.Text as T (Text) import qualified Data.Text.Lazy as TL (Text, pack) diff --git a/ms-auth/src/Network/OAuth2/Provider/AzureAD/SAS.hs b/ms-auth/src/Network/OAuth2/Provider/AzureAD/SAS.hs new file mode 100644 index 0000000..21db7e4 --- /dev/null +++ b/ms-auth/src/Network/OAuth2/Provider/AzureAD/SAS.hs @@ -0,0 +1,3 @@ +module Network.OAuth2.Provider.AzureAD.SAS where + +-- | Shared Access Signature authentication for Storage diff --git a/ms-auth/src/Network/OAuth2/Provider/AzureAD/SharedKey.hs b/ms-auth/src/Network/OAuth2/Provider/AzureAD/SharedKey.hs new file mode 100644 index 0000000..b7a227d --- /dev/null +++ b/ms-auth/src/Network/OAuth2/Provider/AzureAD/SharedKey.hs @@ -0,0 +1,137 @@ +{-# language OverloadedStrings #-} +{-# options_ghc -Wno-unused-imports #-} +module Network.OAuth2.Provider.AzureAD.SharedKey where + +import Data.Function ((&)) +import Data.List (sortOn, intersperse) +import Data.String (IsString(..)) + +-- base64 +import qualified Data.ByteString.Base64 as B64 (encodeBase64, decodeBase64) +-- bytestring +import qualified Data.ByteString as BS (ByteString) +import qualified Data.ByteString.Char8 as BS (pack) +import qualified Data.ByteString.Lazy as LBS (ByteString) +-- cryptohash-sha256 +import qualified Crypto.Hash.SHA256 as H (hmac) +-- http-conduit +import Network.HTTP.Simple (Request, Response, httpBS, httpLBS, defaultRequest, setRequestHost, setRequestPath, setRequestSecure, setRequestMethod, setRequestHeader, setRequestBodySource, setRequestBodyLBS, getResponseStatus, getResponseBody) +-- http-types +import Network.HTTP.Types (RequestHeaders, Header, HeaderName) +-- text +import qualified Data.Text as T (Text, pack, unpack) +import qualified Data.Text.Encoding as T (encodeUtf8, decodeUtf8) +-- time +import Data.Time.Clock (getCurrentTime) +import Data.Time.Format (formatTime, defaultTimeLocale) + + +-- "Tue, 3 Oct 2023 19:33:08 UTC" +timeString :: IO String +timeString = f <$> getCurrentTime + where + f = formatTime defaultTimeLocale "%a,%e %b %Y %H:%M:%S %Z" + +xMsDate :: IO (String, String) +xMsDate = ("x-ms-date", ) <$> timeString +canonicalizeHeaders :: [(String, String)] -> [T.Text] +canonicalizeHeaders = map canonicalizeHdr . sortOn fst + where + canonicalizeHdr (k, v) = T.pack $ k <> ":" <> v + +data RESTVerb = GET | POST | PUT deriving (Show) + +data ToSignLite = ToSignLite { + tslVerb :: RESTVerb -- ^ REST verb + , tslContentType :: T.Text -- ^ MIME content type + , tslCanHeaders :: [(String, String)] + , tslOwner :: T.Text -- ^ owner of the storage account + , tslPath :: T.Text -- ^ resource path + } + +toSign :: ToSignLite -> IO T.Text +toSign (ToSignLite v cty hs o pth) = do + xms <- xMsDate + let + hs' = xms : hs + res = canonicalizedResource o pth + appendNewline x = x <> "\n" + str = mconcat (map appendNewline ([ T.pack (show v), "", cty, ""] <> canonicalizeHeaders hs') <> [res]) + pure str + +signed :: ToSignLite + -> BS.ByteString -- ^ shared key (from Azure portal) + -> IO T.Text +signed (ToSignLite v ty hs owner pth) key = do + t <- toSign (ToSignLite v ty hs owner pth) + case B64.decodeBase64 key of + Left e -> error $ T.unpack e + Right dkey -> do + let + s = H.hmac dkey (T.encodeUtf8 t) + pure $ B64.encodeBase64 s + + +test0 :: IO (Response LBS.ByteString) +test0 = do + let + tsl = ToSignLite GET "text/plain" [] "BG-GOT" "/README.md" + k = error "the key to the storage account can be found in the Azure Portal" + r <- createRequest tsl "weuflowsightsa" "irisity-april4-2023-delivery" k + httpLBS r + +createRequest :: ToSignLite + -> String -- ^ storage account name + -> String -- ^ fileshare name + -> BS.ByteString -- ^ key + -> IO Request +createRequest tsl acct share k = do + s <- signed tsl k + let + meth = BS.pack (show $ tslVerb tsl) + host = BS.pack $ "https://" <> acct <> ".file.core.windows.net/" <> share + p = T.encodeUtf8 $ tslPath tsl + pure (defaultRequest & + setRequestMethod meth & + setRequestHost host & + setRequestPath p & + setRequestSecure True & + setRequestHeader "Authorization" ["SharedKeyLite " <> BS.pack acct <> ":" <> T.encodeUtf8 s] + ) + +-- | Shared Key Lite authentication for Storage (Blob, Queue and File services) +--- https://learn.microsoft.com/en-us/rest/api/storageservices/authorize-with-shared-key#blob-queue-and-file-services-shared-key-lite-authorization + +-- StringToSign = VERB + "\n" + +-- Content-MD5 + "\n" + +-- Content-Type + "\n" + +-- Date + "\n" + +-- CanonicalizedHeaders + +-- CanonicalizedResource; + +-- Construct the CanonicalizedResource string in this format as follows (https://learn.microsoft.com/en-us/rest/api/storageservices/authorize-with-shared-key#shared-key-lite-and-table-service-format-for-2009-09-19-and-later): +-- +-- 1.Beginning with an empty string (""), append a forward slash (/), followed by the name of the account that owns the resource being accessed. +-- +-- 2.Append the resource's encoded URI path. If the request URI addresses a component of the resource, append the appropriate query string. The query string should include the question mark and the comp parameter (for example, ?comp=metadata). +canonicalizedResource :: T.Text -> T.Text -> T.Text +canonicalizedResource ownerAcct res = "/" <> ownerAcct <> "/" <> res + +-- example : PUT blob into storage account "myaccount" : +-- +-- PUT\n\ntext/plain; charset=UTF-8\n\nx-ms-date:Sun, 20 Sep 2009 20:36:40 GMT\nx-ms-meta-m1:v1\nx-ms-meta-m2:v2\n/myaccount/mycontainer/hello.txt +-- +-- 1) utf-8 encode StringToSign +-- +-- 2) HMAC-SHA256 sign with base64-decoded Storage Account key accessible from Azure portal +-- +-- 3) base64 encode +-- +-- (steps 1-3 in symbols: +-- +-- Signature=Base64(HMAC-SHA256(UTF8(StringToSign), Base64.decode())) +--) +-- +-- 4) construct the Authorization header, and add the header to the request : +-- +-- Authorization: SharedKeyLite myaccount:ctzMq410TV3wS7upTBcunJTDLEJwMAZuFPfr0mrrA08= diff --git a/ms-auth/src/Network/OAuth2/Session.hs b/ms-auth/src/Network/OAuth2/Session.hs index 43893d8..726977d 100644 --- a/ms-auth/src/Network/OAuth2/Session.hs +++ b/ms-auth/src/Network/OAuth2/Session.hs @@ -62,7 +62,7 @@ import qualified Data.Map as M (Map, insert, lookup, alter, toList) -- import qualified Data.Heap as H (Heap, empty, null, size, insert, viewMin, deleteMin, Entry(..), ) -- hoauth2 import Network.OAuth.OAuth2 (OAuth2Token(..), AccessToken(..), ExchangeToken(..), RefreshToken(..), OAuth2Error(..), IdToken(..)) -import Network.OAuth2.Experiment (IdpUserInfo, conduitUserInfoRequest, mkAuthorizeRequest, conduitTokenRequest, conduitRefreshTokenRequest, HasRefreshTokenRequest(..), WithExchangeToken, IdpApplication(..), GrantTypeFlow(..)) +import Network.OAuth2.Internal.Types (IdpUserInfo, conduitUserInfoRequest, mkAuthorizeRequest, conduitTokenRequest, conduitRefreshTokenRequest, HasRefreshTokenRequest(..), WithExchangeToken, IdpApplication(..), GrantTypeFlow(..)) import Network.OAuth.OAuth2.TokenRequest (Errors) -- http-client import Network.HTTP.Client (Manager, parseRequest, requestHeaders, httpLbs, responseBody, responseStatus) @@ -272,18 +272,17 @@ managedIdentity :: Manager -> String -- ^ Azure resource URI -> ExceptT [String] IO OAuth2Token managedIdentity mgr clid resUri = ExceptT $ do - mih <- lookupEnv "IDENTITY_ENDPOINT" - mie <- lookupEnv "IDENTITY_HEADER" - case (,) <$> mih <*> mie of - Just (idEndpoint, ih) -> do + mie <- lookupEnv "IDENTITY_ENDPOINT" + mih <- lookupEnv "IDENTITY_HEADER" + case (,) <$> mie <*> mih of + Just (idEndpoint, idHeader) -> do let apiVer = "2019-08-01" - xIdentityHeader = ih r <- parseRequest $ mconcat [idEndpoint, "?", kvs [("resource", resUri), ("api-version", apiVer), ("client_id", clid)]] let r' = r { requestHeaders = [ - ("X-IDENTITY-HEADER", BS.pack xIdentityHeader) + ("X-IDENTITY-HEADER", BS.pack idHeader) ] } res <- httpLbs r' mgr