planb-token-introspection (empty) → 0.1.0.0
raw patch · 10 files changed
+520/−0 lines, 10 filesdep +aesondep +aeson-casingdep +basesetup-changed
Dependencies added: aeson, aeson-casing, base, bytestring, containers, exceptions, http-client, http-client-tls, http-types, lens, mtl, planb-token-introspection, random, safe-exceptions, tasty, tasty-hunit, text, transformers, unliftio-core
Files
- LICENSE +30/−0
- README.md +24/−0
- Setup.hs +2/−0
- planb-token-introspection.cabal +66/−0
- src/Network/PlanB/Introspection.hs +12/−0
- src/Network/PlanB/Introspection/Internal.hs +135/−0
- src/Network/PlanB/Introspection/Internal/Types.hs +64/−0
- tests/Network/PlanB/Introspection/Internal/Test.hs +64/−0
- tests/Network/PlanB/Introspection/Test.hs +106/−0
- tests/Spec.hs +17/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Moritz Clasmeier (c) 2018++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Moritz Schulte nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,24 @@+# Token Introspection for PlanB [](https://hackage.haskell.org/package/planb-token-introspection) [](https://www.stackage.org/package/planb-token-introspection) [](https://travis-ci.org/mtesseract/planb-token-introspection)++This package provides token introspection functionality for+[PlanB](http://planb.readthedocs.io/en/latest/).++## Example++```haskell+printTokenInfo :: ByteString -> IO ()+printTokenInfo token = do+ introspector <- PlanB.new "https://planb-endpoint"+ tokenInfo <- PlanB.introspectToken introspector token+ print tokenInfo+```++If the PlanB introspection endpoint to use can be retrieved from the+environment variable `PLANB_INTROSPECTION_ENDPOINT`, then one can+alternatively use++```haskell+ introspector <- PlanB.newFromEnv+```++for creating the PlanB introspector.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ planb-token-introspection.cabal view
@@ -0,0 +1,66 @@+name: planb-token-introspection+version: 0.1.0.0+synopsis: Token Introspection for PlanB+description: This package provides token introspection functionality+ for the PlanB token provider.+homepage: https://github.com/mtesseract/planb-token-introspection#readme+license: BSD3+license-file: LICENSE+author: Moritz Clasmeier+maintainer: mtesseract@silverratio.net+copyright: (c) 2018 Moritz Clasmeier+category: Security+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10++library+ hs-source-dirs: src+ exposed-modules: Network.PlanB.Introspection+ , Network.PlanB.Introspection.Internal+ , Network.PlanB.Introspection.Internal.Types+ ghc-options: -Wall+ build-depends: base >= 4.7 && < 5+ , http-client+ , http-client-tls+ , http-types+ , safe-exceptions+ , text+ , aeson+ , aeson-casing+ , text+ , containers+ , bytestring+ , mtl+ , transformers+ default-language: Haskell2010++test-suite access-token-provider-test+ type: exitcode-stdio-1.0+ hs-source-dirs: tests+ main-is: Spec.hs+ other-modules: Network.PlanB.Introspection.Test+ , Network.PlanB.Introspection.Internal.Test+ build-depends: base+ , planb-token-introspection+ , aeson+ , text+ , tasty+ , tasty-hunit+ , safe-exceptions+ , random+ , lens+ , containers+ , exceptions+ , bytestring+ , mtl+ , http-client+ , http-types+ , unliftio-core+ , safe-exceptions+ ghc-options: -Wall+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/mtesseract/planb-token-introspection
+ src/Network/PlanB/Introspection.hs view
@@ -0,0 +1,12 @@+module Network.PlanB.Introspection+ ( TokenInfo(..)+ , Conf+ , PlanBIntrospectionException+ , new+ , newFromEnv+ , newCustom+ , httpRequestExecuteIO+ , introspectToken+ ) where++import Network.PlanB.Introspection.Internal
+ src/Network/PlanB/Introspection/Internal.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Network.PlanB.Introspection.Internal+ ( TokenInfo(..)+ , Conf+ , PlanBIntrospectionException+ , new+ , newFromEnv+ , newCustom+ , httpRequestExecuteIO+ , introspectToken+ ) where++import Control.Arrow+import Control.Exception.Safe+import Control.Monad+import Control.Monad.IO.Class+import Data.Aeson+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as ByteString.Lazy+import Data.Function ((&))+import Data.Monoid+import Data.Text (Text)+import qualified Data.Text as Text+import Network.HTTP.Client+import Network.HTTP.Client.TLS+import Network.HTTP.Types+import qualified System.Environment as Env++import Network.PlanB.Introspection.Internal.Types++-- | Create a new PlanB introspector using the provided endpoint.+new :: (MonadThrow m, MonadIO m)+ => Text+ -> m (TokenIntrospector m)+new endpoint = do+ conf <- newConf backendIO endpoint+ pure $ TokenIntrospector { introspectToken = introspectTokenImpl conf }+backendIO :: MonadIO m => Backend m+backendIO =+ Backend { backendHttp = httpBackendIO+ , backendEnv = envBackendIO }++envBackendIO :: MonadIO m => BackendEnv m+envBackendIO =+ BackendEnv { envLookup = envLookupIO }++envLookupIO :: MonadIO m => Text -> m (Maybe Text)+envLookupIO =+ Text.unpack+ >>> Env.lookupEnv+ >>> fmap (fmap Text.pack)+ >>> liftIO++httpBackendIO :: MonadIO m => BackendHttp m+httpBackendIO =+ BackendHttp { httpRequestExecute = httpRequestExecuteIO Nothing }++newFromEnv :: (MonadThrow m, MonadIO m)+ => m (TokenIntrospector m)+newFromEnv = do+ let backend = backendIO+ BackendEnv { .. } = backendEnv backend+ endpoint <- envLookup "PLANB_INTROSPECTION_ENDPOINT" >>= \ case+ Just ep -> pure ep+ Nothing -> throwM PlanBIntrospectionEndpointMissing+ newCustom backend endpoint++newCustom+ :: (MonadThrow m, MonadIO m)+ => Backend m+ -> Text+ -> m (TokenIntrospector m)+newCustom backend introspectionEndpoint = do+ conf <- newConf backend introspectionEndpoint+ pure $ TokenIntrospector { introspectToken = introspectTokenImpl conf }++newConf+ :: MonadThrow m+ => Backend m+ -> Text+ -> m (Conf m)+newConf backend introspectionEndpoint = do+ introspectionRequest <- parseRequest introspectionEndpointStr+ pure Conf { confIntrospectionRequest = introspectionRequest+ , confBackend = backend }+ where introspectionEndpointStr = Text.unpack introspectionEndpoint++httpRequestExecuteIO+ :: MonadIO m+ => Maybe Manager+ -> Request+ -> m (Response LazyByteString)+httpRequestExecuteIO maybeManager request = do+ liftIO $ print request+ manager <- maybe (liftIO getGlobalManager) pure maybeManager+ liftIO $ httpLbs request manager++introspectTokenImpl+ :: MonadThrow m+ => Conf m+ -> ByteString+ -> m TokenInfo+introspectTokenImpl conf token = do+ let endpoint = confIntrospectionRequest conf+ bearerToken = "Bearer " <> token+ request = endpoint { method = "GET"+ , path = "/oauth2/tokeninfo"+ , requestHeaders = [("Authorization", bearerToken)] }+ httpBackend = conf+ & confBackend+ & backendHttp+ response <- httpRequestExecute httpBackend request+ let body = responseBody response & ByteString.Lazy.toStrict++ when (statusCode (responseStatus response) /= 200) $+ throwM $ bodyToPlanBException body++ case eitherDecodeStrict body of+ Right tokenInfo ->+ pure tokenInfo+ Left errMsg ->+ throwM $ PlanBIntrospectionDeserialization (Text.pack errMsg) body++bodyToPlanBException+ :: ByteString -> PlanBIntrospectionException+bodyToPlanBException bytes =+ case eitherDecodeStrict bytes of+ Right err ->+ PlanBIntrospectionError err+ Left errMsgStr ->+ let errMsg = Text.pack errMsgStr+ in PlanBIntrospectionDeserialization errMsg bytes
+ src/Network/PlanB/Introspection/Internal/Types.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TemplateHaskell #-}++module Network.PlanB.Introspection.Internal.Types where++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.Set+import Data.Text (Text)+import GHC.Generics+import Network.HTTP.Client++type LazyByteString = ByteString.Lazy.ByteString++data TokenIntrospector m =+ TokenIntrospector { introspectToken :: ByteString -> m TokenInfo }++data TokenInfo =+ TokenInfo { tokenInfoExpiresIn :: Int+ , tokenInfoScope :: Set Text+ , tokenInfoUid :: Text+ , tokenInfoRealm :: Text+ } deriving (Show, Generic)++$(deriveJSON (aesonDrop (length ("tokenInfo" :: String)) snakeCase) ''TokenInfo)++data BackendHttp m = BackendHttp+ { httpRequestExecute :: Request -> m (Response LazyByteString)+ }++data BackendEnv m = BackendEnv+ { envLookup :: Text -> m (Maybe Text)+ }++data Backend m = Backend+ { backendHttp :: BackendHttp m+ , backendEnv :: BackendEnv m+ }++data Conf m = Conf+ { confIntrospectionRequest :: Request+ , confBackend :: Backend m }++-- | Type for RFC7807 @Problem@ objects.+data PlanBError = PlanBError+ { oauth2Error :: Text+ , oauth2ErrorDescription :: Maybe Text+ , oauth2ErrorURI :: Maybe Text+ , oauth2ErrorState :: Maybe Text+ } deriving (Show, Eq, Generic)++$(deriveJSON (aesonDrop (length ("oauth2" :: String)) snakeCase) ''PlanBError)++data PlanBIntrospectionException = PlanBIntrospectionDeserialization Text ByteString+ | PlanBIntrospectionError PlanBError+ | PlanBIntrospectionEndpointMissing+ deriving (Typeable, Show)++instance Exception PlanBIntrospectionException
+ tests/Network/PlanB/Introspection/Internal/Test.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.PlanB.Introspection.Internal.Test+ ( planBTokenIntrospectionTests+ ) where++import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as ByteString.Lazy+import qualified Data.Map as Map+import qualified Data.Text.Encoding as Text+import Network.HTTP.Client.Internal+import Network.HTTP.Types+import Test.Tasty+import Test.Tasty.HUnit++import Network.PlanB.Introspection+import qualified Network.PlanB.Introspection as PlanB+import Network.PlanB.Introspection.Test+++planBTokenIntrospectionTests :: [TestTree]+planBTokenIntrospectionTests =+ [ testGroup "Network.PlanB.Introspection.Internal" $+ [ testCase "Introspect token"+ testIntrospectToken+ ]+ ]++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\" }"+ response = Response { responseStatus = ok200+ , responseVersion = http20+ , responseHeaders = []+ , responseBody = rspBody+ , responseCookieJar = CJ []+ , responseClose' = ResponseClose (pure ())+ }+ testState = TestState+ { _testStateHttpResponse = Just response+ , _testStateHttpRequests = []+ , _testStateEnvironment = Map.empty+ }+ token = "some-token"+ (_, testState') <- runTestStack testState $ do+ introspector <- makeTestIntrospector+ _info <- introspectToken introspector token+ pure ()+ 1 @=? length (_testStateHttpRequests testState')++_printTokenInfo :: ByteString -> IO ()+_printTokenInfo token = do+ introspector <- PlanB.new "https://planb-endpoint"+ tokenInfo <- PlanB.introspectToken introspector token+ print tokenInfo
+ tests/Network/PlanB/Introspection/Test.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Network.PlanB.Introspection.Test where++import Control.Arrow+import Control.Lens+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 Data.IORef+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++evalTestStack :: TestState -> TestStack a -> IO a+evalTestStack testState m = do+ s <- newIORef testState+ m & (_runTestStack >>> flip runReaderT s)++newtype TestStack a = TestStack+ { _runTestStack :: ReaderT (IORef TestState) IO a+ } deriving ( Functor+ , Applicative+ , Monad+ , MonadThrow+ , MonadCatch+ , MonadMask+ , MonadReader (IORef TestState)+ , MonadIO+ )++instance MonadUnliftIO TestStack where+ askUnliftIO = do+ (UnliftIO u) <- TestStack askUnliftIO+ pure $ UnliftIO (\ (TestStack m) -> u m)++data TestState =+ TestState { _testStateHttpRequests :: [Request]+ , _testStateHttpResponse :: Maybe (Response ByteString.Lazy.ByteString)+ , _testStateEnvironment :: Map Text Text+ }++makeFieldsNoPrefix ''TestState++instance MonadState TestState TestStack where+ get = do+ envRef <- ask+ liftIO $ readIORef envRef+ put s = do+ envRef <- ask+ liftIO $ writeIORef envRef s++mockHttpRequestExecute :: Request -> TestStack (Response LazyByteString)+mockHttpRequestExecute request = do+ testStateHttpRequests %= (request :)+ maybeResponse <- gets (view testStateHttpResponse)+ case maybeResponse of+ Just response ->+ pure response+ Nothing ->+ error "FIXME"++mockHttpBackend :: BackendHttp TestStack+mockHttpBackend =+ BackendHttp { httpRequestExecute = mockHttpRequestExecute }++mockEnvBackend :: BackendEnv TestStack+mockEnvBackend =+ BackendEnv { envLookup = mockEnvLookup }++mockEnvLookup :: Text -> TestStack (Maybe Text)+mockEnvLookup name = do+ environment <- gets (view testStateEnvironment)+ pure $ Map.lookup name environment++mockBackend :: Backend TestStack+mockBackend = Backend+ { backendHttp = mockHttpBackend+ , backendEnv = mockEnvBackend+ }++makeTestIntrospector :: TestStack (TokenIntrospector TestStack)+makeTestIntrospector =+ newCustom mockBackend "https://localhost"
+ tests/Spec.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Test.Tasty++import Network.PlanB.Introspection.Internal.Test++main :: IO ()+main = do+ putStrLn ""+ defaultMain tests++tests :: TestTree+tests =+ testGroup "PlanB Token Introspection Test Suite"+ planBTokenIntrospectionTests