{-# 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.Exception
import Data.Aeson hiding
(Error)
import Data.Aeson.Casing
import Data.Aeson.TH
import Data.ByteString (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 Data.Typeable
import GHC.Generics
import Network.HTTP.Client
import Security.AccessTokenProvider.Internal.Types.Severity
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)
} deriving (Eq, Show, Generic)
$(deriveJSON (aesonDrop 1 snakeCase) ''AtpConfFixed)
data AtpConfFile =
AtpConfFile { _tokens :: Maybe (Map Text 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
} 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
} deriving (Generic)
data ClientCredentials =
ClientCredentials { _clientId :: Text
, _clientSecret :: Text
} deriving (Generic, Show, Eq)
$(deriveJSON (aesonDrop 1 snakeCase) ''ClientCredentials)
data UserCredentials =
UserCredentials { _applicationUsername :: Text
, _applicationPassword :: Text
} deriving (Generic, Show, Eq)
$(deriveJSON (aesonDrop 1 snakeCase) ''UserCredentials)
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
data Credentials =
Credentials { _user :: UserCredentials
, _client :: ClientCredentials }
data AtpRopcgResponse =
AtpRopcgResponse { _scope :: Maybe Text
, _expiresIn :: Maybe Int
, _tokenType :: Text
, _accessToken :: Text
} deriving (Generic, Show, Eq)
$(deriveJSON (aesonDrop 1 snakeCase) ''AtpRopcgResponse)
newtype AtpProbe m =
AtpProbe (forall t. Backend m -> AccessTokenName -> m (Maybe (AccessTokenProvider m t)) )
data BackendHttp m = BackendHttp
{ httpRequestExecute :: Request -> m (Response LazyByteString)
}
data BackendEnv m = BackendEnv
{ envLookup :: Text -> m (Maybe Text)
}
data BackendFilesystem m = BackendFilesystem
{ fileRead :: FilePath -> m ByteString
}
data BackendLog m = BackendLog
{ logAddNamespace :: forall a. Text -> m a -> m a
, logMsg :: Severity -> Text -> m ()
}
data Backend m = Backend
{ backendHttp :: BackendHttp m
, backendEnv :: BackendEnv m
, backendFilesystem :: BackendFilesystem m
, backendLog :: BackendLog m
}