diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,35 +1,36 @@ -# Access Token Provider +# Access Token Provider [![Hackage version](https://img.shields.io/hackage/v/access-token-provider.svg?label=Hackage)](https://hackage.haskell.org/package/access-token-provider) [![Stackage version](https://www.stackage.org/package/access-token-provider/badge/lts?label=Stackage)](https://www.stackage.org/package/access-token-provider) [![Build Status](https://travis-ci.org/mtesseract/access-token-provider.svg?branch=master)](https://travis-ci.org/mtesseract/access-token-provider) -This package provides a convenient retrieval mechanism of access -tokens. Access Token Provider supporting multiple provider backends, -including OAuth2 Resource Owner Password Credentials Grant, file-based -token access (e.g. for Kubernetes) and fetching tokens from the -environment (e.g. for local testing). The package is configurable via -environment variables. It uses Katip for logging. +This package provides a convenient retrieval mechanism for access +tokens. Multiple provider backends, including OAuth2 Resource Owner +Password Credentials Grant, file-based token access (e.g. for +Kubernetes) and fetching tokens from the environment (e.g. for local +testing) are supported; custom provider backends can easily be added. ## Examples ```haskell import qualified Security.AccessTokenProvider as ATP -retrieveSomeToken :: KatipContextT IO () +retrieveSomeToken :: IO () retrieveSomeToken = do tokenProvider <- ATP.new (AccessTokenName "token-name") token <- ATP.retrieveAccessToken tokenProvider - liftIO $ print token + print token ``` ## Configuration -Configuration is done by setting the environment variable `ATP_CONF`. +Configuration is done by setting certain environment variables, +depending on the provider. ### OAuth2 based token retrieval -For OAuth2 (Resource Owner Password Credentials Grant) provider, use: +The OAuth2 (Resource Owner Password Credentials Grant) provider +expects the `ATP_CONF_ROPCG` environment variable to contain a JSON +object as follows: ```json { - "provider": "ropcg", "credentials_directory": "/optional/credentials/directory", "auth_endpoint": "", "tokens": {"token-name": {"scopes": ["first-scope", "second-scope"]}} @@ -43,9 +44,11 @@ ### File based token retrieval (e.g. for Kubernetes) +The file based provider expects the `ATP_CONF_FILE` environment +variable to contain a JSON object as follows: + ```json { - "provider": "file", "tokens": {"token-name": "/some/file/name"} } ``` @@ -55,12 +58,11 @@ ### Environment based token retrieval (e.g. for testing) +The file based provider expects the `ATP_CONF_FIXED` environment +variable to contain a JSON object as follows: + ```json { - "provider": "fixed", "tokens": {"token-name": "some-fixed-token"} } ``` - -As a short cut, you can simply save a token directly in the -environment variable `TOKEN`. diff --git a/access-token-provider.cabal b/access-token-provider.cabal --- a/access-token-provider.cabal +++ b/access-token-provider.cabal @@ -1,5 +1,5 @@ name: access-token-provider -version: 0.1.0.0 +version: 0.1.1.0 synopsis: Provides Access Token for Services description: Access Token Provider supporting multiple provider backends, including OAuth2 Resource Owner Password Credentials Grant, @@ -23,10 +23,11 @@ exposed-modules: Security.AccessTokenProvider , Security.AccessTokenProvider.Internal , Security.AccessTokenProvider.Internal.Types + , Security.AccessTokenProvider.Internal.Types.Severity , Security.AccessTokenProvider.Internal.Lenses , Security.AccessTokenProvider.Internal.Util - , Security.AccessTokenProvider.Internal.Providers.Common , Security.AccessTokenProvider.Internal.Providers.Fixed + , Security.AccessTokenProvider.Internal.Providers.SimpleFixed , Security.AccessTokenProvider.Internal.Providers.File , Security.AccessTokenProvider.Internal.Providers.OAuth2.Ropcg build-depends: base >= 4.7 && < 5 @@ -52,6 +53,7 @@ , mtl , transformers , random + , say default-language: Haskell2010 diff --git a/src/Security/AccessTokenProvider.hs b/src/Security/AccessTokenProvider.hs --- a/src/Security/AccessTokenProvider.hs +++ b/src/Security/AccessTokenProvider.hs @@ -1,19 +1,21 @@ module Security.AccessTokenProvider ( new , newWithProviders - , providerProbeFile - , providerProbeFixed - , providerProbeRopcg - , MonadHttp(..) - , MonadFilesystem(..) - , MonadEnvironment(..) + , newWithBackend + , probeProviderFile + , probeProviderFixed + , probeProviderSimpleFixed + , probeProviderRopcg + , defaultProviders , AccessTokenName(..) , AccessTokenProvider(..) , AccessToken(..) + , AtpProbe(..) ) where import Security.AccessTokenProvider.Internal import Security.AccessTokenProvider.Internal.Providers.File import Security.AccessTokenProvider.Internal.Providers.Fixed import Security.AccessTokenProvider.Internal.Providers.OAuth2.Ropcg +import Security.AccessTokenProvider.Internal.Providers.SimpleFixed import Security.AccessTokenProvider.Internal.Types diff --git a/src/Security/AccessTokenProvider/Internal.hs b/src/Security/AccessTokenProvider/Internal.hs --- a/src/Security/AccessTokenProvider/Internal.hs +++ b/src/Security/AccessTokenProvider/Internal.hs @@ -3,53 +3,151 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} module Security.AccessTokenProvider.Internal where +import Control.Arrow import Control.Exception.Safe import Control.Monad.IO.Unlift +import Data.ByteString (ByteString) +import qualified Data.ByteString as ByteString import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NonEmpty -import Katip +import Data.Monoid +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Katip as Katip +import Network.HTTP.Client +import Network.HTTP.Client.TLS +import qualified System.Environment as Env +import Say import Security.AccessTokenProvider.Internal.Providers.File import Security.AccessTokenProvider.Internal.Providers.Fixed import Security.AccessTokenProvider.Internal.Providers.OAuth2.Ropcg import Security.AccessTokenProvider.Internal.Types +import Security.AccessTokenProvider.Internal.Types.Severity +import Security.AccessTokenProvider.Internal.Util -namespace :: Namespace +import Security.AccessTokenProvider.Internal.Types.Severity (Severity) + +namespace :: Text namespace = "access-token-provider" +-- | Create a new access token provider, specifying backend and list +-- of providers. newWithProviders - :: (MonadThrow m, KatipContext m) - => NonEmpty (AtpProbe m) - -> AccessTokenName + :: MonadThrow m + => Backend m -- ^ Backend to use. + -> NonEmpty (AtpProbe m) -- ^ List of providers to use. + -> AccessTokenName -- ^ Name of the access token to create a + -- provider for. -> m (AccessTokenProvider m t) -newWithProviders providers tokenName = katipAddNamespace namespace $ - probeProviders (NonEmpty.toList providers) +newWithProviders backend providers tokenName = do + let BackendLog { .. } = backendLog backend + logAddNamespace namespace $ + probeProviders (NonEmpty.toList providers) where probeProviders [] = throwM $ AccessTokenProviderMissing tokenName probeProviders (AtpProbe tryProvider : rest) = do - maybeProvider <- tryProvider tokenName + maybeProvider <- tryProvider backend tokenName case maybeProvider of Nothing -> probeProviders rest Just provider -> pure provider +-- | Create a new access token provider using the default IO-based +-- backend and the default providers. new - :: ( KatipContext m - , MonadUnliftIO m - , MonadMask m - , MonadEnvironment m - , MonadFilesystem m - , MonadHttp m) - => AccessTokenName -> m (AccessTokenProvider m t) -new = newWithProviders providers + :: (MonadUnliftIO m, MonadMask m) + => AccessTokenName -- ^ Name of the access token to create a + -- provider for. + -> m (AccessTokenProvider m t) +new = newWithProviders backendIO defaultProviders - where providers = - AtpProbe providerProbeFixed - :| [ AtpProbe providerProbeFile - , AtpProbe providerProbeRopcg ] +-- | List of default providers: Fixed (environment) provider, +-- file-based provider, OAuth2 +-- Resource-Owner-Password-Credentials-Grant provider. +defaultProviders :: (MonadUnliftIO m, MonadMask m) + => NonEmpty (AtpProbe m) +defaultProviders = + probeProviderFixed :| [ probeProviderFile, probeProviderRopcg ] + +httpBackendIO :: MonadIO m => BackendHttp m +httpBackendIO = + BackendHttp { httpRequestExecute = httpRequestExecuteIO } + where httpRequestExecuteIO :: MonadIO m => Request -> m (Response LazyByteString) + httpRequestExecuteIO request = do + manager <- liftIO getGlobalManager + liftIO $ httpLbs request manager + +envBackendIO :: MonadIO m => BackendEnv m +envBackendIO = + BackendEnv { envLookup = envLookupIO } + + where envLookupIO :: MonadIO m => Text -> m (Maybe Text) + envLookupIO = + Text.unpack + >>> Env.lookupEnv + >>> fmap (fmap Text.pack) + >>> liftIO + +filesystemBackendIO :: MonadIO m => BackendFilesystem m +filesystemBackendIO = + BackendFilesystem { fileRead = fileReadIO } + where fileReadIO :: MonadIO m => FilePath -> m ByteString + fileReadIO = liftIO . ByteString.readFile + +logBackendIO :: MonadIO m => BackendLog m +logBackendIO = + BackendLog { logAddNamespace = \ _namespace -> id + , logMsg = logMsgIO + } + where logMsgIO :: MonadIO m => Severity -> Text -> m () + logMsgIO severity msg = + say $ "[" <> tshow severity <> "] " <> msg + +logBackendKatip :: Katip.KatipContext m => BackendLog m +logBackendKatip = + BackendLog { logAddNamespace = \ nspace -> + Katip.katipAddNamespace (Katip.Namespace [nspace]) + , logMsg = \ severity msg -> + Katip.logFM (toKatipSeverity severity) (Katip.ls msg) + } + +-- | IO based backend using simple stdout logging via 'say'. +backendIO :: MonadIO m => Backend m +backendIO = Backend + { backendHttp = httpBackendIO + , backendEnv = envBackendIO + , backendFilesystem = filesystemBackendIO + , backendLog = logBackendIO + } + +-- | IO based backend using Katip for logging. +backendIOWithKatip :: Katip.KatipContext m => Backend m +backendIOWithKatip = + backendIO { backendLog = logBackendKatip } + +toKatipSeverity :: Severity -> Katip.Severity +toKatipSeverity severity = + case severity of + Debug -> Katip.DebugS + Info -> Katip.InfoS + Warning -> Katip.WarningS + Error -> Katip.ErrorS + Alert -> Katip.AlertS + +-- | Create a new access token provider, specifying the backend to +-- use, using the default providers. +newWithBackend + :: (MonadUnliftIO m, MonadMask m) + => Backend m -- ^ Backend to ue. + -> AccessTokenName -- ^ Name of the access token to create a + -- provider for. + -> m (AccessTokenProvider m t) +newWithBackend backend = newWithProviders backend defaultProviders diff --git a/src/Security/AccessTokenProvider/Internal/Providers/Common.hs b/src/Security/AccessTokenProvider/Internal/Providers/Common.hs deleted file mode 100644 --- a/src/Security/AccessTokenProvider/Internal/Providers/Common.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Security.AccessTokenProvider.Internal.Providers.Common - ( tryNewProvider - , tryEnvDeserialization - ) where - -import Control.Exception.Safe -import Control.Lens -import Control.Monad.IO.Class -import Control.Monad.Trans.Class -import Control.Monad.Trans.Maybe -import Data.Aeson -import Data.Aeson.Lens -import Data.Format -import Data.List.NonEmpty (NonEmpty) -import qualified Data.List.NonEmpty as NonEmpty -import Data.Text (Text) -import qualified Data.Text.Encoding as Text -import Katip - -import Security.AccessTokenProvider.Internal.Types -import Security.AccessTokenProvider.Internal.Util - -tryNewProvider - :: (MonadIO m, MonadThrow m, KatipContext m) - => AccessTokenName - -> m (Maybe envConf) - -> (envConf -> m conf) - -> (AccessTokenName -> conf -> m (Maybe (AccessTokenProvider m t))) - -> m (Maybe (AccessTokenProvider m t)) -tryNewProvider tokenName makeEnvConf makeConf providerBuilder = do - maybeEnvConf <- makeEnvConf - case maybeEnvConf of - Just envConf -> do - conf <- makeConf envConf - providerBuilder tokenName conf - Nothing -> - pure Nothing - -atpConfVarName :: Text -atpConfVarName = "ATP_CONF" - -tryEnvDeserialization - :: ( MonadThrow m - , MonadEnvironment m - , FromJSON a - , KatipContext m ) - => NonEmpty Text - -> m (Maybe a) -tryEnvDeserialization providers = do - maybeConf <- runMaybeT $ do - envVal <- MaybeT $ environmentLookup atpConfVarName - jsonVal :: Value <- lift $ throwDecode (Text.encodeUtf8 envVal) - provider <- MaybeT . pure $ jsonVal ^? key "provider" . _String - logFM DebugS (ls [fmt|ATP_CONF requests AccessTokenProvider '${provider}'|]) - if provider `elem` providers - then do logFM InfoS (ls [fmt|Using AccessTokenProvider '${NonEmpty.head providers}'|]) - pure jsonVal - else MaybeT (pure Nothing) - case maybeConf of - Just conf -> - Just <$> throwDecodeValue conf - Nothing -> - pure Nothing diff --git a/src/Security/AccessTokenProvider/Internal/Providers/File.hs b/src/Security/AccessTokenProvider/Internal/Providers/File.hs --- a/src/Security/AccessTokenProvider/Internal/Providers/File.hs +++ b/src/Security/AccessTokenProvider/Internal/Providers/File.hs @@ -2,92 +2,89 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} module Security.AccessTokenProvider.Internal.Providers.File - ( providerProbeFile + ( probeProviderFile ) where -import Control.Applicative import Control.Exception.Safe import Control.Lens import Control.Monad.IO.Unlift import Data.Format -import Data.List.NonEmpty (NonEmpty (..)) -import qualified Data.Map as Map +import qualified Data.Map as Map import Data.Maybe -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import Katip +import qualified Data.Text.Encoding as Text import UnliftIO.STM -import qualified Security.AccessTokenProvider.Internal.Lenses as L -import Security.AccessTokenProvider.Internal.Providers.Common +import qualified Security.AccessTokenProvider.Internal.Lenses as L import Security.AccessTokenProvider.Internal.Types +import qualified Security.AccessTokenProvider.Internal.Types.Severity as Severity +import Security.AccessTokenProvider.Internal.Util -providerProbeFile - :: ( KatipContext m - , MonadFilesystem m - , MonadCatch m - , MonadEnvironment m - , MonadUnliftIO m ) - => AccessTokenName -> m (Maybe (AccessTokenProvider m t)) -providerProbeFile tokenName = katipAddNamespace "probe-file" $ - tryNewProvider tokenName makeConf pure createFilePathTokenProvider +-- | Access Token Provider prober for file based access token +-- retrieval. +probeProviderFile :: (MonadUnliftIO m, MonadCatch m) => AtpProbe m +probeProviderFile = AtpProbe probeProvider - where makeConf = do - maybeTokenFile <- fmap Text.unpack <$> environmentLookup "TOKEN_FILE" - case maybeTokenFile of - Just tokenFile -> - pure . Just $ AtpConfFile { _tokens = Just Map.empty - , _token = Just tokenFile } - Nothing -> - tryEnvDeserialization ("file" :| []) +probeProvider + :: (MonadCatch m, MonadUnliftIO m) + => Backend m + -> AccessTokenName + -> m (Maybe (AccessTokenProvider m t)) +probeProvider backend tokenName = do + let BackendLog { .. } = backendLog backend + BackendEnv { .. } = backendEnv backend + logAddNamespace "probe-file" $ do + envLookup "ATP_CONF_FILE" >>= \ case + Just confS -> do + logMsg Severity.Info [fmt|Trying access token provider 'file'|] + throwDecode (Text.encodeUtf8 confS) >>= tryCreateProvider backend tokenName + Nothing -> + pure Nothing -createFilePathTokenProvider - :: ( KatipContext m - , MonadFilesystem m - , MonadUnliftIO m - , MonadCatch m ) - => AccessTokenName +tryCreateProvider + :: (MonadUnliftIO m, MonadCatch m) + => Backend m + -> AccessTokenName -> AtpConfFile -> m (Maybe (AccessTokenProvider m t)) -createFilePathTokenProvider (AccessTokenName tokenName) conf = do - let tokenFileMap = fromMaybe Map.empty (conf ^. L.tokens) - maybeTokenFile = Map.lookup tokenName tokenFileMap <|> (conf^.L.token) - - case maybeTokenFile of +tryCreateProvider backend (AccessTokenName tokenName) conf = do + let BackendLog { .. } = backendLog backend + tokenFileMap = fromMaybe Map.empty (conf ^. L.tokens) + case Map.lookup tokenName tokenFileMap of Just filename -> do - logFM InfoS (ls [fmt|AccessTokenProvider starting|]) + logMsg Severity.Info [fmt|AccessTokenProvider starting|] provider <- newProvider filename pure (Just provider) Nothing -> pure Nothing where newProvider filename = do - readAction <- newReadAction filename + readAction <- newReadAction backend filename pure AccessTokenProvider { retrieveAccessToken = readAction , releaseProvider = pure () } newReadAction - :: ( MonadFilesystem m - , MonadUnliftIO m - , MonadCatch m - , KatipContext m ) - => FilePath + :: (MonadUnliftIO m, MonadCatch m) + => Backend m + -> FilePath -> m (m (AccessToken t)) -newReadAction filename = do +newReadAction backend filename = do + let fsBackend = backendFilesystem backend + BackendLog { .. } = backendLog backend cache <- atomically $ newTVar (Left (toException AccessTokenProviderTokenMissing)) pure $ - tryAny (fileRead filename) >>= \ case + tryAny (fileRead fsBackend filename) >>= \ case Right bytes -> do liftIO . atomically $ writeTVar cache (Right bytes) pure (AccessToken (Text.decodeUtf8 bytes)) Left exn -> do - logFM ErrorS (ls [fmt|Failed to read token file '${filename}': $exn|]) + logMsg Severity.Error [fmt|Failed to read token file '${filename}': $exn|] liftIO (atomically (readTVar cache)) >>= \ case Right bytes -> do - logFM WarningS (ls [fmt|Using cached token from '${filename}'|]) + logMsg Severity.Warning [fmt|Using cached token from '${filename}'|] pure (AccessToken (Text.decodeUtf8 bytes)) Left _exn -> throwM exn -- Return newer exception. diff --git a/src/Security/AccessTokenProvider/Internal/Providers/Fixed.hs b/src/Security/AccessTokenProvider/Internal/Providers/Fixed.hs --- a/src/Security/AccessTokenProvider/Internal/Providers/Fixed.hs +++ b/src/Security/AccessTokenProvider/Internal/Providers/Fixed.hs @@ -1,51 +1,60 @@ {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} module Security.AccessTokenProvider.Internal.Providers.Fixed - ( providerProbeFixed + ( probeProviderFixed ) where -import Control.Applicative import Control.Exception.Safe import Control.Lens import Control.Monad.IO.Class import Data.Format -import Data.List.NonEmpty (NonEmpty (..)) -import qualified Data.Map as Map +import qualified Data.Map as Map import Data.Maybe -import Katip +import qualified Data.Text.Encoding as Text -import qualified Security.AccessTokenProvider.Internal.Lenses as L -import Security.AccessTokenProvider.Internal.Providers.Common +import qualified Security.AccessTokenProvider.Internal.Lenses as L import Security.AccessTokenProvider.Internal.Types +import qualified Security.AccessTokenProvider.Internal.Types.Severity as Severity +import Security.AccessTokenProvider.Internal.Util -providerProbeFixed - :: (KatipContext m, MonadIO m, MonadThrow m, MonadEnvironment m) - => AccessTokenName - -> m (Maybe (AccessTokenProvider m t)) -providerProbeFixed tokenName = katipAddNamespace "probe-fixed" $ - tryNewProvider tokenName makeEnvConf pure createEnvTokenProvider +-- | Access Token Provider prober for environment based access token +-- retrieval. +probeProviderFixed :: (MonadIO m, MonadCatch m) => AtpProbe m +probeProviderFixed = AtpProbe probeProvider - where makeEnvConf = do - maybeToken <- environmentLookup "TOKEN" - case maybeToken of - Just token -> pure . Just $ AtpConfFixed { _tokens = Just Map.empty - , _token = Just token } - Nothing -> tryEnvDeserialization ("fixed" :| []) +probeProvider + :: (MonadIO m, MonadThrow m) + => Backend m + -> AccessTokenName + -> m (Maybe (AccessTokenProvider m t)) +probeProvider backend tokenName = do + let BackendLog { .. } = backendLog backend + BackendEnv { .. } = backendEnv backend + logAddNamespace "probe-fixed" $ do + envLookup "ATP_CONF_FIXED" >>= \ case + Just confS -> do + logMsg Severity.Info [fmt|Trying access token provider 'fixed'|] + throwDecode (Text.encodeUtf8 confS) >>= tryCreateProvider backend tokenName + Nothing -> + pure Nothing -createEnvTokenProvider - :: (KatipContext m, MonadEnvironment m) - => AccessTokenName +tryCreateProvider + :: Monad m + => Backend m + -> AccessTokenName -> AtpConfFixed -> m (Maybe (AccessTokenProvider m t)) -createEnvTokenProvider (AccessTokenName tokenName) conf = - let tokensMap = fromMaybe Map.empty (conf^.L.tokens) - maybeToken = (conf^.L.token) <|> Map.lookup tokenName tokensMap - in case maybeToken of +tryCreateProvider backend (AccessTokenName tokenName) conf = + let BackendLog { .. } = backendLog backend + tokensMap = fromMaybe Map.empty (conf^.L.tokens) + in case Map.lookup tokenName tokensMap of Just token -> do - logFM InfoS (ls [fmt|AccessTokenProvider started|]) + logMsg Severity.Info [fmt|AccessTokenProvider started|] pure . Just $ AccessTokenProvider { retrieveAccessToken = pure (AccessToken token) , releaseProvider = pure () diff --git a/src/Security/AccessTokenProvider/Internal/Providers/OAuth2/Ropcg.hs b/src/Security/AccessTokenProvider/Internal/Providers/OAuth2/Ropcg.hs --- a/src/Security/AccessTokenProvider/Internal/Providers/OAuth2/Ropcg.hs +++ b/src/Security/AccessTokenProvider/Internal/Providers/OAuth2/Ropcg.hs @@ -2,60 +2,64 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} module Security.AccessTokenProvider.Internal.Providers.OAuth2.Ropcg - ( providerProbeRopcg + ( probeProviderRopcg ) where -import Control.Applicative import Control.Exception.Safe import Control.Lens import Control.Monad import Control.Monad.IO.Class import Control.Monad.IO.Unlift import Data.Aeson -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Base64 as B64 import Data.Format -import Data.List.NonEmpty (NonEmpty (..)) -import qualified Data.Map as Map +import qualified Data.Map as Map import Data.Maybe import Data.Monoid -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import Katip +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text import Network.HTTP.Client import Network.HTTP.Client.TLS import Network.HTTP.Types -import qualified System.Environment as Env +import qualified System.Environment as Env import System.FilePath import System.Random import UnliftIO.Async import UnliftIO.Concurrent import UnliftIO.STM -import qualified Security.AccessTokenProvider.Internal.Lenses as L -import Security.AccessTokenProvider.Internal.Providers.Common +import qualified Security.AccessTokenProvider.Internal.Lenses as L import Security.AccessTokenProvider.Internal.Types +import qualified Security.AccessTokenProvider.Internal.Types.Severity as Severity import Security.AccessTokenProvider.Internal.Util -providerProbeRopcg - :: ( MonadMask m - , MonadUnliftIO m - , KatipContext m - , MonadEnvironment m - , MonadHttp m - , MonadFilesystem m ) - => AccessTokenName - -> m (Maybe (AccessTokenProvider m t)) -providerProbeRopcg tokenName = - tryNewProvider tokenName mkConf createRopcgConf - createTokenProviderResourceOwnerPasswordCredentials +-- | Access Token Provider prober for access token retrieval via +-- OAuth2 Resource-Owner-Password-Credentails-Grant. +probeProviderRopcg :: (MonadMask m, MonadUnliftIO m) => AtpProbe m +probeProviderRopcg = AtpProbe probeProvider - where mkConf = - tryEnvDeserialization - ("resource-owner-password-credentials-grant" :| ["ropcg"]) +probeProvider + :: (MonadMask m, MonadUnliftIO m) + => Backend m + -> AccessTokenName + -> m (Maybe (AccessTokenProvider m t)) +probeProvider backend tokenName = do + let BackendLog { .. } = backendLog backend + BackendEnv { .. } = backendEnv backend + logAddNamespace "probe-ropcg" $ do + envLookup "ATP_CONF_ROPCG" >>= \ case + Just confS -> do + logMsg Severity.Info [fmt|Trying access token provider 'ropcg'|] + throwDecode (Text.encodeUtf8 confS) + >>= createRopcgConf + >>= tryCreateProvider backend tokenName + Nothing -> + pure Nothing -- | Derive an authorization header from provided client credentials. makeBasicAuthorizationHeader @@ -69,29 +73,33 @@ in ("Authorization", "Basic " <> b64Token) retrieveJson - :: (MonadFilesystem m, KatipContext m, FromJSON a, MonadCatch m) - => FilePath + :: (FromJSON a, MonadCatch m) + => Backend m + -> FilePath -> m a -retrieveJson filename = do - content <- fileRead filename +retrieveJson backend filename = do + let fsBackend = backendFilesystem backend + BackendLog { .. } = backendLog backend + content <- fileRead fsBackend filename case eitherDecodeStrict content of Right a -> return a Left errMsgStr -> do let errMsg = Text.pack errMsgStr - logFM ErrorS (ls [fmt|JSON deserialization error: $errMsg|]) + logMsg Severity.Error [fmt|JSON deserialization error: $errMsg|] throwM . AccessTokenProviderDeserialization $ [fmt|Failed to deserialize '${filename}': $errMsg|] -- | Retrieve credentials from credentials directory. retrieveCredentials - :: (MonadFilesystem m, KatipContext m, MonadCatch m) - => AtpConfRopcg + :: MonadCatch m + => Backend m + -> AtpConfRopcg -> m Credentials -retrieveCredentials conf = do +retrieveCredentials backend conf = do let baseDir = conf^.L.credentialsDirectory - userCred <- retrieveJson + userCred <- retrieveJson backend (prefixIfRelative baseDir (conf^.L.resourceOwnerPasswordFile)) - clientCred <- retrieveJson + clientCred <- retrieveJson backend (prefixIfRelative baseDir (conf^.L.clientPasswordFile)) return Credentials { _user = userCred , _client = clientCred } @@ -101,18 +109,6 @@ then filename else baseDir filename -maskHttpRequest - :: Request - -> Request -maskHttpRequest req = - req { requestHeaders = maskHttpHeaders headers } - where headers = requestHeaders req - - maskHttpHeaders = map maskHttpHeader - - maskHttpHeader ("Authorization", _) = ("Authorization", "XXXXXXXXXXXXXXXX") - maskHttpHeader hdr = hdr - -- | Environment variable expected to contain the path to the mint -- credentials. envCredentialsDirectory :: String @@ -130,11 +126,11 @@ liftIO (fromMaybe "." <$> Env.lookupEnv envCredentialsDirectory) createRopcgConf - :: (KatipContext m, MonadIO m, MonadCatch m) + :: (MonadIO m, MonadCatch m) => AtpPreconfRopcg -> m AtpConfRopcg createRopcgConf envConf = do - authEndpoint <- parseEndpoint "authentication" (envConf^.L.authEndpoint) + authEndpoint <- parseEndpoint (envConf^.L.authEndpoint) credentialsDirectory <- retrieveCredentialsDir envConf let clientPasswordFile = fromMaybe defaultClientPasswordFile (envConf^.L.clientPasswordFile) @@ -151,27 +147,23 @@ , _authEndpoint = authEndpoint , _manager = manager , _tokens = envConf^.L.tokens - , _token = envConf^.L.token } where defaultResourceOwnerPasswordFile = "user.json" - defaultClientPasswordFile = "client.json" + defaultClientPasswordFile = "client.json" -- | Main refreshing function. tryRefreshToken - :: ( MonadCatch m - , KatipContext m - , MonadHttp m - , MonadFilesystem m ) - => AtpConfRopcg + :: MonadCatch m + => Backend m + -> AtpConfRopcg -> AccessTokenName -> AtpRopcgTokenDef -> m AtpRopcgResponse -tryRefreshToken conf tokenName tokenDef = - katipAddContext (sl "tokenName" tokenName) $ - katipAddNamespace "refreshActionOne" $ do - credentials <- retrieveCredentials conf - let manager = conf^.L.manager +tryRefreshToken backend conf tokenName tokenDef = + logAddNamespace "refreshActionOne" $ do + credentials <- retrieveCredentials backend conf + let httpBackend = backendHttp backend bodyParameters = [ ("grant_type", "password") , ("username", Text.encodeUtf8 (credentials^.L.user.L.applicationUsername)) @@ -181,25 +173,26 @@ httpRequest = (conf^.L.authEndpoint) { method = "POST" , requestHeaders = [authorization] } & urlEncodedBody bodyParameters - maskedRequest = Text.pack . show $ maskHttpRequest httpRequest - logFM DebugS (ls [fmt|HTTP Request for token refreshing: $maskedRequest|]) - response <- httpRequestExecute httpRequest manager + logMsg Severity.Debug [fmt|HTTP Request for token refreshing: ${tshow httpRequest}|] + response <- httpRequestExecute httpBackend httpRequest let status = responseStatus response body = responseBody response when (status /= ok200) $ do - logFM ErrorS (ls [fmt|Failed to refresh token: ${tshow response}|]) + logMsg Severity.Error [fmt|Failed to refresh token: ${tshow response}|] throwM $ decodeOAuth2Error status body case eitherDecode body :: Either String AtpRopcgResponse of Right tokenResponse -> do - logFM DebugS (ls [fmt|Successfully refreshed token '${tokenName}'|]) + logMsg Severity.Debug [fmt|Successfully refreshed token '${tokenName}'|] pure tokenResponse Left errMsgS -> do let errMsg = Text.pack errMsgS - logFM ErrorS (ls [fmt|Deserialization of token response failed: $errMsg|]) + logMsg Severity.Error [fmt|Deserialization of token response failed: $errMsg|] throwM $ AccessTokenProviderDeserialization errMsg where packScopes = ByteString.intercalate " " . map Text.encodeUtf8 + BackendLog { .. } = backendLog backend + decodeOAuth2Error status body = case decode body of Just problem -> @@ -209,17 +202,16 @@ [fmt|Deserialization of OAuth2 error object failed; response status: ${tshow status}'|] tokenRefreshLoop - :: ( MonadCatch m - , KatipContext m - , MonadHttp m - , MonadFilesystem m ) - => AtpConfRopcg + :: forall m t + . (MonadCatch m, MonadIO m) + => Backend m + -> AtpConfRopcg -> AccessTokenName -> AtpRopcgTokenDef -> TMVar (Either SomeException (AccessToken t)) -> m () -tokenRefreshLoop conf tokenName tokenDef cache = forever $ do - eitherTokenResponse <- tryAny (tryRefreshToken conf tokenName tokenDef) +tokenRefreshLoop backend conf tokenName tokenDef cache = forever $ do + eitherTokenResponse <- tryAny (tryRefreshToken backend conf tokenName tokenDef) atomically $ do let eitherToken = AccessToken . view L.accessToken <$> eitherTokenResponse isEmptyTMVar cache >>= \ case @@ -231,8 +223,7 @@ where -- Returns duration in seconds. computeDurationToWait - :: KatipContext m - => Either SomeException AtpRopcgResponse + :: Either SomeException AtpRopcgResponse -> m Double computeDurationToWait eitherTokenResponse = case eitherTokenResponse of @@ -243,9 +234,11 @@ Nothing -> pure defaultRefreshInterval Left exn -> do - logFM ErrorS (ls [fmt|Failed to refresh token '${tokenName}': $exn|]) + logMsg Severity.Error [fmt|Failed to refresh token '${tokenName}': $exn|] liftIO $ randomRIO (1, 10) -- Some jitter: wait 1 - 10 seconds. + BackendLog { .. } = backendLog backend + -- | In seconds. defaultRefreshInterval :: Double defaultRefreshInterval = 60 @@ -255,45 +248,39 @@ defaultRefreshTimeFactor :: Double defaultRefreshTimeFactor = 0.8 -createTokenProviderResourceOwnerPasswordCredentials - :: ( MonadUnliftIO m - , MonadMask m - , KatipContext m - , MonadHttp m - , MonadFilesystem m ) - => AccessTokenName +tryCreateProvider + :: (MonadUnliftIO m, MonadMask m) + => Backend m + -> AccessTokenName -> AtpConfRopcg -> m (Maybe (AccessTokenProvider m t)) -createTokenProviderResourceOwnerPasswordCredentials tokenName conf = do +tryCreateProvider backend tokenName conf = do let (AccessTokenName tokenNameText) = tokenName + BackendLog { .. } = backendLog backend maybeTokenDef = Map.lookup tokenNameText (conf^.L.tokens) - <|> (conf^.L.token) - case maybeTokenDef of Just tokenDef -> do - logFM InfoS (ls [fmt|AccessTokenProvider starting|]) + logMsg Severity.Info [fmt|AccessTokenProvider starting|] provider <- newProvider tokenDef pure (Just provider) Nothing -> pure Nothing where newProvider tokenDef = do - (retrieveAction, releaseAction) <- newRetrieveAction conf tokenName tokenDef + (retrieveAction, releaseAction) <- newRetrieveAction + backend conf tokenName tokenDef pure AccessTokenProvider { retrieveAccessToken = retrieveAction , releaseProvider = releaseAction } newRetrieveAction - :: ( KatipContext m - , MonadUnliftIO m - , MonadCatch m - , MonadHttp m - , MonadFilesystem m ) - => AtpConfRopcg + :: (MonadUnliftIO m, MonadCatch m) + => Backend m + -> AtpConfRopcg -> AccessTokenName -> AtpRopcgTokenDef -> m (m (AccessToken t), m ()) -newRetrieveAction conf tokenName tokenDef = do +newRetrieveAction backend conf tokenName tokenDef = do cache <- atomically newEmptyTMVar - asyncHandle <- async $ tokenRefreshLoop conf tokenName tokenDef cache + asyncHandle <- async $ tokenRefreshLoop backend conf tokenName tokenDef cache link asyncHandle pure $ do let retrieveAction = atomically (readTMVar cache) >>= \ case diff --git a/src/Security/AccessTokenProvider/Internal/Providers/SimpleFixed.hs b/src/Security/AccessTokenProvider/Internal/Providers/SimpleFixed.hs new file mode 100644 --- /dev/null +++ b/src/Security/AccessTokenProvider/Internal/Providers/SimpleFixed.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Security.AccessTokenProvider.Internal.Providers.SimpleFixed + ( probeProviderSimpleFixed + ) where + +import Control.Exception.Safe +import Control.Monad.IO.Class +import Data.Format + +import Security.AccessTokenProvider.Internal.Types +import qualified Security.AccessTokenProvider.Internal.Types.Severity as Severity + +-- | Access Token Provider prober for access token retrieval from the +-- @TOKEN@ environment retrieval. +probeProviderSimpleFixed :: (MonadIO m, MonadCatch m) => AtpProbe m +probeProviderSimpleFixed = AtpProbe probeProvider + +probeProvider + :: (MonadIO m, MonadThrow m) + => Backend m + -> AccessTokenName + -> m (Maybe (AccessTokenProvider m t)) +probeProvider backend tokenName = do + let BackendLog { .. } = backendLog backend + let BackendEnv { .. } = backendEnv backend + logAddNamespace "probe-simple-fixed" $ do + fmap AccessToken <$> envLookup "TOKEN" >>= \ case + Just accessToken -> do + logMsg Severity.Info [fmt|Trying access token provider 'simple-fixed'|] + tryCreateProvider backend tokenName accessToken + Nothing -> + pure Nothing + +tryCreateProvider + :: Monad m + => Backend m + -> AccessTokenName + -> AccessToken t + -> m (Maybe (AccessTokenProvider m t)) +tryCreateProvider backend _accessTokenName accessToken = do + let BackendLog { .. } = backendLog backend + logMsg Severity.Info [fmt|AccessTokenProvider started|] + pure . Just $ AccessTokenProvider + { retrieveAccessToken = pure accessToken + , releaseProvider = pure () + } diff --git a/src/Security/AccessTokenProvider/Internal/Types.hs b/src/Security/AccessTokenProvider/Internal/Types.hs --- a/src/Security/AccessTokenProvider/Internal/Types.hs +++ b/src/Security/AccessTokenProvider/Internal/Types.hs @@ -11,29 +11,23 @@ module Security.AccessTokenProvider.Internal.Types where -import Control.Arrow import Control.Exception -import Control.Monad.IO.Class -import Control.Monad.Reader -import Control.Monad.Trans.Maybe -import Control.Monad.Trans.State -import Data.Aeson +import Data.Aeson hiding + (Error) import Data.Aeson.Casing import Data.Aeson.TH -import Data.ByteString (ByteString) -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Lazy as ByteString.Lazy +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as ByteString.Lazy import Data.Format -import Data.Map.Strict (Map) +import Data.Map.Strict (Map) import Data.String -import Data.Text (Text) -import qualified Data.Text as Text +import Data.Text (Text) import Data.Typeable import GHC.Generics -import Katip import Network.HTTP.Client -import qualified System.Environment as Env +import Security.AccessTokenProvider.Internal.Types.Severity + type LazyByteString = ByteString.Lazy.ByteString data AccessTokenProvider (m :: * -> * ) t = @@ -54,14 +48,12 @@ data AtpConfFixed = AtpConfFixed { _tokens :: Maybe (Map Text Text) - , _token :: Maybe Text } deriving (Eq, Show, Generic) $(deriveJSON (aesonDrop 1 snakeCase) ''AtpConfFixed) data AtpConfFile = AtpConfFile { _tokens :: Maybe (Map Text FilePath) - , _token :: Maybe FilePath } deriving (Eq, Show, Generic) $(deriveJSON (aesonDrop 1 snakeCase) ''AtpConfFile) @@ -80,7 +72,6 @@ , _refreshTimeFactor :: Maybe Double , _authEndpoint :: Text , _tokens :: Map Text AtpRopcgTokenDef - , _token :: Maybe AtpRopcgTokenDef } deriving (Eq, Show, Generic) $(deriveJSON (aesonDrop 1 snakeCase) ''AtpPreconfRopcg) @@ -94,7 +85,6 @@ , _authEndpoint :: Request , _manager :: Manager , _tokens :: Map Text AtpRopcgTokenDef - , _token :: Maybe AtpRopcgTokenDef } deriving (Generic) -- | Type modelling the content of the credentials stored in a @@ -155,55 +145,28 @@ $(deriveJSON (aesonDrop 1 snakeCase) ''AtpRopcgResponse) newtype AtpProbe m = - AtpProbe (forall t. AccessTokenName -> m (Maybe (AccessTokenProvider m t)) ) - -class Monad m => MonadFilesystem m where - fileRead :: FilePath -> m ByteString - default fileRead :: (m ~ t n, MonadTrans t, MonadFilesystem n) => FilePath -> m ByteString - fileRead = lift . fileRead - -instance MonadFilesystem IO where - fileRead = ByteString.readFile - -instance MonadFilesystem m => MonadFilesystem (ReaderT r m) -instance MonadFilesystem m => MonadFilesystem (MaybeT m) -instance MonadFilesystem m => MonadFilesystem (KatipContextT m) -instance MonadFilesystem m => MonadFilesystem (KatipT m) -instance MonadFilesystem m => MonadFilesystem (StateT s m) - -class Monad m => MonadEnvironment m where - environmentLookup :: Text -> m (Maybe Text) - default environmentLookup :: (m ~ t n, MonadTrans t, MonadEnvironment n) - => Text - -> m (Maybe Text) - environmentLookup = lift . environmentLookup + AtpProbe (forall t. Backend m -> AccessTokenName -> m (Maybe (AccessTokenProvider m t)) ) -instance MonadEnvironment IO where - environmentLookup = - Text.unpack - >>> Env.lookupEnv - >>> liftIO - >>> fmap (fmap Text.pack) +data BackendHttp m = BackendHttp + { httpRequestExecute :: Request -> m (Response LazyByteString) + } -instance MonadEnvironment m => MonadEnvironment (ReaderT r m) -instance MonadEnvironment m => MonadEnvironment (MaybeT m) -instance MonadEnvironment m => MonadEnvironment (KatipContextT m) -instance MonadEnvironment m => MonadEnvironment (KatipT m) -instance MonadEnvironment m => MonadEnvironment (StateT s m) +data BackendEnv m = BackendEnv + { envLookup :: Text -> m (Maybe Text) + } -class Monad m => MonadHttp m where - httpRequestExecute :: Request -> Manager -> m (Response LazyByteString) - default httpRequestExecute :: (m ~ t n, MonadTrans t, MonadHttp n) - => Request - -> Manager - -> m (Response LazyByteString) - httpRequestExecute req manager = lift $ httpRequestExecute req manager +data BackendFilesystem m = BackendFilesystem + { fileRead :: FilePath -> m ByteString + } -instance MonadHttp IO where - httpRequestExecute = httpLbs +data BackendLog m = BackendLog + { logAddNamespace :: forall a. Text -> m a -> m a + , logMsg :: Severity -> Text -> m () + } -instance MonadHttp m => MonadHttp (ReaderT r m) -instance MonadHttp m => MonadHttp (MaybeT m) -instance MonadHttp m => MonadHttp (KatipContextT m) -instance MonadHttp m => MonadHttp (KatipT m) -instance MonadHttp m => MonadHttp (StateT s m) +data Backend m = Backend + { backendHttp :: BackendHttp m + , backendEnv :: BackendEnv m + , backendFilesystem :: BackendFilesystem m + , backendLog :: BackendLog m + } diff --git a/src/Security/AccessTokenProvider/Internal/Types/Severity.hs b/src/Security/AccessTokenProvider/Internal/Types/Severity.hs new file mode 100644 --- /dev/null +++ b/src/Security/AccessTokenProvider/Internal/Types/Severity.hs @@ -0,0 +1,9 @@ +module Security.AccessTokenProvider.Internal.Types.Severity where + +data Severity + = Debug + | Info + | Warning + | Error + | Alert + deriving (Eq, Ord, Enum, Show) diff --git a/src/Security/AccessTokenProvider/Internal/Util.hs b/src/Security/AccessTokenProvider/Internal/Util.hs --- a/src/Security/AccessTokenProvider/Internal/Util.hs +++ b/src/Security/AccessTokenProvider/Internal/Util.hs @@ -13,10 +13,8 @@ import Data.Aeson import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as ByteString.Lazy -import Data.Format import Data.Text (Text) import qualified Data.Text as Text -import Katip import Network.HTTP.Client import Security.AccessTokenProvider.Internal.Types @@ -38,13 +36,11 @@ throwM $ AccessTokenProviderDeserialization (Text.pack errMsg) parseEndpoint - :: (KatipContext m, MonadIO m, MonadCatch m) + :: (MonadIO m, MonadCatch m) => Text - -> Text -> m Request -parseEndpoint label endpoint = +parseEndpoint endpoint = parseRequest (Text.unpack endpoint) `catchAny` \ exn -> do - logFM ErrorS (ls [fmt|Failed to parse $label endpoint '${endpoint}': $exn|]) throwM exn tshow diff --git a/tests/Security/AccessTokenProvider/Internal/Providers/Test.hs b/tests/Security/AccessTokenProvider/Internal/Providers/Test.hs --- a/tests/Security/AccessTokenProvider/Internal/Providers/Test.hs +++ b/tests/Security/AccessTokenProvider/Internal/Providers/Test.hs @@ -11,18 +11,17 @@ import Control.Monad.IO.Class import qualified Data.ByteString.Lazy as ByteString.Lazy import Data.Format +import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map.Strict as Map -import qualified Data.Text as Text +import Data.Semigroup import qualified Data.Text.Encoding as Text import Data.UUID (UUID) -import Katip import Network.HTTP.Client.Internal import Network.HTTP.Types.Status import Network.HTTP.Types.Version import System.Random import Test.Tasty import Test.Tasty.HUnit -import UnliftIO.Concurrent import Security.AccessTokenProvider import qualified Security.AccessTokenProvider as ATP @@ -32,100 +31,86 @@ securityAccessTokenProviderInternalProvidersTest :: [TestTree] securityAccessTokenProviderInternalProvidersTest = [ testGroup "Security.AccessTokenProvider.Internal.Providers" - [ testCase "Fixed Provider reads from TOKEN" - fixedProviderReadsFromToken - , testCase "Fixed Provider reads from ATP_CONF" + [ testCase "SimpleFixed Provider reads from TOKEN" + simpleFixedProviderReadsFromToken + , testCase "Fixed Provider reads from ATP_CONF_FIXED" fixedProviderReadsFromConf - , testCase "Fixed Provider reads from ATP_CONF and lookup fails" + , testCase "Fixed Provider reads from ATP_CONF_FIXED and lookup fails" fixedProviderReadsFromConfLookupFails - , testCase "File Provider reads from TOKEN_FILE" - fileProviderReadsFromTokenFile - , testCase "File Provider reads from ATP_CONF" + , testCase "File Provider reads from ATP_CONF_FILE" fileProviderReadsFromConf - , testCase "File Provider reads from ATP_CONF and lookup fails" + , testCase "File Provider reads from ATP_CONF_FILE and lookup fails" fileProviderReadsFromConfLookupFails - , testCase "Ropcg Provider reads from ATP_CONF" + , testCase "Ropcg Provider reads from ATP_CONF_ROPCG" ropcgProviderReadsFromConf ] ] -fixedProviderReadsFromToken :: Assertion -fixedProviderReadsFromToken = do +simpleFixedProviderReadsFromToken :: Assertion +simpleFixedProviderReadsFromToken = do token <- tshow <$> (randomIO :: IO UUID) let testState = TestState { _testStateFilesystem = Map.empty , _testStateEnvironment = Map.fromList [ ("TOKEN", token) ] , _testStateHttpResponse = Nothing , _testStateHttpRequests = [] + , _testStateLog = [] } evalTestStack testState $ do - tokenProvider <- new (AccessTokenName "some-random-token-name") + tokenProvider <- newWithProviders mockBackend + (defaultProviders <> pure probeProviderSimpleFixed) + (AccessTokenName "some-random-token-name") (AccessToken token') <- retrieveAccessToken tokenProvider liftIO $ token @=? token' fixedProviderReadsFromConf :: Assertion fixedProviderReadsFromConf = do token <- tshow <$> (randomIO :: IO UUID) - let conf = [fmt|{"provider": "fixed", "tokens": {"label1": "$token"}}|] + let conf = [fmt|{"tokens": {"label1": "$token"}}|] testState = TestState { _testStateFilesystem = Map.empty - , _testStateEnvironment = Map.fromList [ ("ATP_CONF", conf) ] + , _testStateEnvironment = Map.fromList [ ("ATP_CONF_FIXED", conf) ] , _testStateHttpResponse = Nothing , _testStateHttpRequests = [] + , _testStateLog = [] } evalTestStack testState $ do - tokenProvider <- new (AccessTokenName "label1") + tokenProvider <- newWithBackend mockBackend (AccessTokenName "label1") (AccessToken token') <- retrieveAccessToken tokenProvider liftIO $ token @=? token' fixedProviderReadsFromConfLookupFails :: Assertion fixedProviderReadsFromConfLookupFails = do token <- tshow <$> (randomIO :: IO UUID) - let conf = [fmt|{"provider": "fixed", "tokens": {"label1": "$token"}}|] + let conf = [fmt|{"tokens": {"label1": "$token"}}|] testState = TestState { _testStateFilesystem = Map.empty - , _testStateEnvironment = Map.fromList [ ("ATP_CONF", conf) ] + , _testStateEnvironment = Map.fromList [ ("ATP_CONF_FIXED", conf) ] , _testStateHttpResponse = Nothing , _testStateHttpRequests = [] + , _testStateLog = [] } evalTestStack testState $ do - Left _ <- tryAny $ new (AccessTokenName "label2") + Left _ <- tryAny $ newWithBackend mockBackend (AccessTokenName "label2") pure () -fileProviderReadsFromTokenFile :: Assertion -fileProviderReadsFromTokenFile = do - tokenText <- tshow <$> (randomIO :: IO UUID) - let tokenBytes = Text.encodeUtf8 tokenText - filename = "/a/b/c" - testState = TestState - { _testStateFilesystem = - Map.fromList [ (filename, tokenBytes) ] - , _testStateEnvironment = - Map.fromList [ ("TOKEN_FILE", Text.pack filename) ] - , _testStateHttpResponse = Nothing - , _testStateHttpRequests = [] - } - evalTestStack testState $ do - tokenProvider <- new (AccessTokenName "some-random-token-name") - (AccessToken token') <- retrieveAccessToken tokenProvider - liftIO $ tokenText @=? token' - fileProviderReadsFromConf :: Assertion fileProviderReadsFromConf = do tokenText <- tshow <$> (randomIO :: IO UUID) let tokenBytes = Text.encodeUtf8 tokenText filename = "/a/b/c" - conf = [fmt|{"provider": "file", "tokens": {"label1": "$filename"}}|] + conf = [fmt|{"tokens": {"label1": "$filename"}}|] testState = TestState { _testStateFilesystem = Map.fromList [ (filename, tokenBytes) ] , _testStateEnvironment = - Map.fromList [ ("ATP_CONF", conf) ] + Map.fromList [ ("ATP_CONF_FILE", conf) ] , _testStateHttpResponse = Nothing , _testStateHttpRequests = [] + , _testStateLog = [] } evalTestStack testState $ do - tokenProvider <- new (AccessTokenName "label1") + tokenProvider <- newWithBackend mockBackend (AccessTokenName "label1") (AccessToken token') <- retrieveAccessToken tokenProvider liftIO $ tokenText @=? token' @@ -134,17 +119,18 @@ tokenText <- tshow <$> (randomIO :: IO UUID) let tokenBytes = Text.encodeUtf8 tokenText filename = "/a/b/c" - conf = [fmt|{"provider": "file", "tokens": {"label1": "$filename"}}|] + conf = [fmt|{"tokens": {"label1": "$filename"}}|] testState = TestState { _testStateFilesystem = Map.fromList [ (filename, tokenBytes) ] , _testStateEnvironment = - Map.fromList [ ("ATP_CONF", conf) ] + Map.fromList [ ("ATP_CONF_FILE", conf) ] , _testStateHttpResponse = Nothing , _testStateHttpRequests = [] + , _testStateLog = [] } evalTestStack testState $ do - Left _ <- tryAny $ new (AccessTokenName "label2") + Left _ <- tryAny $ newWithBackend mockBackend (AccessTokenName "label2") pure () ropcgProviderReadsFromConf :: Assertion @@ -155,7 +141,7 @@ "auth_endpoint": "https://localhost", "tokens": {"label1": {"scopes": ["foo"]}} }|] - responseBody = ByteString.Lazy.fromStrict . Text.encodeUtf8 $ + rspBody = ByteString.Lazy.fromStrict . Text.encodeUtf8 $ [fmt|{"scope": "foo", "expires_in": 60, "token_type": "test", @@ -164,7 +150,7 @@ response = Response { responseStatus = ok200 , responseVersion = http20 , responseHeaders = [] - , responseBody = responseBody + , responseBody = rspBody , responseCookieJar = CJ [] , responseClose' = ResponseClose (pure ()) } @@ -180,20 +166,21 @@ [ ("/credentials/user.json", userCredentials) , ("/credentials/client.json", clientCredentials) ] - , _testStateEnvironment = Map.fromList [ ("ATP_CONF", conf) ] + , _testStateEnvironment = Map.fromList [ ("ATP_CONF_ROPCG", conf) ] , _testStateHttpResponse = Just response , _testStateHttpRequests = [] + , _testStateLog = [] } (_, testState') <- runTestStack testState $ do - tokenProvider <- new (AccessTokenName "label1") + tokenProvider <- newWithBackend mockBackend (AccessTokenName "label1") (AccessToken token) <- retrieveAccessToken tokenProvider liftIO $ tokenText @=? token pure () 1 @=? length (testState'^.testStateHttpRequests) pure () -retrieveSomeToken :: KatipContextT IO () +retrieveSomeToken :: IO () retrieveSomeToken = do tokenProvider <- ATP.new (AccessTokenName "token-name") token <- ATP.retrieveAccessToken tokenProvider - liftIO $ print token + print token diff --git a/tests/Test.hs b/tests/Test.hs --- a/tests/Test.hs +++ b/tests/Test.hs @@ -14,53 +14,38 @@ 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 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.IORef -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map -import Data.Text (Text) -import Katip -import Katip.Monadic +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Text (Text) import Network.HTTP.Client -import System.IO -import UnliftIO.Exception import Security.AccessTokenProvider.Internal.Types +import Security.AccessTokenProvider.Internal.Types.Severity runTestStack :: TestState -> TestStack a -> IO (a, TestState) runTestStack testState m = do s <- newIORef testState a <- m & (_runTestStack - >>> runKatip >>> flip runReaderT s) (a,) <$> readIORef s -runKatip :: MonadUnliftIO m => KatipContextT m a -> m a -runKatip m = do - handleScribe <- liftIO $ mkHandleScribe ColorIfTerminal stdout WarningS V2 - let makeLogEnv = do - logEnv <- initLogEnv "test-suite" "test" - registerScribe "stdout" handleScribe defaultScribeSettings logEnv - bracket (liftIO makeLogEnv) (liftIO . closeScribes) $ \ logEnv -> do - let initialContext = () - let initialNamespace = "main" - runKatipContextT logEnv initialContext initialNamespace m - evalTestStack :: TestState -> TestStack a -> IO a evalTestStack testState m = do s <- newIORef testState m & (_runTestStack - >>> runKatip >>> flip runReaderT s) newtype TestStack a = TestStack - { _runTestStack :: KatipContextT (ReaderT (IORef TestState) IO) a + { _runTestStack :: ReaderT (IORef TestState) IO a } deriving ( Functor , Applicative , Monad @@ -69,8 +54,6 @@ , MonadMask , MonadReader (IORef TestState) , MonadIO - , Katip - , KatipContext ) instance MonadUnliftIO TestStack where @@ -83,6 +66,7 @@ , _testStateEnvironment :: Map Text Text , _testStateHttpRequests :: [Request] , _testStateHttpResponse :: Maybe (Response ByteString.Lazy.ByteString) + , _testStateLog :: [(Severity, Text)] } makeFieldsNoPrefix ''TestState @@ -95,23 +79,46 @@ envRef <- ask liftIO $ writeIORef envRef s -instance MonadEnvironment TestStack where - environmentLookup name = - Map.lookup name <$> gets (view testStateEnvironment) +mockBackend :: Backend TestStack +mockBackend = + Backend { backendHttp = mockBackendHttp + , backendEnv = mockBackendEnv + , backendFilesystem = mockBackendFilesystem + , backendLog = mockBackendLog + } -instance MonadFilesystem TestStack where - fileRead filename = do - fs <- gets (view testStateFilesystem) - case Map.lookup filename fs of - Just bytes -> pure bytes - _ -> error "FIXME: file not found" +mockBackendHttp :: BackendHttp TestStack +mockBackendHttp = + BackendHttp { httpRequestExecute = \ request -> do + testStateHttpRequests %= (request :) + maybeResponse <- gets (view testStateHttpResponse) + case maybeResponse of + Just response -> + pure response + Nothing -> + error "FIXME" + } -instance MonadHttp TestStack where - httpRequestExecute request _manager = do - testStateHttpRequests %= (request :) - maybeResponse <- gets (view testStateHttpResponse) - case maybeResponse of - Just response -> - pure response - Nothing -> - error "FIXME" +mockBackendEnv :: BackendEnv TestStack +mockBackendEnv = + BackendEnv { envLookup = \ name -> + Map.lookup name <$> gets (view testStateEnvironment) + } + +mockBackendFilesystem :: BackendFilesystem TestStack +mockBackendFilesystem = + BackendFilesystem { fileRead = \ filename -> do + fs <- gets (view testStateFilesystem) + case Map.lookup filename fs of + Just bytes -> + pure bytes + Nothing -> + error "FIXME: file not found" + } + +mockBackendLog :: BackendLog TestStack +mockBackendLog = + BackendLog { logAddNamespace = \ _namespace -> id + , logMsg = \ severity msg -> + modify (testStateLog %~ ((severity, msg) :)) + }