diff --git a/examples/scotty/Main.hs b/examples/scotty/Main.hs --- a/examples/scotty/Main.hs +++ b/examples/scotty/Main.hs @@ -19,7 +19,7 @@ import Data.Tuple (swap) import Network.HTTP.Client (newManager, Manager) import Network.HTTP.Client.TLS (tlsManagerSettings) -import Network.HTTP.Types (badRequest400) +import Network.HTTP.Types (badRequest400, unauthorized401) import Network.Wai.Middleware.RequestLogger (logStdoutDev) import System.Environment (getEnv) import Text.Blaze.Html.Renderer.Text (renderHtml) @@ -27,8 +27,7 @@ import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5.Attributes as A import qualified Web.OIDC.Client as O -import qualified Web.OIDC.Discovery as O -import Web.Scotty (scotty, middleware, get, param, post, redirect, html, status, text) +import Web.Scotty (scotty, middleware, get, param, post, redirect, html, status, text, rescue) import Web.Scotty.Cookie (setSimpleCookie, getCookie) type SessionStateMap = Map Text O.State @@ -45,7 +44,7 @@ ssm <- newIORef M.empty mgr <- newManager tlsManagerSettings prov <- O.discover O.google mgr - let oidc = O.setCredentials clientId clientSecret redirectUri $ O.setProvider prov $ O.newOIDC cprg + let oidc = O.setCredentials clientId clientSecret redirectUri $ O.newOIDC prov run oidc cprg ssm mgr @@ -68,24 +67,30 @@ redirect $ pack . show $ loc get "/callback" $ do - code :: O.Code <- param "code" - state :: O.State <- param "state" - cookie <- getCookie "test-session" - case cookie of - Nothing -> status401 - Just sid -> do - sst <- getStateBy sid - if state == sst - then do - tokens <- liftIO $ O.requestTokens oidc code mgr - blaze $ do - H.h1 "Result" - H.pre . H.toHtml . show . O.claims . O.idToken $ tokens - else status401 + err <- param' "error" + case err of + Just err' -> status401 err' + Nothing -> do + code :: O.Code <- param "code" + state :: O.State <- param "state" + cookie <- getCookie "test-session" + case cookie of + Just sid -> do + sst <- getStateBy sid + if state == sst + then do + tokens <- liftIO $ O.requestTokens oidc code mgr + blaze $ do + H.h1 "Result" + H.pre . H.toHtml . show . O.claims . O.idToken $ tokens + else status400 "state not match" + Nothing -> status400 "cookie not found" where blaze = html . renderHtml - status401 = status badRequest400 >> text "cookie not found" + param' n = (Just <$> param n) `rescue` (\_ -> return Nothing) + status400 m = status badRequest400 >> text m + status401 m = status unauthorized401 >> text m gen = encode <$> atomicModifyIORef' cprg (swap . cprgGenBytes 64) genSessionId = liftIO $ decodeUtf8 <$> gen @@ -96,4 +101,3 @@ case M.lookup sid m of Just st -> return st Nothing -> return "" - diff --git a/oidc-client.cabal b/oidc-client.cabal --- a/oidc-client.cabal +++ b/oidc-client.cabal @@ -1,5 +1,5 @@ name: oidc-client -version: 0.1.0.1 +version: 0.2.0.0 synopsis: OpenID Connect 1.0 library for RP homepage: https://github.com/krdlab/haskell-oidc-client stability: experimental @@ -31,11 +31,15 @@ default-language: Haskell2010 exposed-modules: Web.OIDC.Client - , Web.OIDC.Discovery - , Web.OIDC.Discovery.Issuers + , Web.OIDC.Client.CodeFlow + , Web.OIDC.Client.Discovery + , Web.OIDC.Client.Discovery.Issuers + , Web.OIDC.Client.Discovery.Provider + , Web.OIDC.Client.Settings + , Web.OIDC.Client.Tokens + , Web.OIDC.Client.Types other-modules: Web.OIDC.Client.Internal - , Web.OIDC.Types build-depends: base >=4.7 && <5 , bytestring >=0.10 && <0.11 @@ -46,9 +50,8 @@ , http-client , tls >=1.3.2 , http-client-tls - , jose-jwt >=0.6.2 && <0.7 + , jose-jwt >=0.7 , time - , crypto-random if flag(network-uri) build-depends: network-uri >=2.6, network >=2.6 else @@ -64,6 +67,11 @@ base , hspec , oidc-client + , bytestring + , text + , http-types + , http-client + , http-client-tls executable scotty-example main-is: Main.hs diff --git a/src/Web/OIDC/Client.hs b/src/Web/OIDC/Client.hs --- a/src/Web/OIDC/Client.hs +++ b/src/Web/OIDC/Client.hs @@ -1,233 +1,33 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE GADTs #-} {-| -Module: Web.OIDC.Client -Maintainer: krdlab@gmail.com -Stability: experimental + Module: Web.OIDC.Client + Maintainer: krdlab@gmail.com + Stability: experimental -} module Web.OIDC.Client ( - -- * Client Obtains ID Token and Access Token - OIDC - , newOIDC - , newOIDC' - , setProvider - , setCredentials - , getAuthenticationRequestUrl - , requestTokens + -- * OpenID Connect Discovery + module Web.OIDC.Client.Discovery - -- * Types - , Provider - , Scope, ScopeValue(..) - , Code, State - , Parameters - , Tokens(..), IdToken(..), IdTokenClaims(..) + -- * Settings and Tokens + , OIDC, newOIDC, setCredentials + , module Web.OIDC.Client.Tokens - -- * Exception - , OpenIdException(..) + -- * Authorization Code Flow + , module Web.OIDC.Client.CodeFlow + -- * Types and Exceptions + , module Web.OIDC.Client.Types + -- * Re-exports , module Jose.Jwt ) where -import Control.Applicative ((<$>)) -import Control.Monad (unless) -import Control.Monad.Catch (MonadThrow, throwM, MonadCatch, catch) -import Crypto.Random (CPRG) -import Data.Aeson (decode) -import qualified Data.ByteString.Char8 as B -import Data.ByteString (ByteString) -import Data.IORef (IORef, atomicModifyIORef') -import Data.List (nub) -import Data.Maybe (fromMaybe, fromJust) -import Data.Text (pack) -import Data.Text.Encoding (decodeUtf8) -import Data.Time.Clock.POSIX (getPOSIXTime) -import Data.Tuple (swap) -import qualified Jose.Jwk as Jwk -import Jose.Jwt (Jwt) -import qualified Jose.Jwt as Jwt -import Network.HTTP.Client (parseUrl, getUri, setQueryString, applyBasicAuth, urlEncodedBody, Request(..), Manager, httpLbs, responseBody) -import Network.URI (URI) -import Prelude hiding (exp) - -import qualified Web.OIDC.Client.Internal as I -import qualified Web.OIDC.Types as OT -import Web.OIDC.Types (Provider, Scope, ScopeValue(..), Code, State, Parameters, Tokens(..), IdToken(..), IdTokenClaims(..), OpenIdException(..)) - --- | This data type represents information needed in the OpenID flow. -data OIDC = OIDC - { authorizationSeverUrl :: String - , tokenEndpoint :: String - , clientId :: ByteString - , clientSecret :: ByteString - , redirectUri :: ByteString - , provider :: Provider - , cprgRef :: CPRGRef - } - -data CPRGRef where - Ref :: (CPRG g) => IORef g -> CPRGRef - NoRef :: CPRGRef - -def :: OIDC -def = OIDC - { authorizationSeverUrl = error "You must specify authorizationSeverUrl" - , tokenEndpoint = error "You must specify tokenEndpoint" - , clientId = error "You must specify clientId" - , clientSecret = error "You must specify clientSecret" - , redirectUri = error "You must specify redirectUri" - , provider = error "You must specify provider" - , cprgRef = NoRef - } - --- | Create OIDC. --- --- First argument is used in a token decoding on ID Token Validation. -newOIDC :: CPRG g => IORef g -> OIDC -newOIDC ref = def { cprgRef = Ref ref } - -newOIDC' :: OIDC -newOIDC' = def - -setProvider - :: Provider -- ^ OP's information (obtain by 'discover') - -> OIDC - -> OIDC -setProvider p oidc = - oidc { authorizationSeverUrl = OT.authorizationEndpoint . OT.configuration $ p - , tokenEndpoint = OT.tokenEndpoint . OT.configuration $ p - , provider = p - } - -setCredentials - :: ByteString -- ^ client ID - -> ByteString -- ^ client secret - -> ByteString -- ^ redirect URI - -> OIDC - -> OIDC -setCredentials cid secret redirect oidc = - oidc { clientId = cid - , clientSecret = secret - , redirectUri = redirect - } - -getAuthenticationRequestUrl :: (MonadThrow m, MonadCatch m) => OIDC -> Scope -> Maybe State -> Parameters -> m URI -getAuthenticationRequestUrl oidc scope state params = do - req <- parseUrl endpoint `catch` OT.rethrow - return $ getUri $ setQueryString query req - where - endpoint = authorizationSeverUrl oidc - query = requireds ++ state' ++ params - requireds = - [ ("response_type", Just "code") - , ("client_id", Just $ clientId oidc) - , ("redirect_uri", Just $ redirectUri oidc) - , ("scope", Just $ B.pack . unwords . nub . map show $ OpenId:scope) - ] - state' = - case state of - Just _ -> [("state", state)] - Nothing -> [] - --- TODO: error response - --- | Request and obtain valid tokens. --- --- This function requests ID Token and Access Token to a OP's token endpoint, and validates the received ID Token. --- Returned value is a valid tokens. -requestTokens :: OIDC -> Code -> Manager -> IO Tokens -requestTokens oidc code manager = do - json <- getTokensJson `catch` OT.rethrow - case decode json of - Just ts -> validate oidc ts - Nothing -> error "failed to decode tokens json" -- TODO - where - getTokensJson = do - req <- parseUrl endpoint - let req' = applyBasicAuth cid sec $ urlEncodedBody body $ req { method = "POST" } - res <- httpLbs req' manager - return $ responseBody res - endpoint = tokenEndpoint oidc - cid = clientId oidc - sec = clientSecret oidc - redirect = redirectUri oidc - body = - [ ("grant_type", "authorization_code") - , ("code", code) - , ("redirect_uri", redirect) - ] - -validate :: OIDC -> I.TokensResponse -> IO Tokens -validate oidc tres = do - let jwt' = I.idToken tres - claims' <- validateIdToken oidc jwt' - let tokens = Tokens { - accessToken = I.accessToken tres - , tokenType = I.tokenType tres - , idToken = IdToken { claims = OT.toIdTokenClaims claims', jwt = jwt' } - , expiresIn = I.expiresIn tres - , refreshToken = I.refreshToken tres - } - return tokens - -validateIdToken :: OIDC -> Jwt -> IO Jwt.JwtClaims -validateIdToken oidc jwt' = do - case cprgRef oidc of - Ref crpg -> do - decoded <- case Jwt.decodeClaims (Jwt.unJwt jwt') of - Left cause -> throwM $ JwtExceptoin cause - Right (jwth, _) -> - case jwth of - (Jwt.JwsH jws) -> do - let kid = Jwt.jwsKid jws - alg = Jwt.jwsAlg jws - jwk = getJwk kid (OT.jwkSet . provider $ oidc) - atomicModifyIORef' crpg $ \g -> swap (Jwt.decode g [jwk] (Just $ Jwt.JwsEncoding alg) (Jwt.unJwt jwt')) - (Jwt.JweH jwe) -> do - let kid = Jwt.jweKid jwe - alg = Jwt.jweAlg jwe - enc = Jwt.jweEnc jwe - jwk = getJwk kid (OT.jwkSet . provider $ oidc) - atomicModifyIORef' crpg $ \g -> swap (Jwt.decode g [jwk] (Just $ Jwt.JweEncoding alg enc) (Jwt.unJwt jwt')) - _ -> error "not supported" - case decoded of - Left err -> throwM $ JwtExceptoin err - Right _ -> return () - NoRef -> error "not implemented" -- TODO: request tokeninfo - - claims' <- getClaims - - unless (getIss claims' == issuer') - $ throwM $ ValidationException "issuer" - - unless (clientId' `elem` getAud claims') - $ throwM $ ValidationException "audience" - - expire <- getExp claims' - now <- getCurrentTime - unless (now < expire) - $ throwM $ ValidationException "expire" - - return claims' - where - getJwk kid jwks = head $ case kid of - Just keyId -> filter (eq keyId) jwks - Nothing -> jwks - where - eq e jwk = fromMaybe False ((==) e <$> Jwk.jwkId jwk) - - getClaims = case Jwt.decodeClaims (Jwt.unJwt jwt') of - Right (_, c) -> return c - Left cause -> throwM $ JwtExceptoin cause - - issuer' = pack . OT.issuer . OT.configuration . provider $ oidc - clientId' = decodeUtf8 . clientId $ oidc +import Web.OIDC.Client.CodeFlow +import Web.OIDC.Client.Settings (OIDC, newOIDC, setCredentials) +import Web.OIDC.Client.Discovery +import Web.OIDC.Client.Tokens +import Web.OIDC.Client.Types - getIss c = fromJust (Jwt.jwtIss c) - getAud c = fromJust (Jwt.jwtAud c) - getExp c = case Jwt.jwtExp c of - Just e -> return e - Nothing -> throwM $ ValidationException "exp claim was not found" - getCurrentTime = Jwt.IntDate <$> getPOSIXTime +import Jose.Jwt +{-# ANN module "HLint: ignore Use import/export shortcut" #-} diff --git a/src/Web/OIDC/Client/CodeFlow.hs b/src/Web/OIDC/Client/CodeFlow.hs new file mode 100644 --- /dev/null +++ b/src/Web/OIDC/Client/CodeFlow.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE OverloadedStrings #-} +{-| + Module: Web.OIDC.Client.CodeFlow + Maintainer: krdlab@gmail.com + Stability: experimental +-} +module Web.OIDC.Client.CodeFlow + ( + getAuthenticationRequestUrl + , requestTokens + + -- * For testing + , validateClaims + , getCurrentIntDate + ) where + +import Control.Applicative ((<$>)) +import Control.Monad (unless) +import Control.Monad.Catch (MonadThrow, throwM, MonadCatch, catch) +import Data.Aeson (decode) +import qualified Data.ByteString.Char8 as B +import Data.List (nub) +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8) +import Data.Time.Clock.POSIX (getPOSIXTime) +import Jose.Jwt (Jwt) +import qualified Jose.Jwt as Jwt +import Network.HTTP.Client (getUri, setQueryString, applyBasicAuth, urlEncodedBody, Request(..), Manager, httpLbs, responseBody) +import Network.URI (URI) + +import Web.OIDC.Client.Settings (OIDC(..)) +import qualified Web.OIDC.Client.Discovery.Provider as P +import qualified Web.OIDC.Client.Internal as I +import Web.OIDC.Client.Internal (parseUrl) +import Web.OIDC.Client.Tokens (Tokens(..), IdToken(..)) +import Web.OIDC.Client.Types (Scope, ScopeValue(..), Code, State, Parameters, OpenIdException(..)) + +-- | Make URL for Authorization Request. +getAuthenticationRequestUrl + :: (MonadThrow m, MonadCatch m) + => OIDC + -> Scope -- ^ used to specify what are privileges requested for tokens. (use `ScopeValue`) + -> Maybe State -- ^ used for CSRF mitigation. (recommended parameter) + -> Parameters -- ^ Optional parameters + -> m URI +getAuthenticationRequestUrl oidc scope state params = do + req <- parseUrl endpoint `catch` I.rethrow + return $ getUri $ setQueryString query req + where + endpoint = oidcAuthorizationSeverUrl oidc + query = requireds ++ state' ++ params + requireds = + [ ("response_type", Just "code") + , ("client_id", Just $ oidcClientId oidc) + , ("redirect_uri", Just $ oidcRedirectUri oidc) + , ("scope", Just $ B.pack . unwords . nub . map show $ OpenId:scope) + ] + state' = + case state of + Just _ -> [("state", state)] + Nothing -> [] + +-- TODO: error response + +-- | Request and validate tokens. +-- +-- This function requests ID Token and Access Token to a OP's token endpoint, and validates the received ID Token. +-- Returned `Tokens` value is a valid. +-- +-- If a HTTP error has occurred or a tokens validation has failed, this function throws `OpenIdException`. +requestTokens :: OIDC -> Code -> Manager -> IO Tokens +requestTokens oidc code manager = do + json <- getTokensJson `catch` I.rethrow + case decode json of + Just ts -> validate oidc ts + Nothing -> error "failed to decode tokens json" -- TODO + where + getTokensJson = do + req <- parseUrl endpoint + let req' = applyBasicAuth cid sec $ urlEncodedBody body $ req { method = "POST" } + res <- httpLbs req' manager + return $ responseBody res + endpoint = oidcTokenEndpoint oidc + cid = oidcClientId oidc + sec = oidcClientSecret oidc + redirect = oidcRedirectUri oidc + body = + [ ("grant_type", "authorization_code") + , ("code", code) + , ("redirect_uri", redirect) + ] + +validate :: OIDC -> I.TokensResponse -> IO Tokens +validate oidc tres = do + let jwt' = I.idToken tres + validateIdToken oidc jwt' + claims' <- getClaims jwt' + now <- getCurrentIntDate + validateClaims + (P.issuer . P.configuration . oidcProvider $ oidc) + (decodeUtf8 . oidcClientId $ oidc) + now + claims' + return Tokens { + accessToken = I.accessToken tres + , tokenType = I.tokenType tres + , idToken = IdToken { claims = I.toIdTokenClaims claims', jwt = jwt' } + , expiresIn = I.expiresIn tres + , refreshToken = I.refreshToken tres + } + +validateIdToken :: OIDC -> Jwt -> IO () +validateIdToken oidc jwt' = do + let jwks = P.jwkSet . oidcProvider $ oidc + token = Jwt.unJwt jwt' + decoded <- Jwt.decode jwks Nothing token + case decoded of + Right _ -> return () + Left err -> throwM $ JwtExceptoin err + +getClaims :: MonadThrow m => Jwt -> m Jwt.JwtClaims +getClaims jwt' = case Jwt.decodeClaims (Jwt.unJwt jwt') of + Right (_, c) -> return c + Left cause -> throwM $ JwtExceptoin cause + +validateClaims :: Text -> Text -> Jwt.IntDate -> Jwt.JwtClaims -> IO () +validateClaims issuer' clientId' now claims' = do + iss' <- getIss claims' + unless (iss' == issuer') + $ throwM $ ValidationException "issuer" + + aud' <- getAud claims' + unless (clientId' `elem` aud') + $ throwM $ ValidationException "audience" + + exp' <- getExp claims' + unless (now < exp') + $ throwM $ ValidationException "expire" + where + getIss c = get Jwt.jwtIss c "'iss' claim was not found" + getAud c = get Jwt.jwtAud c "'aud' claim was not found" + getExp c = get Jwt.jwtExp c "'exp' claim was not found" + get f v msg = case f v of + Just v' -> return v' + Nothing -> throwM $ ValidationException msg + +getCurrentIntDate :: IO Jwt.IntDate +getCurrentIntDate = Jwt.IntDate <$> getPOSIXTime diff --git a/src/Web/OIDC/Client/Discovery.hs b/src/Web/OIDC/Client/Discovery.hs new file mode 100644 --- /dev/null +++ b/src/Web/OIDC/Client/Discovery.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE OverloadedStrings #-} +{-| + Module: Web.OIDC.Client.Discovery + Maintainer: krdlab@gmail.com + Stability: experimental +-} +module Web.OIDC.Client.Discovery + ( + discover + + -- * OpenID Provider Issuers + , google + + -- * OpenID Provider Configuration Information + , Provider(..) + , Configuration(..) + ) where + +import Control.Applicative ((<$>)) +import Control.Monad.Catch (throwM, catch) +import Data.Aeson (decode) +import Data.Text (append) +import Data.Maybe (fromMaybe) +import Data.Monoid (mempty) +import qualified Jose.Jwk as Jwk +import Network.HTTP.Client (Manager, httpLbs, responseBody) + +import Web.OIDC.Client.Discovery.Issuers (google) +import Web.OIDC.Client.Discovery.Provider (Provider(..), Configuration(..)) +import Web.OIDC.Client.Internal (rethrow, parseUrl) +import Web.OIDC.Client.Types (IssuerLocation, OpenIdException(..)) + +-- | This function obtains OpenID Provider configuration and JWK set. +discover + :: IssuerLocation -- ^ OpenID Provider's Issuer location + -> Manager + -> IO Provider +discover location manager = do + conf <- getConfiguration `catch` rethrow + case conf of + Just c -> Provider c . jwks <$> getJwkSetJson (jwksUri c) `catch` rethrow + Nothing -> throwM $ DiscoveryException "failed to decode configuration" + where + getConfiguration = do + req <- parseUrl (location `append` "/.well-known/openid-configuration") + res <- httpLbs req manager + return $ decode $ responseBody res + getJwkSetJson url = do + req <- parseUrl url + res <- httpLbs req manager + return $ responseBody res + jwks j = fromMaybe single (Jwk.keys <$> decode j) + where + single = case decode j of + Just k -> return k + Nothing -> mempty diff --git a/src/Web/OIDC/Client/Discovery/Issuers.hs b/src/Web/OIDC/Client/Discovery/Issuers.hs new file mode 100644 --- /dev/null +++ b/src/Web/OIDC/Client/Discovery/Issuers.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE OverloadedStrings #-} +{-| + Module: Web.OIDC.Client.Discovery.Issuers + Maintainer: krdlab@gmail.com + Stability: experimental +-} +module Web.OIDC.Client.Discovery.Issuers + ( + google + -- TODO: other services + ) where + +import Web.OIDC.Client.Types (IssuerLocation) + +google :: IssuerLocation +google = "https://accounts.google.com" diff --git a/src/Web/OIDC/Client/Discovery/Provider.hs b/src/Web/OIDC/Client/Discovery/Provider.hs new file mode 100644 --- /dev/null +++ b/src/Web/OIDC/Client/Discovery/Provider.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE OverloadedStrings #-} +{-| + Module: Web.OIDC.Client.Discovery.Provider + Maintainer: krdlab@gmail.com + Stability: experimental +-} +module Web.OIDC.Client.Discovery.Provider + ( + Provider(..) + , Configuration(..) + ) where + +import Control.Applicative ((<$>), (<*>)) +import Control.Monad (mzero) +import Data.Aeson (FromJSON, parseJSON, Value(..), (.:)) +import Data.Text (Text) +import Jose.Jwk (Jwk) + +import Web.OIDC.Client.Types (ScopeValue, IssuerLocation) + +-- | An OpenID Provider information +data Provider = Provider { configuration :: Configuration, jwkSet :: [Jwk] } + +-- | An OpenID Provider Configuration +data Configuration = Configuration + { issuer :: IssuerLocation + , authorizationEndpoint :: Text + , tokenEndpoint :: Text + , userinfoEndpoint :: Text + , revocationEndpoint :: Text + , jwksUri :: Text + , responseTypesSupported :: [Text] + , subjectTypesSupported :: [Text] + , idTokenSigningAlgValuesSupported :: [Text] + , scopesSupported :: [ScopeValue] + , tokenEndpointAuthMethodsSupported :: [Text] + , claimsSupported :: [Text] + } + deriving (Show, Eq) + +instance FromJSON Configuration where + parseJSON (Object o) = Configuration + <$> o .: "issuer" + <*> o .: "authorization_endpoint" + <*> o .: "token_endpoint" + <*> o .: "userinfo_endpoint" + <*> o .: "revocation_endpoint" + <*> o .: "jwks_uri" + <*> o .: "response_types_supported" + <*> o .: "subject_types_supported" + <*> o .: "id_token_signing_alg_values_supported" + <*> o .: "scopes_supported" + <*> o .: "token_endpoint_auth_methods_supported" + <*> o .: "claims_supported" + parseJSON _ = mzero diff --git a/src/Web/OIDC/Client/Internal.hs b/src/Web/OIDC/Client/Internal.hs --- a/src/Web/OIDC/Client/Internal.hs +++ b/src/Web/OIDC/Client/Internal.hs @@ -1,22 +1,29 @@ {-# LANGUAGE OverloadedStrings #-} {-| -Module: Web.OIDC.Client.Internal -Maintainer: krdlab@gmail.com -Stability: experimental + Module: Web.OIDC.Client.Internal + Maintainer: krdlab@gmail.com + Stability: experimental -} module Web.OIDC.Client.Internal where import Control.Applicative ((<$>), (<*>)) import Control.Monad (mzero) +import Control.Monad.Catch (MonadThrow, throwM, MonadCatch) import Data.Aeson (FromJSON, parseJSON, Value(..), (.:), (.:?)) -import Jose.Jwt (Jwt) +import Data.Maybe (fromJust) +import Data.Text (Text, unpack) +import Jose.Jwt (Jwt, JwtClaims(..)) +import Network.HTTP.Client (HttpException, parseUrl, Request) +import Prelude hiding (exp) +import Web.OIDC.Client.Tokens (IdTokenClaims(..)) +import Web.OIDC.Client.Types (OpenIdException(InternalHttpException)) data TokensResponse = TokensResponse - { accessToken :: !String - , tokenType :: !String - , idToken :: !Jwt - , expiresIn :: !(Maybe Integer) - , refreshToken :: !(Maybe String) + { accessToken :: !Text + , tokenType :: !Text + , idToken :: !Jwt + , expiresIn :: !(Maybe Integer) + , refreshToken :: !(Maybe Text) } deriving (Show, Eq) @@ -28,3 +35,18 @@ <*> o .:? "expires_in" <*> o .:? "refresh_token" parseJSON _ = mzero + +rethrow :: (MonadCatch m) => HttpException -> m a +rethrow = throwM . InternalHttpException + +toIdTokenClaims :: JwtClaims -> IdTokenClaims +toIdTokenClaims c = IdTokenClaims -- FIXME: fromJust + { iss = fromJust (jwtIss c) + , sub = fromJust (jwtSub c) + , aud = fromJust (jwtAud c) + , exp = fromJust (jwtExp c) + , iat = fromJust (jwtIat c) + } + +parseUrl :: MonadThrow m => Text -> m Request +parseUrl = Network.HTTP.Client.parseUrl . unpack diff --git a/src/Web/OIDC/Client/Settings.hs b/src/Web/OIDC/Client/Settings.hs new file mode 100644 --- /dev/null +++ b/src/Web/OIDC/Client/Settings.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE OverloadedStrings #-} +{-| + Module: Web.OIDC.Client.Settings + Maintainer: krdlab@gmail.com + Stability: experimental +-} +module Web.OIDC.Client.Settings + ( + OIDC(..) + , def + , newOIDC + , setCredentials + ) where + +import Data.ByteString (ByteString) +import Data.Text (Text) + +import Web.OIDC.Client.Discovery.Provider (Provider) +import qualified Web.OIDC.Client.Discovery.Provider as P + +-- | This data type represents information needed in the OpenID flow. +data OIDC = OIDC + { oidcAuthorizationSeverUrl :: Text + , oidcTokenEndpoint :: Text + , oidcClientId :: ByteString + , oidcClientSecret :: ByteString + , oidcRedirectUri :: ByteString + , oidcProvider :: Provider + } + +def :: OIDC +def = OIDC + { oidcAuthorizationSeverUrl = error "You must specify authorizationSeverUrl" + , oidcTokenEndpoint = error "You must specify tokenEndpoint" + , oidcClientId = error "You must specify clientId" + , oidcClientSecret = error "You must specify clientSecret" + , oidcRedirectUri = error "You must specify redirectUri" + , oidcProvider = error "You must specify provider" + } + +newOIDC + :: Provider -- ^ OP's information (obtained by 'Web.OIDC.Client.Discovery.discover') + -> OIDC +newOIDC p = + def { oidcAuthorizationSeverUrl = P.authorizationEndpoint . P.configuration $ p + , oidcTokenEndpoint = P.tokenEndpoint . P.configuration $ p + , oidcProvider = p + } + +setCredentials + :: ByteString -- ^ client ID + -> ByteString -- ^ client secret + -> ByteString -- ^ redirect URI (the HTTP endpont on your server that will receive a response from OP) + -> OIDC + -> OIDC +setCredentials cid secret redirect oidc = + oidc { oidcClientId = cid + , oidcClientSecret = secret + , oidcRedirectUri = redirect + } diff --git a/src/Web/OIDC/Client/Tokens.hs b/src/Web/OIDC/Client/Tokens.hs new file mode 100644 --- /dev/null +++ b/src/Web/OIDC/Client/Tokens.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE OverloadedStrings #-} +{-| + Module: Web.OIDC.Client.Tokens + Maintainer: krdlab@gmail.com + Stability: experimental +-} +module Web.OIDC.Client.Tokens + ( + Tokens(..) + , IdToken(..) + , IdTokenClaims(..) + ) where + +import Data.Text (Text) +import Jose.Jwt (Jwt, IntDate) +import Prelude hiding (exp) + +data Tokens = Tokens + { accessToken :: Text + , tokenType :: Text + , idToken :: IdToken + , expiresIn :: Maybe Integer + , refreshToken :: Maybe Text + } + deriving (Show, Eq) + +data IdToken = IdToken + { claims :: IdTokenClaims + , jwt :: Jwt + } + deriving (Show, Eq) + +data IdTokenClaims = IdTokenClaims + { iss :: Text + , sub :: Text + , aud :: [Text] + , exp :: IntDate + , iat :: IntDate + -- TODO: optional + } + deriving (Show, Eq) diff --git a/src/Web/OIDC/Client/Types.hs b/src/Web/OIDC/Client/Types.hs new file mode 100644 --- /dev/null +++ b/src/Web/OIDC/Client/Types.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-| + Module: Web.OIDC.Client.Types + Maintainer: krdlab@gmail.com + Stability: experimental +-} +module Web.OIDC.Client.Types + ( + ScopeValue(..) + , Scope + , State + , Parameters + , Code + , IssuerLocation + , OpenIdException(..) + ) where + +import Control.Applicative ((<*), (*>), (<|>)) +import Control.Exception (Exception) +import Data.Aeson (FromJSON, parseJSON, withText) +import Data.Attoparsec.Text (parseOnly, endOfInput, string) +import Data.ByteString (ByteString) +import Data.List (isPrefixOf) +import Data.Text (Text, pack) +import Data.Typeable (Typeable) +import Jose.Jwt (JwtError) +import Network.HTTP.Client (HttpException) + +type IssuerLocation = Text + +data ScopeValue = + OpenId + | Profile + | Email + | Address + | Phone + | OfflineAccess + deriving (Eq) + +instance Show ScopeValue where + show OpenId = "openid" + show Profile = "profile" + show Email = "email" + show Address = "address" + show Phone = "phone" + show OfflineAccess = "offline_access" + +instance Read ScopeValue where + readsPrec _ s + | "openid" `isPrefixOf` s = [(OpenId, drop 6 s)] + | "profile" `isPrefixOf` s = [(Profile, drop 7 s)] + | "email" `isPrefixOf` s = [(Email, drop 5 s)] + | "address" `isPrefixOf` s = [(Address, drop 7 s)] + | "phone" `isPrefixOf` s = [(Phone, drop 5 s)] + | "offline_access" `isPrefixOf` s = [(OfflineAccess, drop 14 s)] + | otherwise = [] + +instance FromJSON ScopeValue where + parseJSON = withText "ScopeValue" (run parser) + where + run p t = + case parseOnly (p <* endOfInput) t of + Right r -> return r + Left err -> fail $ "could not parse scope value: " ++ err + parser = parser' OpenId + <|> parser' Profile + <|> parser' Email + <|> parser' Address + <|> parser' Phone + <|> parser' OfflineAccess + parser' v = string (pack . show $ v) *> return v + +type Scope = [ScopeValue] + +type State = ByteString + +type Parameters = [(ByteString, Maybe ByteString)] + +type Code = ByteString + +data OpenIdException = + DiscoveryException Text + | InternalHttpException HttpException + | JwtExceptoin JwtError + | ValidationException Text + deriving (Show, Typeable) + +instance Exception OpenIdException diff --git a/src/Web/OIDC/Discovery.hs b/src/Web/OIDC/Discovery.hs deleted file mode 100644 --- a/src/Web/OIDC/Discovery.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-| -Module: Web.OIDC.Discovery -Maintainer: krdlab@gmail.com -Stability: experimental --} -module Web.OIDC.Discovery - ( discover - , IssuerLocation - , Provider - , module I - ) where - -import Control.Applicative ((<$>)) -import Control.Monad.Catch (throwM, catch) -import Data.Aeson (decode) -import Data.Maybe (fromMaybe) -import Data.Monoid (mempty) -import qualified Jose.Jwk as Jwk -import Network.HTTP.Client (Manager, parseUrl, httpLbs, responseBody) -import Web.OIDC.Types -import Web.OIDC.Discovery.Issuers as I - --- | This function obtains OpenID Provider configuration and JWK set. -discover - :: IssuerLocation -- ^ OpenID Provider's Issuer location - -> Manager - -> IO Provider -discover location manager = do - conf <- getConfiguration `catch` rethrow - case conf of - Just c -> Provider c . jwks <$> getJwkSetJson (jwksUri c) `catch` rethrow - Nothing -> throwM $ DiscoveryException "failed to decode configuration" - where - getConfiguration = do - req <- parseUrl (location ++ "/.well-known/openid-configuration") - res <- httpLbs req manager - return $ decode $ responseBody res - getJwkSetJson url = do - req <- parseUrl url - res <- httpLbs req manager - return $ responseBody res - jwks j = fromMaybe single (Jwk.keys <$> decode j) - where - single = case decode j of - Just k -> return k - Nothing -> mempty diff --git a/src/Web/OIDC/Discovery/Issuers.hs b/src/Web/OIDC/Discovery/Issuers.hs deleted file mode 100644 --- a/src/Web/OIDC/Discovery/Issuers.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-| -Module: Web.OIDC.Discovery.Issuers -Maintainer: krdlab@gmail.com -Stability: experimental --} -module Web.OIDC.Discovery.Issuers - ( google - ) where - -import Web.OIDC.Types (IssuerLocation) - -google :: IssuerLocation -google = "https://accounts.google.com" diff --git a/src/Web/OIDC/Types.hs b/src/Web/OIDC/Types.hs deleted file mode 100644 --- a/src/Web/OIDC/Types.hs +++ /dev/null @@ -1,158 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-| -Module: Web.OIDC.Types -Maintainer: krdlab@gmail.com -Stability: experimental --} -module Web.OIDC.Types where - -import Control.Applicative ((<$>), (<*>), (<*), (*>), (<|>)) -import Control.Exception (Exception) -import Control.Monad (mzero) -import Control.Monad.Catch (throwM, MonadCatch) -import Data.Aeson (FromJSON, parseJSON, withText, Value(..), (.:)) -import Data.Attoparsec.Text (parseOnly, endOfInput, string) -import Data.ByteString (ByteString) -import Data.List (isPrefixOf) -import Data.Maybe (fromJust) -import Data.Text (unpack, pack) -import Data.Typeable (Typeable) -import Jose.Jwk (Jwk) -import Jose.Jwt (Jwt, JwtClaims(..), JwtError, IntDate) -import Network.HTTP.Client (HttpException) -import Prelude hiding (exp) - -type IssuerLocation = String - --- | An OpenID Provider information -data Provider = Provider { configuration :: Configuration, jwkSet :: [Jwk] } - --- | An OpenID Provider Configuration -data Configuration = Configuration - { issuer :: IssuerLocation - , authorizationEndpoint :: String - , tokenEndpoint :: String - , userinfoEndpoint :: String - , revocationEndpoint :: String - , jwksUri :: String - , responseTypesSupported :: [String] - , subjectTypesSupported :: [String] - , idTokenSigningAlgValuesSupported :: [String] - , scopesSupported :: [ScopeValue] - , tokenEndpointAuthMethodsSupported :: [String] - , claimsSupported :: [String] - } - deriving (Show, Eq) - -instance FromJSON Configuration where - parseJSON (Object o) = Configuration - <$> o .: "issuer" - <*> o .: "authorization_endpoint" - <*> o .: "token_endpoint" - <*> o .: "userinfo_endpoint" - <*> o .: "revocation_endpoint" - <*> o .: "jwks_uri" - <*> o .: "response_types_supported" - <*> o .: "subject_types_supported" - <*> o .: "id_token_signing_alg_values_supported" - <*> o .: "scopes_supported" - <*> o .: "token_endpoint_auth_methods_supported" - <*> o .: "claims_supported" - parseJSON _ = mzero - -data ScopeValue = - OpenId - | Profile - | Email - | Address - | Phone - | OfflineAccess - deriving (Eq) - -instance Show ScopeValue where - show OpenId = "openid" - show Profile = "profile" - show Email = "email" - show Address = "address" - show Phone = "phone" - show OfflineAccess = "offline_access" - -instance Read ScopeValue where - readsPrec _ s - | "openid" `isPrefixOf` s = [(OpenId, drop 6 s)] - | "profile" `isPrefixOf` s = [(Profile, drop 7 s)] - | "email" `isPrefixOf` s = [(Email, drop 5 s)] - | "address" `isPrefixOf` s = [(Address, drop 7 s)] - | "phone" `isPrefixOf` s = [(Phone, drop 5 s)] - | "offline_access" `isPrefixOf` s = [(OfflineAccess, drop 14 s)] - | otherwise = [] - -instance FromJSON ScopeValue where - parseJSON = withText "ScopeValue" (run parser) - where - run p t = - case parseOnly (p <* endOfInput) t of - Right r -> return r - Left err -> fail $ "could not parse scope value: " ++ err - parser = parser' OpenId - <|> parser' Profile - <|> parser' Email - <|> parser' Address - <|> parser' Phone - <|> parser' OfflineAccess - parser' v = string (pack . show $ v) *> return v - -type Scope = [ScopeValue] - -type State = ByteString - -type Parameters = [(ByteString, Maybe ByteString)] - -type Code = ByteString - -data Tokens = Tokens - { accessToken :: String - , tokenType :: String - , idToken :: IdToken - , expiresIn :: Maybe Integer - , refreshToken :: Maybe String - } - deriving (Show, Eq) - -data IdToken = IdToken - { claims :: IdTokenClaims - , jwt :: Jwt - } - deriving (Show, Eq) - -data IdTokenClaims = IdTokenClaims - { iss :: String - , sub :: String - , aud :: [String] - , exp :: IntDate - , iat :: IntDate - -- TODO: optional - } - deriving (Show, Eq) - -toIdTokenClaims :: JwtClaims -> IdTokenClaims -toIdTokenClaims c = IdTokenClaims - { iss = unpack $ fromJust (jwtIss c) - , sub = unpack $ fromJust (jwtSub c) - , aud = map unpack $ fromJust (jwtAud c) - , exp = fromJust (jwtExp c) - , iat = fromJust (jwtIat c) - } - -data OpenIdException = - DiscoveryException String - | InternalHttpException HttpException - | JwtExceptoin JwtError - | ValidationException String - deriving (Show, Typeable) - -instance Exception OpenIdException - -rethrow :: (MonadCatch m) => HttpException -> m a -rethrow = throwM . InternalHttpException diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,9 +1,5 @@ -{-# LANGUAGE OverloadedStrings #-} - -import Test.Hspec +import Test.Hspec (hspec) +import qualified Spec.Client as Client main :: IO () -main = hspec $ - describe "dummy test" $ - it "dummy" $ - True `shouldBe` True +main = hspec Client.tests