oidc-client 0.1.0.1 → 0.2.0.0

raw patch · 15 files changed

+557/−481 lines, 15 filesdep ~bytestringdep ~jose-jwtdep ~textPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: bytestring, jose-jwt, text

API changes (from Hackage documentation)

Files

• examples/scotty/Main.hs +24/−20
• oidc-client.cabal +14/−6
• src/Web/OIDC/Client.hs +20/−220
• src/Web/OIDC/Client/CodeFlow.hs +148/−0
• src/Web/OIDC/Client/Discovery.hs +56/−0
• src/Web/OIDC/Client/Discovery/Issuers.hs +16/−0
• src/Web/OIDC/Client/Discovery/Provider.hs +55/−0
• src/Web/OIDC/Client/Internal.hs +31/−9
• src/Web/OIDC/Client/Settings.hs +60/−0
• src/Web/OIDC/Client/Tokens.hs +41/−0
• src/Web/OIDC/Client/Types.hs +89/−0
• src/Web/OIDC/Discovery.hs +0/−47
• src/Web/OIDC/Discovery/Issuers.hs +0/−14
• src/Web/OIDC/Types.hs +0/−158
• test/Spec.hs +3/−7

@@ -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 ""-

@@ -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

@@ -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" #-}

@@ -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

@@ -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

@@ -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"

@@ -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

@@ -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

@@ -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+         }

@@ -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)

@@ -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

@@ -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

@@ -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"

@@ -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

@@ -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