diff --git a/examples/scotty/Main.hs b/examples/scotty/Main.hs --- a/examples/scotty/Main.hs +++ b/examples/scotty/Main.hs @@ -7,7 +7,7 @@ import Crypto.Random.AESCtr (makeSystem) import Crypto.Random.API (CPRG, cprgGenBytes) import Data.ByteString (ByteString) -import Data.ByteString.Base32 (encode) +import Data.ByteString.Base64.URL (encode) import qualified Data.ByteString.Char8 as B import Data.IORef (IORef, newIORef, atomicModifyIORef', readIORef) import Data.Map (Map) 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.3.0.0 +version: 0.3.0.1 synopsis: OpenID Connect 1.0 library for RP homepage: https://github.com/krdlab/haskell-oidc-client stability: experimental @@ -60,12 +60,24 @@ test-suite oidc-client-spec type: exitcode-stdio-1.0 - hs-source-dirs: test + hs-source-dirs: test, src default-language: Haskell2010 ghc-options: -Wall main-is: Spec.hs other-modules: Spec.Client + , Spec.Client.Internal + + -- NOTE: The following modules are needed for using Web.OIDC.Client.Internal. + , Web.OIDC.Client + , 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.Internal + , Web.OIDC.Client.Tokens + , Web.OIDC.Client.Types build-depends: base , hspec @@ -75,6 +87,11 @@ , http-types , http-client , http-client-tls + , aeson + , jose-jwt + , exceptions + , time + , network-uri executable scotty-example main-is: Main.hs @@ -95,7 +112,7 @@ , blaze-html , cprng-aes , crypto-random - , base32-bytestring + , base64-bytestring , http-types , http-client , tls >=1.3.2 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 @@ -16,10 +16,11 @@ import Control.Monad (unless) import Control.Monad.Catch (MonadThrow, throwM, MonadCatch, catch) -import Data.Aeson (decode) +import Data.Aeson (eitherDecode) import qualified Data.ByteString.Char8 as B import Data.List (nub) -import Data.Text (Text, unpack) +import Data.Monoid ((<>)) +import Data.Text (Text, pack, unpack) import Data.Text.Encoding (decodeUtf8) import Data.Time.Clock.POSIX (getPOSIXTime) import Jose.Jwt (Jwt) @@ -70,9 +71,9 @@ 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 + case eitherDecode json of + Right ts -> validate oidc ts + Left err -> error $ "failed to decode tokens json: " ++ err -- TODO: Exception where getTokensJson = do req <- parseUrl endpoint @@ -128,15 +129,15 @@ validateClaims issuer' clientId' now claims' = do iss' <- getIss claims' unless (iss' == issuer') - $ throwM $ ValidationException "issuer" + $ throwM $ ValidationException $ "issuer from token \"" <> iss' <> "\" is different than expected issuer \"" <> issuer' <> "\"" aud' <- getAud claims' unless (clientId' `elem` aud') - $ throwM $ ValidationException "audience" + $ throwM $ ValidationException $ "our client \"" <> clientId' <> "\" isn't contained in the token's audience " <> (pack . show) aud' exp' <- getExp claims' unless (now < exp') - $ throwM $ ValidationException "expire" + $ throwM $ ValidationException "received token has expired" where getIss c = get Jwt.jwtIss c "'iss' claim was not found" getAud c = get Jwt.jwtAud c "'aud' claim was not found" 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,13 +6,15 @@ -} 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 Data.Maybe (fromJust) import Data.Text (Text, unpack) +import Data.Text.Read (decimal) import Jose.Jwt (Jwt, JwtClaims(..)) -import Network.HTTP.Client (HttpException, parseUrl, Request) +import Network.HTTP.Client (HttpException, parseRequest, Request) import Prelude hiding (exp) import Web.OIDC.Client.Tokens (IdTokenClaims(..)) import Web.OIDC.Client.Types (OpenIdException(InternalHttpException)) @@ -28,13 +30,18 @@ instance FromJSON TokensResponse where parseJSON (Object o) = TokensResponse - <$> o .: "access_token" - <*> o .: "token_type" - <*> o .: "id_token" - <*> o .:? "expires_in" - <*> o .:? "refresh_token" + <$> o .: "access_token" + <*> o .: "token_type" + <*> o .: "id_token" + <*> (o .:? "expires_in" <|> (>>= textToInt) <$> (o .:? "expires_in")) + <*> o .:? "refresh_token" parseJSON _ = mzero +textToInt :: Text -> Maybe Integer +textToInt t = case decimal t of + Right (i, _) -> Just i + Left _ -> Nothing + rethrow :: (MonadCatch m) => HttpException -> m a rethrow = throwM . InternalHttpException @@ -48,4 +55,4 @@ } parseUrl :: MonadThrow m => Text -> m Request -parseUrl = Network.HTTP.Client.parseUrl . unpack +parseUrl = Network.HTTP.Client.parseRequest . unpack diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,5 +1,8 @@ import Test.Hspec (hspec) import qualified Spec.Client as Client +import qualified Spec.Client.Internal as Internal main :: IO () -main = hspec Client.tests +main = hspec $ do + Client.tests + Internal.tests diff --git a/test/Spec/Client/Internal.hs b/test/Spec/Client/Internal.hs new file mode 100644 --- /dev/null +++ b/test/Spec/Client/Internal.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE OverloadedStrings #-} +module Spec.Client.Internal where + +import Data.Aeson (decode) +import Jose.Jwt (Jwt(..)) +import Test.Hspec (Spec, describe, it, shouldBe) +import qualified Web.OIDC.Client.Internal as I + +tests :: Spec +tests = + describe "Internal: Decode TokensResponse JSON data" $ do + it "should be successful decoding a JSON data which has full fields" $ do + let json = "{\"access_token\":\"access token\",\"token_type\":\"token type\",\"id_token\":\"dummy jwt\",\"expires_in\":123,\"refresh_token\":\"refresh token\"}" + decode json `shouldBe` Just (I.TokensResponse "access token" "token type" (Jwt "dummy jwt") (Just 123) (Just "refresh token")) + + it "should be successful decoding a JSON data without 'refresh_token' field" $ do + let json = "{\"access_token\":\"access token\",\"token_type\":\"token type\",\"id_token\":\"dummy jwt\",\"expires_in\":123}" + decode json `shouldBe` Just (I.TokensResponse "access token" "token type" (Jwt "dummy jwt") (Just 123) Nothing) + + it "should be successful decoding a JSON data without 'expires_in' and 'refresh_token' fields" $ do + let json = "{\"access_token\":\"access token\",\"token_type\":\"token type\",\"id_token\":\"dummy jwt\"}" + decode json `shouldBe` Just (I.TokensResponse "access token" "token type" (Jwt "dummy jwt") Nothing Nothing) + + it "should be failure decoding a JSON data from the lack of a required field" $ do + let json = "{\"access_token\":\"access token\",\"token_type\":\"token type\"}" + decode json `shouldBe` (Nothing :: Maybe I.TokensResponse) + + -- NOTE: The 'expires_in' field is an integer, is not included a fractional part. But, I received the report https://github.com/krdlab/haskell-oidc-client/pull/15. + -- see also: https://tools.ietf.org/html/rfc6749#appendix-A.14 + it "should be successful decoding a JSON data with 'expires_in' field which has a fractional part" $ do + let json = "{\"access_token\":\"access token\",\"token_type\":\"token type\",\"id_token\":\"dummy jwt\",\"expires_in\":123.45}" + decode json `shouldBe` Just (I.TokensResponse "access token" "token type" (Jwt "dummy jwt") (Just 123) Nothing)