access-token-provider (empty) → 0.1.0.0
raw patch · 19 files changed
+1463/−0 lines, 19 filesdep +access-token-providerdep +aesondep +aeson-casingsetup-changed
Dependencies added: access-token-provider, aeson, aeson-casing, base, base64-bytestring, bytestring, containers, exceptions, filepath, http-client, http-client-tls, http-types, katip, lens, lens-aeson, mtl, random, safe-exceptions, stm, tasty, tasty-hunit, text, th-format, transformers, unliftio, unliftio-core, uuid
Files
- LICENSE +30/−0
- README.md +66/−0
- Setup.hs +2/−0
- access-token-provider.cabal +94/−0
- src/Security/AccessTokenProvider.hs +19/−0
- src/Security/AccessTokenProvider/Internal.hs +55/−0
- src/Security/AccessTokenProvider/Internal/Lenses.hs +21/−0
- src/Security/AccessTokenProvider/Internal/Providers/Common.hs +67/−0
- src/Security/AccessTokenProvider/Internal/Providers/File.hs +93/−0
- src/Security/AccessTokenProvider/Internal/Providers/Fixed.hs +54/−0
- src/Security/AccessTokenProvider/Internal/Providers/OAuth2/Ropcg.hs +303/−0
- src/Security/AccessTokenProvider/Internal/Types.hs +209/−0
- src/Security/AccessTokenProvider/Internal/Util.hs +54/−0
- tests/Security/AccessTokenProvider/Internal/Providers/Test.hs +199/−0
- tests/Security/AccessTokenProvider/Internal/Test.hs +16/−0
- tests/Security/AccessTokenProvider/Internal/Util/Test.hs +36/−0
- tests/Security/AccessTokenProvider/Test.hs +11/−0
- tests/Spec.hs +17/−0
- tests/Test.hs +117/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Moritz Clasmeier (c) 2018++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Moritz Schulte nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,66 @@+# 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.++## Examples++```haskell+import qualified Security.AccessTokenProvider as ATP++retrieveSomeToken :: KatipContextT IO ()+retrieveSomeToken = do+ tokenProvider <- ATP.new (AccessTokenName "token-name")+ token <- ATP.retrieveAccessToken tokenProvider+ liftIO $ print token+```++## Configuration++Configuration is done by setting the environment variable `ATP_CONF`.++### OAuth2 based token retrieval++For OAuth2 (Resource Owner Password Credentials Grant) provider, use:++```json+{+ "provider": "ropcg",+ "credentials_directory": "/optional/credentials/directory",+ "auth_endpoint": "<OAuth2 authentication endpoint>",+ "tokens": {"token-name": {"scopes": ["first-scope", "second-scope"]}}+}+```++The `credentials_directory` setting defaults to the content of the+environment variable `CREDENTIALS_DIR`. It is expected to contain the+files `user.json` and `client.json`, containing the user and client+credentials respectively.++### File based token retrieval (e.g. for Kubernetes)++```json+{+ "provider": "file",+ "tokens": {"token-name": "/some/file/name"}+}+```++As a short cut, you can simply save a token path directly in the+environment variable `TOKEN_FILE`.++### Environment based token retrieval (e.g. for testing)++```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`.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ access-token-provider.cabal view
@@ -0,0 +1,94 @@+name: access-token-provider+version: 0.1.0.0+synopsis: Provides Access Token for Services+description: 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.+homepage: https://github.com/mtesseract/access-token-provider#readme+license: BSD3+license-file: LICENSE+author: Moritz Clasmeier+maintainer: mtesseract@silverratio.net+copyright: (c) 2018 Moritz Clasmeier+category: Data+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10++library+ hs-source-dirs: src+ ghc-options: -Wall+ exposed-modules: Security.AccessTokenProvider+ , Security.AccessTokenProvider.Internal+ , Security.AccessTokenProvider.Internal.Types+ , Security.AccessTokenProvider.Internal.Lenses+ , Security.AccessTokenProvider.Internal.Util+ , Security.AccessTokenProvider.Internal.Providers.Common+ , Security.AccessTokenProvider.Internal.Providers.Fixed+ , Security.AccessTokenProvider.Internal.Providers.File+ , Security.AccessTokenProvider.Internal.Providers.OAuth2.Ropcg+ build-depends: base >= 4.7 && < 5+ , containers+ , text+ , bytestring+ , exceptions+ , aeson+ , http-types+ , aeson-casing+ , http-client+ , http-client-tls+ , unliftio-core+ , unliftio+ , katip+ , th-format >= 0.1.2.0+ , lens+ , lens-aeson+ , safe-exceptions+ , base64-bytestring+ , filepath+ , stm+ , mtl+ , transformers+ , random+ default-language: Haskell2010+++test-suite access-token-provider-test+ type: exitcode-stdio-1.0+ hs-source-dirs: tests+ main-is: Spec.hs+ other-modules: Security.AccessTokenProvider.Test+ , Security.AccessTokenProvider.Internal.Test+ , Security.AccessTokenProvider.Internal.Util.Test+ , Security.AccessTokenProvider.Internal.Providers.Test+ , Test+ build-depends: base+ , access-token-provider+ , aeson+ , text+ , tasty+ , tasty-hunit+ , katip+ , safe-exceptions+ , uuid+ , random+ , lens+ , containers+ , exceptions+ , bytestring+ , mtl+ , http-client+ , http-types+ , th-format+ , unliftio-core+ , unliftio+ , safe-exceptions+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ default-language: Haskell2010+ default-extensions: OverloadedStrings++source-repository head+ type: git+ location: https://github.com/mtesseract/access-token-provider
+ src/Security/AccessTokenProvider.hs view
@@ -0,0 +1,19 @@+module Security.AccessTokenProvider+ ( new+ , newWithProviders+ , providerProbeFile+ , providerProbeFixed+ , providerProbeRopcg+ , MonadHttp(..)+ , MonadFilesystem(..)+ , MonadEnvironment(..)+ , AccessTokenName(..)+ , AccessTokenProvider(..)+ , AccessToken(..)+ ) 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.Types
+ src/Security/AccessTokenProvider/Internal.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Security.AccessTokenProvider.Internal where++import Control.Exception.Safe+import Control.Monad.IO.Unlift+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NonEmpty+import Katip++import Security.AccessTokenProvider.Internal.Providers.File+import Security.AccessTokenProvider.Internal.Providers.Fixed+import Security.AccessTokenProvider.Internal.Providers.OAuth2.Ropcg+import Security.AccessTokenProvider.Internal.Types++namespace :: Namespace+namespace = "access-token-provider"++newWithProviders+ :: (MonadThrow m, KatipContext m)+ => NonEmpty (AtpProbe m)+ -> AccessTokenName+ -> m (AccessTokenProvider m t)+newWithProviders providers tokenName = katipAddNamespace namespace $+ probeProviders (NonEmpty.toList providers)++ where probeProviders [] =+ throwM $ AccessTokenProviderMissing tokenName+ probeProviders (AtpProbe tryProvider : rest) = do+ maybeProvider <- tryProvider tokenName+ case maybeProvider of+ Nothing ->+ probeProviders rest+ Just provider ->+ pure provider++new+ :: ( KatipContext m+ , MonadUnliftIO m+ , MonadMask m+ , MonadEnvironment m+ , MonadFilesystem m+ , MonadHttp m)+ => AccessTokenName -> m (AccessTokenProvider m t)+new = newWithProviders providers++ where providers =+ AtpProbe providerProbeFixed+ :| [ AtpProbe providerProbeFile+ , AtpProbe providerProbeRopcg ]
+ src/Security/AccessTokenProvider/Internal/Lenses.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Security.AccessTokenProvider.Internal.Lenses where++import Control.Lens++import Security.AccessTokenProvider.Internal.Types++makeFieldsNoPrefix ''AtpConfRopcg+makeFieldsNoPrefix ''AtpConfFile+makeFieldsNoPrefix ''AtpConfFixed+makeFieldsNoPrefix ''AtpPreconfRopcg+makeFieldsNoPrefix ''AtpRopcgTokenDef+makeFieldsNoPrefix ''ClientCredentials+makeFieldsNoPrefix ''UserCredentials+makeFieldsNoPrefix ''Credentials+makeFieldsNoPrefix ''AtpRopcgResponse
+ src/Security/AccessTokenProvider/Internal/Providers/Common.hs view
@@ -0,0 +1,67 @@+{-# 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
+ src/Security/AccessTokenProvider/Internal/Providers/File.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Security.AccessTokenProvider.Internal.Providers.File+ ( providerProbeFile+ ) 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 Data.Maybe+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import Katip+import UnliftIO.STM++import qualified Security.AccessTokenProvider.Internal.Lenses as L+import Security.AccessTokenProvider.Internal.Providers.Common+import Security.AccessTokenProvider.Internal.Types++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++ 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" :| [])++createFilePathTokenProvider+ :: ( KatipContext m+ , MonadFilesystem m+ , MonadUnliftIO m+ , MonadCatch 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+ Just filename -> do+ logFM InfoS (ls [fmt|AccessTokenProvider starting|])+ provider <- newProvider filename+ pure (Just provider)+ Nothing ->+ pure Nothing++ where newProvider filename = do+ readAction <- newReadAction filename+ pure AccessTokenProvider { retrieveAccessToken = readAction+ , releaseProvider = pure () }++newReadAction+ :: ( MonadFilesystem m+ , MonadUnliftIO m+ , MonadCatch m+ , KatipContext m )+ => FilePath+ -> m (m (AccessToken t))+newReadAction filename = do+ cache <- atomically $ newTVar (Left (toException AccessTokenProviderTokenMissing))+ pure $+ tryAny (fileRead 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|])+ liftIO (atomically (readTVar cache)) >>= \ case+ Right bytes -> do+ logFM WarningS (ls [fmt|Using cached token from '${filename}'|])+ pure (AccessToken (Text.decodeUtf8 bytes))+ Left _exn ->+ throwM exn -- Return newer exception.
+ src/Security/AccessTokenProvider/Internal/Providers/Fixed.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Security.AccessTokenProvider.Internal.Providers.Fixed+ ( providerProbeFixed+ ) 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 Data.Maybe+import Katip++import qualified Security.AccessTokenProvider.Internal.Lenses as L+import Security.AccessTokenProvider.Internal.Providers.Common+import Security.AccessTokenProvider.Internal.Types++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++ where makeEnvConf = do+ maybeToken <- environmentLookup "TOKEN"+ case maybeToken of+ Just token -> pure . Just $ AtpConfFixed { _tokens = Just Map.empty+ , _token = Just token }+ Nothing -> tryEnvDeserialization ("fixed" :| [])++createEnvTokenProvider+ :: (KatipContext m, MonadEnvironment 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+ Just token -> do+ logFM InfoS (ls [fmt|AccessTokenProvider started|])+ pure . Just $ AccessTokenProvider+ { retrieveAccessToken = pure (AccessToken token)+ , releaseProvider = pure ()+ }+ Nothing ->+ pure Nothing
+ src/Security/AccessTokenProvider/Internal/Providers/OAuth2/Ropcg.hs view
@@ -0,0 +1,303 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Security.AccessTokenProvider.Internal.Providers.OAuth2.Ropcg+ ( providerProbeRopcg+ ) 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 Data.Format+import Data.List.NonEmpty (NonEmpty (..))+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 Network.HTTP.Client+import Network.HTTP.Client.TLS+import Network.HTTP.Types+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 Security.AccessTokenProvider.Internal.Types+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++ where mkConf =+ tryEnvDeserialization+ ("resource-owner-password-credentials-grant" :| ["ropcg"])++-- | Derive an authorization header from provided client credentials.+makeBasicAuthorizationHeader+ :: ClientCredentials+ -> Header+makeBasicAuthorizationHeader credentials =+ let b64Token = [credentials^.L.clientId, credentials^.L.clientSecret]+ & map Text.encodeUtf8+ & ByteString.intercalate ":"+ & B64.encode+ in ("Authorization", "Basic " <> b64Token)++retrieveJson+ :: (MonadFilesystem m, KatipContext m, FromJSON a, MonadCatch m)+ => FilePath+ -> m a+retrieveJson filename = do+ content <- fileRead 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|])+ throwM . AccessTokenProviderDeserialization $+ [fmt|Failed to deserialize '${filename}': $errMsg|]++-- | Retrieve credentials from credentials directory.+retrieveCredentials+ :: (MonadFilesystem m, KatipContext m, MonadCatch m)+ => AtpConfRopcg+ -> m Credentials+retrieveCredentials conf = do+ let baseDir = conf^.L.credentialsDirectory+ userCred <- retrieveJson+ (prefixIfRelative baseDir (conf^.L.resourceOwnerPasswordFile))+ clientCred <- retrieveJson+ (prefixIfRelative baseDir (conf^.L.clientPasswordFile))+ return Credentials { _user = userCred+ , _client = clientCred }++ where prefixIfRelative baseDir filename =+ if isAbsolute filename+ 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+envCredentialsDirectory = "CREDENTIALS_DIR"++retrieveCredentialsDir+ :: (MonadIO m, MonadThrow m)+ => AtpPreconfRopcg+ -> m FilePath+retrieveCredentialsDir envConf =+ case envConf^.L.credentialsDirectory of+ Just dir ->+ pure dir+ Nothing ->+ liftIO (fromMaybe "." <$> Env.lookupEnv envCredentialsDirectory)++createRopcgConf+ :: (KatipContext m, MonadIO m, MonadCatch m)+ => AtpPreconfRopcg+ -> m AtpConfRopcg+createRopcgConf envConf = do+ authEndpoint <- parseEndpoint "authentication" (envConf^.L.authEndpoint)+ credentialsDirectory <- retrieveCredentialsDir envConf+ let clientPasswordFile = fromMaybe defaultClientPasswordFile+ (envConf^.L.clientPasswordFile)+ let resourceOwnerPasswordFile = fromMaybe defaultResourceOwnerPasswordFile+ (envConf^.L.resourceOwnerPasswordFile)+ let refreshTimeFactor = fromMaybe defaultRefreshTimeFactor+ (envConf^.L.refreshTimeFactor)+ manager <- liftIO $ newManager tlsManagerSettings+ pure AtpConfRopcg+ { _credentialsDirectory = credentialsDirectory+ , _clientPasswordFile = clientPasswordFile+ , _resourceOwnerPasswordFile = resourceOwnerPasswordFile+ , _refreshTimeFactor = refreshTimeFactor+ , _authEndpoint = authEndpoint+ , _manager = manager+ , _tokens = envConf^.L.tokens+ , _token = envConf^.L.token+ }++ where defaultResourceOwnerPasswordFile = "user.json"+ defaultClientPasswordFile = "client.json"++-- | Main refreshing function.+tryRefreshToken+ :: ( MonadCatch m+ , KatipContext m+ , MonadHttp m+ , MonadFilesystem 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+ bodyParameters =+ [ ("grant_type", "password")+ , ("username", Text.encodeUtf8 (credentials^.L.user.L.applicationUsername))+ , ("password", Text.encodeUtf8 (credentials^.L.user.L.applicationPassword))+ , ("scope", packScopes (tokenDef^.L.scopes)) ]+ authorization = makeBasicAuthorizationHeader (credentials^.L.client)+ 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+ let status = responseStatus response+ body = responseBody response+ when (status /= ok200) $ do+ logFM ErrorS (ls [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}'|])+ pure tokenResponse+ Left errMsgS -> do+ let errMsg = Text.pack errMsgS+ logFM ErrorS (ls [fmt|Deserialization of token response failed: $errMsg|])+ throwM $ AccessTokenProviderDeserialization errMsg++ where packScopes = ByteString.intercalate " " . map Text.encodeUtf8++ decodeOAuth2Error status body =+ case decode body of+ Just problem ->+ AccessTokenProviderRefreshFailure problem+ Nothing ->+ AccessTokenProviderDeserialization $+ [fmt|Deserialization of OAuth2 error object failed; response status: ${tshow status}'|]++tokenRefreshLoop+ :: ( MonadCatch m+ , KatipContext m+ , MonadHttp m+ , MonadFilesystem m )+ => AtpConfRopcg+ -> AccessTokenName+ -> AtpRopcgTokenDef+ -> TMVar (Either SomeException (AccessToken t))+ -> m ()+tokenRefreshLoop conf tokenName tokenDef cache = forever $ do+ eitherTokenResponse <- tryAny (tryRefreshToken conf tokenName tokenDef)+ atomically $ do+ let eitherToken = AccessToken . view L.accessToken <$> eitherTokenResponse+ isEmptyTMVar cache >>= \ case+ True -> putTMVar cache eitherToken+ False -> void $ swapTMVar cache eitherToken+ secondsToWait <- computeDurationToWait eitherTokenResponse+ let microsToWait = round $ secondsToWait * 10^(6 :: Int)+ threadDelay microsToWait++ where -- Returns duration in seconds.+ computeDurationToWait+ :: KatipContext m+ => Either SomeException AtpRopcgResponse+ -> m Double+ computeDurationToWait eitherTokenResponse =+ case eitherTokenResponse of+ Right tokenResponse ->+ case tokenResponse^.L.expiresIn of+ Just expiresIn ->+ pure $ conf^.L.refreshTimeFactor * fromIntegral expiresIn+ Nothing ->+ pure defaultRefreshInterval+ Left exn -> do+ logFM ErrorS (ls [fmt|Failed to refresh token '${tokenName}': $exn|])+ liftIO $ randomRIO (1, 10) -- Some jitter: wait 1 - 10 seconds.++-- | In seconds.+defaultRefreshInterval :: Double+defaultRefreshInterval = 60++-- | By default, we start refreshing tokens after 80% of the+-- "expires_in" time of a token has been elapsed.+defaultRefreshTimeFactor :: Double+defaultRefreshTimeFactor = 0.8++createTokenProviderResourceOwnerPasswordCredentials+ :: ( MonadUnliftIO m+ , MonadMask m+ , KatipContext m+ , MonadHttp m+ , MonadFilesystem m )+ => AccessTokenName+ -> AtpConfRopcg+ -> m (Maybe (AccessTokenProvider m t))+createTokenProviderResourceOwnerPasswordCredentials tokenName conf = do+ let (AccessTokenName tokenNameText) = tokenName+ maybeTokenDef = Map.lookup tokenNameText (conf^.L.tokens)+ <|> (conf^.L.token)++ case maybeTokenDef of+ Just tokenDef -> do+ logFM InfoS (ls [fmt|AccessTokenProvider starting|])+ provider <- newProvider tokenDef+ pure (Just provider)+ Nothing ->+ pure Nothing++ where newProvider tokenDef = do+ (retrieveAction, releaseAction) <- newRetrieveAction conf tokenName tokenDef+ pure AccessTokenProvider { retrieveAccessToken = retrieveAction+ , releaseProvider = releaseAction }+newRetrieveAction+ :: ( KatipContext m+ , MonadUnliftIO m+ , MonadCatch m+ , MonadHttp m+ , MonadFilesystem m )+ => AtpConfRopcg+ -> AccessTokenName+ -> AtpRopcgTokenDef+ -> m (m (AccessToken t), m ())+newRetrieveAction conf tokenName tokenDef = do+ cache <- atomically newEmptyTMVar+ asyncHandle <- async $ tokenRefreshLoop conf tokenName tokenDef cache+ link asyncHandle+ pure $ do+ let retrieveAction = atomically (readTMVar cache) >>= \ case+ Right token -> pure token+ Left exn -> throwM exn+ releaseAction = cancel asyncHandle+ (retrieveAction, releaseAction)
+ src/Security/AccessTokenProvider/Internal/Types.hs view
@@ -0,0 +1,209 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++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.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.Format+import Data.Map.Strict (Map)+import Data.String+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Typeable+import GHC.Generics+import Katip+import Network.HTTP.Client+import qualified System.Environment as Env++type LazyByteString = ByteString.Lazy.ByteString++data AccessTokenProvider (m :: * -> * ) t =+ AccessTokenProvider { retrieveAccessToken :: m (AccessToken t)+ , releaseProvider :: m () }++newtype AccessToken t =+ AccessToken { unAccessToken :: Text+ } deriving (Eq, Ord, Show)++newtype AccessTokenName = AccessTokenName Text+ deriving (Eq, Ord, Show, IsString)++$(deriveJSON defaultOptions ''AccessTokenName)++instance Format AccessTokenName where+ formatText (AccessTokenName tokenName) = tokenName++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)++newtype AtpRopcgTokenDef =+ AtpRopcgTokenDef { _scopes :: [Text]+ } deriving (Eq, Show, Generic)++$(deriveJSON (aesonDrop 1 snakeCase) ''AtpRopcgTokenDef)++data AtpPreconfRopcg =+ AtpPreconfRopcg+ { _credentialsDirectory :: Maybe FilePath+ , _clientPasswordFile :: Maybe FilePath+ , _resourceOwnerPasswordFile :: Maybe FilePath+ , _refreshTimeFactor :: Maybe Double+ , _authEndpoint :: Text+ , _tokens :: Map Text AtpRopcgTokenDef+ , _token :: Maybe AtpRopcgTokenDef+ } deriving (Eq, Show, Generic)++$(deriveJSON (aesonDrop 1 snakeCase) ''AtpPreconfRopcg)++data AtpConfRopcg =+ AtpConfRopcg+ { _credentialsDirectory :: FilePath+ , _clientPasswordFile :: FilePath+ , _resourceOwnerPasswordFile :: FilePath+ , _refreshTimeFactor :: Double+ , _authEndpoint :: Request+ , _manager :: Manager+ , _tokens :: Map Text AtpRopcgTokenDef+ , _token :: Maybe AtpRopcgTokenDef+ } deriving (Generic)++-- | Type modelling the content of the credentials stored in a+-- client.json file.+data ClientCredentials =+ ClientCredentials { _clientId :: Text+ , _clientSecret :: Text+ } deriving (Generic, Show, Eq)++$(deriveJSON (aesonDrop 1 snakeCase) ''ClientCredentials)+++-- | Type modelling the content of the credentials stored in a+-- user.json file.+data UserCredentials =+ UserCredentials { _applicationUsername :: Text+ , _applicationPassword :: Text+ } deriving (Generic, Show, Eq)++$(deriveJSON (aesonDrop 1 snakeCase) ''UserCredentials)++-- | Type for RFC7807 @Problem@ objects.+data OAuth2Error = OAuth2Error+ { oauth2Error :: Text+ , oauth2ErrorDescription :: Maybe Text+ , oauth2ErrorURI :: Maybe Text+ , oauth2ErrorState :: Maybe Text+ } deriving (Show, Eq, Generic)++instance ToJSON OAuth2Error where+ toJSON = genericToJSON $ aesonDrop 6 snakeCase+instance FromJSON OAuth2Error where+ parseJSON = genericParseJSON $ aesonDrop 6 snakeCase+++data AccessTokenProviderException+ = AccessTokenProviderRefreshFailure OAuth2Error+ | AccessTokenProviderDeserialization Text+ | AccessTokenProviderTokenMissing+ | AccessTokenProviderMissing AccessTokenName+ deriving (Typeable, Show)++instance Exception AccessTokenProviderException++-- | Type containing all credentials read from a mint credentials+-- directory.+data Credentials =+ Credentials { _user :: UserCredentials+ , _client :: ClientCredentials }++data AtpRopcgResponse =+ AtpRopcgResponse { _scope :: Maybe Text+ , _expiresIn :: Maybe Int -- Validity in seconds+ , _tokenType :: Text+ , _accessToken :: Text+ } deriving (Generic, Show, Eq)++$(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++instance MonadEnvironment IO where+ environmentLookup =+ Text.unpack+ >>> Env.lookupEnv+ >>> liftIO+ >>> fmap (fmap Text.pack)++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)++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++instance MonadHttp IO where+ httpRequestExecute = httpLbs++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)
+ src/Security/AccessTokenProvider/Internal/Util.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++module Security.AccessTokenProvider.Internal.Util+ ( throwDecode+ , tshow+ , parseEndpoint+ , throwDecodeValue+ ) where++import Control.Exception.Safe+import Control.Monad.IO.Class+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++throwDecode :: (MonadThrow m, FromJSON a) => ByteString -> m a+throwDecode bytes =+ case eitherDecode (ByteString.Lazy.fromStrict bytes) of+ Right a ->+ pure a+ Left errMsg ->+ throwM $ AccessTokenProviderDeserialization (Text.pack errMsg)++throwDecodeValue :: (MonadThrow m, FromJSON a) => Value -> m a+throwDecodeValue val =+ case fromJSON val of+ Success a ->+ pure a+ Error errMsg ->+ throwM $ AccessTokenProviderDeserialization (Text.pack errMsg)++parseEndpoint+ :: (KatipContext m, MonadIO m, MonadCatch m)+ => Text+ -> Text+ -> m Request+parseEndpoint label endpoint =+ parseRequest (Text.unpack endpoint) `catchAny` \ exn -> do+ logFM ErrorS (ls [fmt|Failed to parse $label endpoint '${endpoint}': $exn|])+ throwM exn++tshow+ :: Show a+ => a+ -> Text+tshow = Text.pack . show
+ tests/Security/AccessTokenProvider/Internal/Providers/Test.hs view
@@ -0,0 +1,199 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Security.AccessTokenProvider.Internal.Providers.Test+ ( securityAccessTokenProviderInternalProvidersTest+ ) where++import Control.Exception.Safe+import Control.Lens+import Control.Monad.IO.Class+import qualified Data.ByteString.Lazy as ByteString.Lazy+import Data.Format+import qualified Data.Map.Strict as Map+import qualified Data.Text as Text+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+import Security.AccessTokenProvider.Internal.Util+import Test++securityAccessTokenProviderInternalProvidersTest :: [TestTree]+securityAccessTokenProviderInternalProvidersTest =+ [ testGroup "Security.AccessTokenProvider.Internal.Providers"+ [ testCase "Fixed Provider reads from TOKEN"+ fixedProviderReadsFromToken+ , testCase "Fixed Provider reads from ATP_CONF"+ fixedProviderReadsFromConf+ , testCase "Fixed Provider reads from ATP_CONF and lookup fails"+ fixedProviderReadsFromConfLookupFails+ , testCase "File Provider reads from TOKEN_FILE"+ fileProviderReadsFromTokenFile+ , testCase "File Provider reads from ATP_CONF"+ fileProviderReadsFromConf+ , testCase "File Provider reads from ATP_CONF and lookup fails"+ fileProviderReadsFromConfLookupFails+ , testCase "Ropcg Provider reads from ATP_CONF"+ ropcgProviderReadsFromConf+ ]+ ]++fixedProviderReadsFromToken :: Assertion+fixedProviderReadsFromToken = do+ token <- tshow <$> (randomIO :: IO UUID)+ let testState = TestState+ { _testStateFilesystem = Map.empty+ , _testStateEnvironment = Map.fromList [ ("TOKEN", token) ]+ , _testStateHttpResponse = Nothing+ , _testStateHttpRequests = []+ }+ evalTestStack testState $ do+ tokenProvider <- new (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"}}|]+ testState = TestState+ { _testStateFilesystem = Map.empty+ , _testStateEnvironment = Map.fromList [ ("ATP_CONF", conf) ]+ , _testStateHttpResponse = Nothing+ , _testStateHttpRequests = []+ }+ evalTestStack testState $ do+ tokenProvider <- new (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"}}|]+ testState = TestState+ { _testStateFilesystem = Map.empty+ , _testStateEnvironment = Map.fromList [ ("ATP_CONF", conf) ]+ , _testStateHttpResponse = Nothing+ , _testStateHttpRequests = []+ }+ evalTestStack testState $ do+ Left _ <- tryAny $ new (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"}}|]+ testState = TestState+ { _testStateFilesystem =+ Map.fromList [ (filename, tokenBytes) ]+ , _testStateEnvironment =+ Map.fromList [ ("ATP_CONF", conf) ]+ , _testStateHttpResponse = Nothing+ , _testStateHttpRequests = []+ }+ evalTestStack testState $ do+ tokenProvider <- new (AccessTokenName "label1")+ (AccessToken token') <- retrieveAccessToken tokenProvider+ liftIO $ tokenText @=? token'++fileProviderReadsFromConfLookupFails :: Assertion+fileProviderReadsFromConfLookupFails = do+ tokenText <- tshow <$> (randomIO :: IO UUID)+ let tokenBytes = Text.encodeUtf8 tokenText+ filename = "/a/b/c"+ conf = [fmt|{"provider": "file", "tokens": {"label1": "$filename"}}|]+ testState = TestState+ { _testStateFilesystem =+ Map.fromList [ (filename, tokenBytes) ]+ , _testStateEnvironment =+ Map.fromList [ ("ATP_CONF", conf) ]+ , _testStateHttpResponse = Nothing+ , _testStateHttpRequests = []+ }+ evalTestStack testState $ do+ Left _ <- tryAny $ new (AccessTokenName "label2")+ pure ()++ropcgProviderReadsFromConf :: Assertion+ropcgProviderReadsFromConf = do+ tokenText <- tshow <$> (randomIO :: IO UUID)+ let conf = [fmt|{ "provider": "ropcg",+ "credentials_directory": "/credentials",+ "auth_endpoint": "https://localhost",+ "tokens": {"label1": {"scopes": ["foo"]}}+ }|]+ responseBody = ByteString.Lazy.fromStrict . Text.encodeUtf8 $+ [fmt|{"scope": "foo",+ "expires_in": 60,+ "token_type": "test",+ "access_token": "$tokenText"+ }|]+ response = Response { responseStatus = ok200+ , responseVersion = http20+ , responseHeaders = []+ , responseBody = responseBody+ , responseCookieJar = CJ []+ , responseClose' = ResponseClose (pure ())+ }+ userCredentials =+ "{ \"application_username\": \"some-application-username\", \+ \ \"application_password\": \"some-application-password\" }"+ clientCredentials =+ "{ \"client_id\": \"some-client-id\", \+ \ \"client_secret\": \"some-client-secret\" }"++ testState = TestState+ { _testStateFilesystem = Map.fromList+ [ ("/credentials/user.json", userCredentials)+ , ("/credentials/client.json", clientCredentials)+ ]+ , _testStateEnvironment = Map.fromList [ ("ATP_CONF", conf) ]+ , _testStateHttpResponse = Just response+ , _testStateHttpRequests = []+ }+ (_, testState') <- runTestStack testState $ do+ tokenProvider <- new (AccessTokenName "label1")+ (AccessToken token) <- retrieveAccessToken tokenProvider+ liftIO $ tokenText @=? token+ pure ()+ 1 @=? length (testState'^.testStateHttpRequests)+ pure ()++retrieveSomeToken :: KatipContextT IO ()+retrieveSomeToken = do+ tokenProvider <- ATP.new (AccessTokenName "token-name")+ token <- ATP.retrieveAccessToken tokenProvider+ liftIO $ print token
+ tests/Security/AccessTokenProvider/Internal/Test.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE OverloadedStrings #-}++module Security.AccessTokenProvider.Internal.Test+ ( securityAccessTokenProviderInternalTest+ ) where++import Security.AccessTokenProvider.Internal.Providers.Test+import Security.AccessTokenProvider.Internal.Util.Test+import Test.Tasty++securityAccessTokenProviderInternalTest :: [TestTree]+securityAccessTokenProviderInternalTest =+ [ testGroup "Security.AccessTokenProvider.Internal" $+ concat [ securityAccessTokenProviderInternalUtilTest+ , securityAccessTokenProviderInternalProvidersTest ]+ ]
+ tests/Security/AccessTokenProvider/Internal/Util/Test.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Security.AccessTokenProvider.Internal.Util.Test+ ( securityAccessTokenProviderInternalUtilTest+ ) where++import Control.Exception.Safe+import Data.Aeson (Value)+import Test.Tasty+import Test.Tasty.HUnit++import Security.AccessTokenProvider.Internal.Types+import Security.AccessTokenProvider.Internal.Util++securityAccessTokenProviderInternalUtilTest :: [TestTree]+securityAccessTokenProviderInternalUtilTest =+ [ testGroup "Security.AccessTokenProvider.Internal.Util"+ [ testCase "throwDecode throws on deserialization failure"+ throwDecodeThrowsDeserializationFailure+ , testCase "throwDecode deserializes JSON"+ throwDecodeDeserializes+ ]+ ]++throwDecodeThrowsDeserializationFailure :: Assertion+throwDecodeThrowsDeserializationFailure = do+ let bs = "[1, 2, 3}"+ Left _res :: Either AccessTokenProviderException [Int] <- try $ throwDecode bs+ pure ()++throwDecodeDeserializes :: Assertion+throwDecodeDeserializes = do+ let bs = "{\"numbers\": [1, 2, 3]}"+ _res :: Value <- throwDecode bs+ pure ()
+ tests/Security/AccessTokenProvider/Test.hs view
@@ -0,0 +1,11 @@+module Security.AccessTokenProvider.Test+ ( securityAccessTokenProviderTests+ ) where++import Security.AccessTokenProvider.Internal.Test+import Test.Tasty++securityAccessTokenProviderTests :: TestTree+securityAccessTokenProviderTests =+ testGroup "Security.AccessTokenProvider"+ securityAccessTokenProviderInternalTest
+ tests/Spec.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Test.Tasty++import Security.AccessTokenProvider.Test++main :: IO ()+main = do+ putStrLn ""+ defaultMain tests++tests :: TestTree+tests =+ testGroup "Access Token Provider Test Suite"+ [securityAccessTokenProviderTests]
+ tests/Test.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeSynonymInstances #-}+++module Test where++import Control.Arrow+import Control.Lens+import Control.Monad.Catch hiding (bracket)+import Control.Monad.IO.Class+import Control.Monad.IO.Unlift+import Control.Monad.Reader+import Control.Monad.State+import 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 Network.HTTP.Client+import System.IO+import UnliftIO.Exception++import Security.AccessTokenProvider.Internal.Types++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+ } deriving ( Functor+ , Applicative+ , Monad+ , MonadThrow+ , MonadCatch+ , MonadMask+ , MonadReader (IORef TestState)+ , MonadIO+ , Katip+ , KatipContext+ )++instance MonadUnliftIO TestStack where+ askUnliftIO = do+ (UnliftIO u) <- TestStack askUnliftIO+ pure $ UnliftIO (\ (TestStack m) -> u m)++data TestState =+ TestState { _testStateFilesystem :: Map FilePath ByteString+ , _testStateEnvironment :: Map Text Text+ , _testStateHttpRequests :: [Request]+ , _testStateHttpResponse :: Maybe (Response ByteString.Lazy.ByteString)+ }++makeFieldsNoPrefix ''TestState++instance MonadState TestState TestStack where+ get = do+ envRef <- ask+ liftIO $ readIORef envRef+ put s = do+ envRef <- ask+ liftIO $ writeIORef envRef s++instance MonadEnvironment TestStack where+ environmentLookup name =+ Map.lookup name <$> gets (view testStateEnvironment)++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"++instance MonadHttp TestStack where+ httpRequestExecute request _manager = do+ testStateHttpRequests %= (request :)+ maybeResponse <- gets (view testStateHttpResponse)+ case maybeResponse of+ Just response ->+ pure response+ Nothing ->+ error "FIXME"