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.2.0 +version: 0.1.3.0 synopsis: Token Introspection for PlanB description: This package provides token introspection functionality for the PlanB token provider. 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,14 +1,12 @@ module Network.PlanB.Introspection ( TokenInfo(..) - , Conf - , IntrospectionException(..) + , IntrospectionError(..) , ErrorResponse(..) + , TokenIntrospector(..) , new , newWithManager , newFromEnv - , newWithBackend - , httpRequestExecuteIO - , introspectToken - ) where + ) +where import Network.PlanB.Introspection.Internal 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,14 +5,17 @@ module Network.PlanB.Introspection.Internal ( TokenInfo(..) , Conf - , IntrospectionException(..) + , IntrospectionError(..) , ErrorResponse(..) + , TokenIntrospector(..) + , Backend(..) + , BackendEnv(..) + , BackendHttp(..) , new , newWithManager , newFromEnv , newWithBackend - , httpRequestExecuteIO - , introspectToken + , backendIO ) where import Control.Arrow @@ -33,22 +36,23 @@ import Network.PlanB.Introspection.Internal.Types --- | Create a new PlanB introspector using the provided endpoint. +-- | Create a new PlanB token introspector using the provided endpoint. Uses a global default HTTP manager. new :: (MonadThrow m, MonadIO m) => Text -> m (TokenIntrospector m) new = newWithBackend (backendIO Nothing) --- | Create a new PlanB introspector using the provided endpoint and --- manager. +-- | Create a new PlanB toke introspector using the provided endpoint and +-- HTTP manager. newWithManager :: (MonadThrow m, MonadIO m) => Manager -> Text -> m (TokenIntrospector m) newWithManager manager = newWithBackend (backendIO (Just manager)) +-- | Produces the default IO backend. backendIO :: MonadIO m - => Maybe Manager + => Maybe Manager -- ^ Use global default HTTP manager if 'Nothing'. -> Backend m backendIO maybeManager = Backend { backendHttp = httpBackendIO maybeManager @@ -85,7 +89,7 @@ Nothing -> throwM NoEndpoint newWithBackend backend endpoint --- | Create a new PlanB introspector using the provided backend and endpoint. +-- | Create a new PlanB token introspector using the provided backend and endpoint. newWithBackend :: (MonadThrow m, MonadIO m) => Backend m @@ -143,7 +147,7 @@ BackendHttp { .. } = backend & backendHttp bodyToPlanBException - :: ByteString -> IntrospectionException + :: ByteString -> IntrospectionError bodyToPlanBException bytes = case eitherDecodeStrict bytes of Right err @ ErrorResponse { .. } -> 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 @@ -8,10 +8,10 @@ import Control.Exception.Safe import Data.Aeson.Casing import Data.Aeson.TH -import Data.ByteString (ByteString) -import qualified Data.ByteString.Lazy as ByteString.Lazy +import Data.ByteString ( ByteString ) +import qualified Data.ByteString.Lazy as ByteString.Lazy import Data.Set -import Data.Text (Text) +import Data.Text ( Text ) import GHC.Generics import Network.HTTP.Client @@ -20,9 +20,10 @@ -- | A 'TokenIntrospector' can be used for introspecting tokens. data TokenIntrospector m = TokenIntrospector - { introspectToken :: ByteString -> m TokenInfo -- ^ Introspect the provided token + { introspectToken :: ByteString -> m TokenInfo -- ^ Introspect the provided token. } +-- | Information returned on a successful token introspection. data TokenInfo = TokenInfo { tokenInfoExpiresIn :: Int , tokenInfoScope :: Set Text @@ -40,6 +41,7 @@ { envLookup :: Text -> m (Maybe Text) } +-- | Type for backends for the PlanB token introspector. data Backend m = Backend { backendHttp :: BackendHttp m , backendEnv :: BackendEnv m @@ -49,6 +51,7 @@ { confIntrospectionRequest :: Request , confBackend :: Backend m } +-- | Contains the error response data returned from a PlanB server in case of an introspection error. data ErrorResponse = ErrorResponse { errorResponseError :: Text , errorResponseErrorDescription :: Maybe Text @@ -56,11 +59,13 @@ $(deriveJSON (aesonDrop (length ("errorResponse" :: String)) snakeCase) ''ErrorResponse) -data IntrospectionException = DeserializationFailure Text ByteString - | InvalidRequest ErrorResponse - | InvalidToken ErrorResponse - | Other ErrorResponse - | NoEndpoint - deriving (Typeable, Show) +-- | This type models the error scenarios specific to a token introspection attempt. These can be used +-- as exceptions and are in fact thrown by a PlanB token introspector. +data IntrospectionError = DeserializationFailure Text ByteString + | InvalidRequest ErrorResponse + | InvalidToken ErrorResponse + | Other ErrorResponse + | NoEndpoint + deriving (Typeable, Show, Eq, Generic) -instance Exception IntrospectionException +instance Exception IntrospectionError 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 @@ -29,9 +29,32 @@ testIntrospectToken , testCase "Deserialization failure is converted to exception" testDeserializationFailure + , testCase "InvalidToken exception is thrown" + testInvalidToken ] ] +testInvalidToken :: Assertion +testInvalidToken = do + let rspBody = ByteString.Lazy.fromStrict . Text.encodeUtf8 $ + [fmt|{"error":"invalid_token","error_description":"Access Token not valid"}|] + response = Response { responseStatus = status401 + , responseVersion = http20 + , responseHeaders = [] + , responseBody = rspBody + , responseCookieJar = CJ [] + , responseClose' = ResponseClose (pure ()) + } + testState = TestState + { _testStateHttpResponse = Just response + , _testStateHttpRequests = [] + , _testStateEnvironment = Map.empty + } + Left (PlanB.InvalidToken _) <- try $ runTestStack testState $ do + introspector <- makeTestIntrospector + void $ introspectToken introspector "some-token" + pure () + testDeserializationFailure :: Assertion testDeserializationFailure = do let rspBody = ByteString.Lazy.fromStrict . Text.encodeUtf8 $ "{something broken" @@ -47,10 +70,9 @@ , _testStateHttpRequests = [] , _testStateEnvironment = Map.empty } - tokenName = "some-token-name" Left (PlanB.DeserializationFailure _ _) <- try $ runTestStack testState $ do introspector <- makeTestIntrospector - void $ introspectToken introspector tokenName + void $ introspectToken introspector "some-token" pure () testIntrospectToken :: Assertion 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 @@ -13,26 +13,24 @@ import Control.Arrow import Control.Lens -import Control.Monad.Catch hiding (bracket) +import Control.Monad.Catch hiding ( bracket ) import Control.Monad.IO.Class import Control.Monad.IO.Unlift import Control.Monad.Reader import Control.Monad.State -import qualified Data.ByteString.Lazy as ByteString.Lazy +import qualified Data.ByteString.Lazy as ByteString.Lazy import Data.IORef -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Text (Text) +import Data.Map ( Map ) +import qualified Data.Map as Map +import Data.Text ( Text ) import Network.HTTP.Client - import Network.PlanB.Introspection.Internal -import Network.PlanB.Introspection.Internal.Types runTestStack :: TestState -> TestStack a -> IO (a, TestState) runTestStack testState m = do s <- newIORef testState a <- m & (_runTestStack >>> flip runReaderT s) - (a,) <$> readIORef s + (a, ) <$> readIORef s evalTestStack :: TestState -> TestStack a -> IO a evalTestStack testState m = do @@ -72,23 +70,20 @@ envRef <- ask liftIO $ writeIORef envRef s -mockHttpRequestExecute :: Request -> TestStack (Response LazyByteString) +mockHttpRequestExecute + :: Request -> TestStack (Response ByteString.Lazy.ByteString) mockHttpRequestExecute request = do testStateHttpRequests %= (request :) maybeResponse <- gets (view testStateHttpResponse) case maybeResponse of - Just response -> - pure response - Nothing -> - error "FIXME" + Just response -> pure response + Nothing -> error "FIXME" mockHttpBackend :: BackendHttp TestStack -mockHttpBackend = - BackendHttp { httpRequestExecute = mockHttpRequestExecute } +mockHttpBackend = BackendHttp {httpRequestExecute = mockHttpRequestExecute} mockEnvBackend :: BackendEnv TestStack -mockEnvBackend = - BackendEnv { envLookup = mockEnvLookup } +mockEnvBackend = BackendEnv {envLookup = mockEnvLookup} mockEnvLookup :: Text -> TestStack (Maybe Text) mockEnvLookup name = do @@ -96,11 +91,8 @@ pure $ Map.lookup name environment mockBackend :: Backend TestStack -mockBackend = Backend - { backendHttp = mockHttpBackend - , backendEnv = mockEnvBackend - } +mockBackend = + Backend {backendHttp = mockHttpBackend, backendEnv = mockEnvBackend} makeTestIntrospector :: TestStack (TokenIntrospector TestStack) -makeTestIntrospector = - newWithBackend mockBackend "https://localhost" +makeTestIntrospector = newWithBackend mockBackend "https://localhost"