{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes       #-}
module Bank.TrueLayer.Auth
  ( genAccessToken
  , swapCode
  , buildOAuth2
  , getAuthorizationUrl
  , RefreshToken(..)
  , AccessToken(..)
  , OAuth2Token(..)
  , OAuth2
  , ExchangeToken(..)
  , Env(..)
  , ClientId(..)
  , ClientSecret(..)
  ) where

import           Control.Monad.Except    (runExceptT)
import           Data.Bifunctor          (bimap)
import           Data.Text               (Text)
import           Data.Text.Encoding      (encodeUtf8)
import           Network.HTTP.Client     (newManager)
import           Network.HTTP.Client.TLS (tlsManagerSettings)
import           Network.OAuth.OAuth2
    ( AccessToken (..)
    , ExchangeToken (..)
    , OAuth2 (..)
    , OAuth2Token (..)
    , RefreshToken (..)
    , appendQueryParams
    , authorizationUrl
    , fetchAccessToken
    , refreshAccessToken
    )
import           URI.ByteString          (URI)
import           URI.ByteString.QQ       (uri)


newtype ClientId = ClientId Text
  deriving (Int -> ClientId -> ShowS
[ClientId] -> ShowS
ClientId -> String
(Int -> ClientId -> ShowS)
-> (ClientId -> String) -> ([ClientId] -> ShowS) -> Show ClientId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ClientId -> ShowS
showsPrec :: Int -> ClientId -> ShowS
$cshow :: ClientId -> String
show :: ClientId -> String
$cshowList :: [ClientId] -> ShowS
showList :: [ClientId] -> ShowS
Show)
newtype ClientSecret = ClientSecret Text
  deriving (Int -> ClientSecret -> ShowS
[ClientSecret] -> ShowS
ClientSecret -> String
(Int -> ClientSecret -> ShowS)
-> (ClientSecret -> String)
-> ([ClientSecret] -> ShowS)
-> Show ClientSecret
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ClientSecret -> ShowS
showsPrec :: Int -> ClientSecret -> ShowS
$cshow :: ClientSecret -> String
show :: ClientSecret -> String
$cshowList :: [ClientSecret] -> ShowS
showList :: [ClientSecret] -> ShowS
Show)

data Env = Sandbox | Prod


buildOAuth2 :: Env -> ClientId -> ClientSecret -> URI -> OAuth2
buildOAuth2 :: Env -> ClientId -> ClientSecret -> URI -> OAuth2
buildOAuth2 Env
env (ClientId Text
clientId) (ClientSecret Text
clientSecret) URI
callback =
  OAuth2 { oauth2ClientId :: Text
oauth2ClientId          = Text
clientId
         , oauth2ClientSecret :: Text
oauth2ClientSecret      = Text
clientSecret
         , oauth2AuthorizeEndpoint :: URI
oauth2AuthorizeEndpoint = Env -> URI
getAuthorizeEndpoint Env
env
         , oauth2TokenEndpoint :: URI
oauth2TokenEndpoint     = Env -> URI
getAccessTokenEndpoint Env
env
         , oauth2RedirectUri :: URI
oauth2RedirectUri       = URI
callback
         }


getAuthorizeEndpoint :: Env -> URI
getAuthorizeEndpoint :: Env -> URI
getAuthorizeEndpoint Env
Prod    = [uri|https://auth.truelayer.com|]
getAuthorizeEndpoint Env
Sandbox = [uri|https://auth.truelayer-sandbox.com|]


getAccessTokenEndpoint :: Env -> URI
getAccessTokenEndpoint :: Env -> URI
getAccessTokenEndpoint Env
Prod = [uri|https://auth.truelayer.com/connect/token|]
getAccessTokenEndpoint Env
Sandbox =
  [uri|https://auth.truelayer-sandbox.com/connect/token|]


getAuthorizationUrl :: OAuth2 -> [(Text, Text)] -> URI
getAuthorizationUrl :: OAuth2 -> [(Text, Text)] -> URI
getAuthorizationUrl OAuth2
oauth2Settings [(Text, Text)]
params = [(ByteString, ByteString)] -> URI -> URI
forall a. [(ByteString, ByteString)] -> URIRef a -> URIRef a
appendQueryParams
  [(ByteString, ByteString)]
bytestringParams
  (OAuth2 -> URI
authorizationUrl OAuth2
oauth2Settings)
  where bytestringParams :: [(ByteString, ByteString)]
bytestringParams = ((Text, Text) -> (ByteString, ByteString))
-> [(Text, Text)] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> ByteString)
-> (Text -> ByteString) -> (Text, Text) -> (ByteString, ByteString)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Text -> ByteString
encodeUtf8 Text -> ByteString
encodeUtf8) [(Text, Text)]
params


genAccessToken :: OAuth2 -> RefreshToken -> IO (Maybe OAuth2Token)
genAccessToken :: OAuth2 -> RefreshToken -> IO (Maybe OAuth2Token)
genAccessToken OAuth2
oauthSettings RefreshToken
token = do
  Manager
manager <- ManagerSettings -> IO Manager
newManager ManagerSettings
tlsManagerSettings
  Either TokenRequestError OAuth2Token
eToken  <- ExceptT TokenRequestError IO OAuth2Token
-> IO (Either TokenRequestError OAuth2Token)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (Manager
-> OAuth2
-> RefreshToken
-> ExceptT TokenRequestError IO OAuth2Token
forall (m :: * -> *).
MonadIO m =>
Manager
-> OAuth2
-> RefreshToken
-> ExceptT TokenRequestError m OAuth2Token
refreshAccessToken Manager
manager OAuth2
oauthSettings RefreshToken
token)
  Maybe OAuth2Token -> IO (Maybe OAuth2Token)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe OAuth2Token -> IO (Maybe OAuth2Token))
-> Maybe OAuth2Token -> IO (Maybe OAuth2Token)
forall a b. (a -> b) -> a -> b
$ case Either TokenRequestError OAuth2Token
eToken of
    Left  TokenRequestError
_ -> Maybe OAuth2Token
forall a. Maybe a
Nothing
    Right OAuth2Token
t -> OAuth2Token -> Maybe OAuth2Token
forall a. a -> Maybe a
Just OAuth2Token
t


swapCode :: OAuth2 -> ExchangeToken -> IO (Maybe OAuth2Token)
swapCode :: OAuth2 -> ExchangeToken -> IO (Maybe OAuth2Token)
swapCode OAuth2
oauthSettings ExchangeToken
code = do
  Manager
manager <- ManagerSettings -> IO Manager
newManager ManagerSettings
tlsManagerSettings
  Either TokenRequestError OAuth2Token
eToken  <- ExceptT TokenRequestError IO OAuth2Token
-> IO (Either TokenRequestError OAuth2Token)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (Manager
-> OAuth2
-> ExchangeToken
-> ExceptT TokenRequestError IO OAuth2Token
forall (m :: * -> *).
MonadIO m =>
Manager
-> OAuth2
-> ExchangeToken
-> ExceptT TokenRequestError m OAuth2Token
fetchAccessToken Manager
manager OAuth2
oauthSettings ExchangeToken
code)
  Maybe OAuth2Token -> IO (Maybe OAuth2Token)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe OAuth2Token -> IO (Maybe OAuth2Token))
-> Maybe OAuth2Token -> IO (Maybe OAuth2Token)
forall a b. (a -> b) -> a -> b
$ case Either TokenRequestError OAuth2Token
eToken of
    Left  TokenRequestError
_     -> Maybe OAuth2Token
forall a. Maybe a
Nothing
    Right OAuth2Token
token -> OAuth2Token -> Maybe OAuth2Token
forall a. a -> Maybe a
Just OAuth2Token
token