diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -18,7 +18,7 @@ alternatively use ```haskell - introspector <- PlanB.newFromEnv + introspector <- PlanB.newFromEnv Nothing ``` for creating the PlanB introspector. diff --git a/planb-token-introspection.cabal b/planb-token-introspection.cabal --- a/planb-token-introspection.cabal +++ b/planb-token-introspection.cabal @@ -1,5 +1,5 @@ name: planb-token-introspection -version: 0.1.0.0 +version: 0.1.1.0 synopsis: Token Introspection for PlanB description: This package provides token introspection functionality for the PlanB token provider. @@ -58,6 +58,7 @@ , http-types , unliftio-core , safe-exceptions + , th-format ghc-options: -Wall default-language: Haskell2010 diff --git a/src/Network/PlanB/Introspection.hs b/src/Network/PlanB/Introspection.hs --- a/src/Network/PlanB/Introspection.hs +++ b/src/Network/PlanB/Introspection.hs @@ -1,10 +1,11 @@ module Network.PlanB.Introspection ( TokenInfo(..) , Conf - , PlanBIntrospectionException + , IntrospectionException(..) , new + , newWithManager , newFromEnv - , newCustom + , newWithBackend , httpRequestExecuteIO , introspectToken ) where diff --git a/src/Network/PlanB/Introspection/Internal.hs b/src/Network/PlanB/Introspection/Internal.hs --- a/src/Network/PlanB/Introspection/Internal.hs +++ b/src/Network/PlanB/Introspection/Internal.hs @@ -5,10 +5,11 @@ module Network.PlanB.Introspection.Internal ( TokenInfo(..) , Conf - , PlanBIntrospectionException + , IntrospectionException(..) , new + , newWithManager , newFromEnv - , newCustom + , newWithBackend , httpRequestExecuteIO , introspectToken ) where @@ -35,12 +36,23 @@ new :: (MonadThrow m, MonadIO m) => Text -> m (TokenIntrospector m) -new endpoint = do - conf <- newConf backendIO endpoint +new = newWithManager Nothing + +-- | Create a new PlanB introspector using the provided endpoint and +-- manager. +newWithManager :: (MonadThrow m, MonadIO m) + => Maybe Manager + -> Text + -> m (TokenIntrospector m) +newWithManager maybeManager endpoint = do + conf <- newConf (backendIO maybeManager) endpoint pure $ TokenIntrospector { introspectToken = introspectTokenImpl conf } -backendIO :: MonadIO m => Backend m -backendIO = - Backend { backendHttp = httpBackendIO + +backendIO :: MonadIO m + => Maybe Manager + -> Backend m +backendIO maybeManager = + Backend { backendHttp = httpBackendIO maybeManager , backendEnv = envBackendIO } envBackendIO :: MonadIO m => BackendEnv m @@ -54,26 +66,33 @@ >>> fmap (fmap Text.pack) >>> liftIO -httpBackendIO :: MonadIO m => BackendHttp m -httpBackendIO = - BackendHttp { httpRequestExecute = httpRequestExecuteIO Nothing } +httpBackendIO :: MonadIO m + => Maybe Manager + -> BackendHttp m +httpBackendIO maybeManager = + BackendHttp { httpRequestExecute = httpRequestExecuteIO maybeManager } +-- | Convenience function. Create a new PlanB introspector using the +-- provided manager. The PlanB server to use is retrieved from the +-- environment variable @PLANB_INTROSPECTION_ENDPOINT@. newFromEnv :: (MonadThrow m, MonadIO m) - => m (TokenIntrospector m) -newFromEnv = do - let backend = backendIO + => Maybe Manager + -> m (TokenIntrospector m) +newFromEnv maybeManager = do + let backend = backendIO maybeManager BackendEnv { .. } = backendEnv backend endpoint <- envLookup "PLANB_INTROSPECTION_ENDPOINT" >>= \ case Just ep -> pure ep - Nothing -> throwM PlanBIntrospectionEndpointMissing - newCustom backend endpoint + Nothing -> throwM IntrospectionEndpointMissing + newWithBackend backend endpoint -newCustom +-- | Create a new PlanB introspector using the provided backend and endpoint. +newWithBackend :: (MonadThrow m, MonadIO m) => Backend m -> Text -> m (TokenIntrospector m) -newCustom backend introspectionEndpoint = do +newWithBackend backend introspectionEndpoint = do conf <- newConf backend introspectionEndpoint pure $ TokenIntrospector { introspectToken = introspectTokenImpl conf } @@ -122,14 +141,14 @@ Right tokenInfo -> pure tokenInfo Left errMsg -> - throwM $ PlanBIntrospectionDeserialization (Text.pack errMsg) body + throwM $ IntrospectionDeserialization (Text.pack errMsg) body bodyToPlanBException - :: ByteString -> PlanBIntrospectionException + :: ByteString -> IntrospectionException bodyToPlanBException bytes = case eitherDecodeStrict bytes of Right err -> - PlanBIntrospectionError err + IntrospectionError err Left errMsgStr -> let errMsg = Text.pack errMsgStr - in PlanBIntrospectionDeserialization errMsg bytes + in IntrospectionDeserialization errMsg bytes diff --git a/src/Network/PlanB/Introspection/Internal/Types.hs b/src/Network/PlanB/Introspection/Internal/Types.hs --- a/src/Network/PlanB/Introspection/Internal/Types.hs +++ b/src/Network/PlanB/Introspection/Internal/Types.hs @@ -17,8 +17,11 @@ type LazyByteString = ByteString.Lazy.ByteString +-- | A 'TokenIntrospector' can be used for introspecting tokens. data TokenIntrospector m = - TokenIntrospector { introspectToken :: ByteString -> m TokenInfo } + TokenIntrospector + { introspectToken :: ByteString -> m TokenInfo -- ^ Introspect the provided token + } data TokenInfo = TokenInfo { tokenInfoExpiresIn :: Int @@ -56,9 +59,9 @@ $(deriveJSON (aesonDrop (length ("oauth2" :: String)) snakeCase) ''PlanBError) -data PlanBIntrospectionException = PlanBIntrospectionDeserialization Text ByteString - | PlanBIntrospectionError PlanBError - | PlanBIntrospectionEndpointMissing +data IntrospectionException = IntrospectionDeserialization Text ByteString + | IntrospectionError PlanBError + | IntrospectionEndpointMissing deriving (Typeable, Show) -instance Exception PlanBIntrospectionException +instance Exception IntrospectionException diff --git a/tests/Network/PlanB/Introspection/Internal/Test.hs b/tests/Network/PlanB/Introspection/Internal/Test.hs --- a/tests/Network/PlanB/Introspection/Internal/Test.hs +++ b/tests/Network/PlanB/Introspection/Internal/Test.hs @@ -1,11 +1,15 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} module Network.PlanB.Introspection.Internal.Test ( planBTokenIntrospectionTests ) where +import Control.Exception.Safe +import Control.Monad import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as ByteString.Lazy +import Data.Format import qualified Data.Map as Map import qualified Data.Text.Encoding as Text import Network.HTTP.Client.Internal @@ -23,21 +27,45 @@ [ testGroup "Network.PlanB.Introspection.Internal" $ [ testCase "Introspect token" testIntrospectToken + , testCase "Deserialization failure is converted to exception" + testDeserializationFailure ] ] +testDeserializationFailure :: Assertion +testDeserializationFailure = do + let rspBody = ByteString.Lazy.fromStrict . Text.encodeUtf8 $ "{something broken" + response = Response { responseStatus = ok200 + , responseVersion = http20 + , responseHeaders = [] + , responseBody = rspBody + , responseCookieJar = CJ [] + , responseClose' = ResponseClose (pure ()) + } + testState = TestState + { _testStateHttpResponse = Just response + , _testStateHttpRequests = [] + , _testStateEnvironment = Map.empty + } + tokenName = "some-token-name" + Left (PlanB.IntrospectionDeserialization _ _) <- try $ runTestStack testState $ do + introspector <- makeTestIntrospector + void $ introspectToken introspector tokenName + pure () + testIntrospectToken :: Assertion testIntrospectToken = do - let rspBody = ByteString.Lazy.fromStrict . Text.encodeUtf8 $ - "{ \"access_token\": \"some-token\", \ - \ \"client_id\": \"test-suite\", \ - \ \"cn\": \"some-username\", \ - \ \"expires_in\": 3591, \ - \ \"grant_type\": \"password\", \ - \ \"realm\": \"/employees\", \ - \ \"scope\": [\"uid\"], \ - \ \"token_type\": \"Bearer\", \ - \ \"uid\": \"some-user-name\" }" + let rspBody = ByteString.Lazy.fromStrict . Text.encodeUtf8 $ [fmt| + { "access_token": "some-token", + "client_id": "test-suite", + "cn": "some-username", + "expires_in": 3591, + "grant_type": "password", + "realm": "/employees", + "scope": ["uid"], + "token_type": "Bearer", + "uid": "some-user-name" } + |] response = Response { responseStatus = ok200 , responseVersion = http20 , responseHeaders = [] diff --git a/tests/Network/PlanB/Introspection/Test.hs b/tests/Network/PlanB/Introspection/Test.hs --- a/tests/Network/PlanB/Introspection/Test.hs +++ b/tests/Network/PlanB/Introspection/Test.hs @@ -103,4 +103,4 @@ makeTestIntrospector :: TestStack (TokenIntrospector TestStack) makeTestIntrospector = - newCustom mockBackend "https://localhost" + newWithBackend mockBackend "https://localhost"