access-token-provider 0.1.0.0 → 0.1.1.0

raw patch · 14 files changed

+496/−452 lines, 14 filesdep +sayPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: say

API changes (from Hackage documentation)

Files

• README.md +19/−17
• access-token-provider.cabal +4/−2
• src/Security/AccessTokenProvider.hs +8/−6
• src/Security/AccessTokenProvider/Internal.hs +118/−20
• src/Security/AccessTokenProvider/Internal/Providers/Common.hs +0/−67
• src/Security/AccessTokenProvider/Internal/Providers/File.hs +45/−48
• src/Security/AccessTokenProvider/Internal/Providers/Fixed.hs +36/−27
• src/Security/AccessTokenProvider/Internal/Providers/OAuth2/Ropcg.hs +86/−99
• src/Security/AccessTokenProvider/Internal/Providers/SimpleFixed.hs +52/−0
• src/Security/AccessTokenProvider/Internal/Types.hs +28/−65
• src/Security/AccessTokenProvider/Internal/Types/Severity.hs +9/−0
• src/Security/AccessTokenProvider/Internal/Util.hs +2/−6
• tests/Security/AccessTokenProvider/Internal/Providers/Test.hs +38/−51
• tests/Test.hs +51/−44

@@ -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": "<OAuth2 authentication 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`.

@@ -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  

@@ -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

@@ -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

@@ -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

@@ -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.

@@ -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 ()

@@ -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

@@ -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 ()+    }

@@ -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+  }

@@ -0,0 +1,9 @@+module Security.AccessTokenProvider.Internal.Types.Severity where++data Severity+  = Debug+  | Info+  | Warning+  | Error+  | Alert+  deriving (Eq, Ord, Enum, Show)

@@ -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

@@ -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

@@ -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) :))+             }