diff --git a/examples/scotty/Main.hs b/examples/scotty/Main.hs --- a/examples/scotty/Main.hs +++ b/examples/scotty/Main.hs @@ -3,7 +3,6 @@ module Main where -import Control.Applicative ((<$>)) import Control.Monad.IO.Class (liftIO) import Crypto.Random.AESCtr (makeSystem) import Crypto.Random.API (CPRG, cprgGenBytes) @@ -60,7 +59,7 @@ post "/login" $ do state <- genState - loc <- liftIO $ O.getAuthenticationRequestUrl oidc [O.Email] (Just state) [] + loc <- liftIO $ O.getAuthenticationRequestUrl oidc [O.email] (Just state) [] sid <- genSessionId saveState sid state setSimpleCookie "test-session" sid 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.2.0.0 +version: 0.3.0.0 synopsis: OpenID Connect 1.0 library for RP homepage: https://github.com/krdlab/haskell-oidc-client stability: experimental @@ -29,6 +29,7 @@ library hs-source-dirs: src default-language: Haskell2010 + ghc-options: -Wall exposed-modules: Web.OIDC.Client , Web.OIDC.Client.CodeFlow @@ -44,7 +45,7 @@ base >=4.7 && <5 , bytestring >=0.10 && <0.11 , text >=1.2 && <1.3 - , aeson >=0.9 + , aeson >=0.10 , attoparsec >=0.12 , exceptions , http-client @@ -63,6 +64,8 @@ default-language: Haskell2010 ghc-options: -Wall main-is: Spec.hs + other-modules: + Spec.Client build-depends: base , hspec @@ -75,7 +78,9 @@ executable scotty-example main-is: Main.hs + default-language: Haskell2010 hs-source-dirs: examples/scotty/ + ghc-options: -Wall if flag(build-examples) build-depends: base >=4.7 && <5 diff --git a/src/Web/OIDC/Client/CodeFlow.hs b/src/Web/OIDC/Client/CodeFlow.hs --- a/src/Web/OIDC/Client/CodeFlow.hs +++ b/src/Web/OIDC/Client/CodeFlow.hs @@ -14,18 +14,17 @@ , 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 (Text, unpack) 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.HTTP.Client (getUri, setQueryString, urlEncodedBody, Request(..), Manager, httpLbs, responseBody) import Network.URI (URI) import Web.OIDC.Client.Settings (OIDC(..)) @@ -33,7 +32,7 @@ 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(..)) +import Web.OIDC.Client.Types (Scope, openId, Code, State, Parameters, OpenIdException(..)) -- | Make URL for Authorization Request. getAuthenticationRequestUrl @@ -47,13 +46,13 @@ req <- parseUrl endpoint `catch` I.rethrow return $ getUri $ setQueryString query req where - endpoint = oidcAuthorizationSeverUrl oidc + endpoint = oidcAuthorizationServerUrl 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) + , ("scope", Just $ B.pack . unwords . nub . map unpack $ openId:scope) ] state' = case state of @@ -77,7 +76,7 @@ where getTokensJson = do req <- parseUrl endpoint - let req' = applyBasicAuth cid sec $ urlEncodedBody body $ req { method = "POST" } + let req' = urlEncodedBody body $ req { method = "POST" } res <- httpLbs req' manager return $ responseBody res endpoint = oidcTokenEndpoint oidc @@ -85,9 +84,11 @@ sec = oidcClientSecret oidc redirect = oidcRedirectUri oidc body = - [ ("grant_type", "authorization_code") - , ("code", code) - , ("redirect_uri", redirect) + [ ("grant_type", "authorization_code") + , ("code", code) + , ("client_id", cid) + , ("client_secret", sec) + , ("redirect_uri", redirect) ] validate :: OIDC -> I.TokensResponse -> IO Tokens diff --git a/src/Web/OIDC/Client/Discovery.hs b/src/Web/OIDC/Client/Discovery.hs --- a/src/Web/OIDC/Client/Discovery.hs +++ b/src/Web/OIDC/Client/Discovery.hs @@ -16,12 +16,10 @@ , 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) diff --git a/src/Web/OIDC/Client/Discovery/Provider.hs b/src/Web/OIDC/Client/Discovery/Provider.hs --- a/src/Web/OIDC/Client/Discovery/Provider.hs +++ b/src/Web/OIDC/Client/Discovery/Provider.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} {-| Module: Web.OIDC.Client.Discovery.Provider Maintainer: krdlab@gmail.com @@ -10,9 +11,8 @@ , Configuration(..) ) where -import Control.Applicative ((<$>), (<*>)) -import Control.Monad (mzero) -import Data.Aeson (FromJSON, parseJSON, Value(..), (.:)) +import Data.Aeson.TH (deriveFromJSON, Options(..), defaultOptions) +import Data.Aeson.Types (camelTo2) import Data.Text (Text) import Jose.Jwk (Jwk) @@ -26,30 +26,17 @@ { issuer :: IssuerLocation , authorizationEndpoint :: Text , tokenEndpoint :: Text - , userinfoEndpoint :: Text - , revocationEndpoint :: Text + , userinfoEndpoint :: Maybe Text + , revocationEndpoint :: Maybe Text , jwksUri :: Text , responseTypesSupported :: [Text] , subjectTypesSupported :: [Text] , idTokenSigningAlgValuesSupported :: [Text] - , scopesSupported :: [ScopeValue] - , tokenEndpointAuthMethodsSupported :: [Text] - , claimsSupported :: [Text] + , scopesSupported :: Maybe [ScopeValue] + , tokenEndpointAuthMethodsSupported :: Maybe [Text] + , claimsSupported :: Maybe [Text] } + -- http://openid.net/specs/openid-connect-discovery-1_0.html#ProviderMetadata 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 +$(deriveFromJSON defaultOptions{fieldLabelModifier = camelTo2 '_'} ''Configuration) 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 @@ -6,7 +6,6 @@ -} 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(..), (.:), (.:?)) diff --git a/src/Web/OIDC/Client/Settings.hs b/src/Web/OIDC/Client/Settings.hs --- a/src/Web/OIDC/Client/Settings.hs +++ b/src/Web/OIDC/Client/Settings.hs @@ -20,31 +20,31 @@ -- | 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 + { oidcAuthorizationServerUrl :: 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" + { oidcAuthorizationServerUrl = error "You must specify authorizationServerUrl" + , 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 + def { oidcAuthorizationServerUrl = P.authorizationEndpoint . P.configuration $ p + , oidcTokenEndpoint = P.tokenEndpoint . P.configuration $ p + , oidcProvider = p } setCredentials diff --git a/src/Web/OIDC/Client/Types.hs b/src/Web/OIDC/Client/Types.hs --- a/src/Web/OIDC/Client/Types.hs +++ b/src/Web/OIDC/Client/Types.hs @@ -7,7 +7,8 @@ -} module Web.OIDC.Client.Types ( - ScopeValue(..) + ScopeValue + , openId, profile, email, address, phone, offlineAccess , Scope , State , Parameters @@ -16,60 +17,24 @@ , 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.Text (Text) 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 = [] +type ScopeValue = Text -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 +openId, profile, email, address, phone, offlineAccess :: ScopeValue +openId = "openid" +profile = "profile" +email = "email" +address = "address" +phone = "phone" +offlineAccess = "offline_access" type Scope = [ScopeValue] diff --git a/test/Spec/Client.hs b/test/Spec/Client.hs new file mode 100644 --- /dev/null +++ b/test/Spec/Client.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE OverloadedStrings #-} +module Spec.Client where + +import Data.ByteString (ByteString) +import Data.Text (unpack) +import Data.Text.Encoding (decodeUtf8) +import Network.HTTP.Client (newManager) +import Network.HTTP.Client.TLS (tlsManagerSettings) +import Network.HTTP.Types (urlEncode) +import Test.Hspec (Spec, describe, it, shouldContain, shouldNotContain, shouldThrow) +import Web.OIDC.Client + +clientId, clientSecret, redirectUri, nonce :: ByteString +clientId = "dummy client id" +clientSecret = "dummy client secret" +redirectUri = "http://localhost" +nonce = "dummy nonce" + +tests :: Spec +tests = do + describe "CodeFlow.getAuthenticationRequestUrl" $ do + + it "should return a url that has required parameters" $ do + manager <- newManager tlsManagerSettings + provider <- discover google manager + let oidc = setCredentials clientId clientSecret redirectUri $ newOIDC provider + url <- getAuthenticationRequestUrl oidc [] Nothing [] + show url `shouldContain` "response_type=code" + show url `shouldContain` "scope=openid" + show url `shouldContain` (toES "client_id" ++ "=" ++ toES clientId) + show url `shouldContain` (toES "redirect_uri" ++ "=" ++ toES redirectUri) + show url `shouldNotContain` toES clientSecret + + it "should return a url that has other parameters" $ do + manager <- newManager tlsManagerSettings + provider <- discover google manager + let oidc = setCredentials clientId clientSecret redirectUri $ newOIDC provider + state = "dummy state" + url <- getAuthenticationRequestUrl oidc [email] (Just state) [("nonce", Just nonce)] + show url `shouldContain` (toES "scope" ++ "=" ++ toES "openid email") + show url `shouldContain` (toES "state" ++ "=" ++ toES state) + show url `shouldContain` (toES "nonce" ++ "=" ++ toES nonce) + + describe "CodeFlow.validateClaims" $ do + it "should succeed at a validation of correct claims" $ do + let issuer' = "http://localhost" + clientId' = decodeUtf8 clientId + now <- getCurrentIntDate + let claims' = defClaims { jwtIss = Just issuer' + , jwtAud = Just [clientId'] + , jwtExp = Just (add 10 now) + } + validateClaims issuer' clientId' now claims' + validateClaims issuer' clientId' now (claims' { jwtAud = Just ["other id", clientId'] }) + + it "should throw ValidationException if 'iss' field is invalid" $ do + let issuer' = "http://localhost" + clientId' = decodeUtf8 clientId + now <- getCurrentIntDate + let claims' = defClaims { jwtIss = Just "http://localhost/hoge" + , jwtAud = Just [clientId'] + , jwtExp = Just (add 10 now) + } + validateClaims issuer' clientId' now claims' + `shouldThrow` isValidationException + + it "should throw ValidationException if 'aud' field does not contain Client ID" $ do + let issuer' = "http://localhost" + clientId' = decodeUtf8 clientId + now <- getCurrentIntDate + let claims' = defClaims { jwtIss = Just issuer' + , jwtAud = Just ["other id"] + , jwtExp = Just (add 10 now) + } + validateClaims issuer' clientId' now claims' + `shouldThrow` isValidationException + + it "should throw ValidationException if 'exp' field expired" $ do + let issuer' = "http://localhost" + clientId' = decodeUtf8 clientId + now <- getCurrentIntDate + let claims' = defClaims { jwtIss = Just issuer' + , jwtAud = Just [clientId'] + , jwtExp = Just (add (-1) now) + } + validateClaims issuer' clientId' now claims' + `shouldThrow` isValidationException + + where + toES = unpack . decodeUtf8 . urlEncode True + defClaims = JwtClaims { jwtIss = Nothing + , jwtSub = Nothing + , jwtAud = Nothing + , jwtExp = Nothing + , jwtNbf = Nothing + , jwtIat = Nothing + , jwtJti = Nothing + } + add sec (IntDate t) = IntDate $ t + sec + isValidationException e = case e of + (ValidationException _) -> True + _ -> False