module Network.Payments.PayPal.Auth
( ClientID
, Secret
, Seconds
, AccessToken(..)
, AccessTokenWithExpiration
, AccessTokenError(..)
, AccessTokenResult
, fetchAccessToken
, fetchAccessTokenWithExpiration
, safeExpirationTime
) where
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
#endif
import Control.Exception
import Control.Lens
import Control.Monad
import Data.Aeson
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Text as T
import Data.Time.Clock
import qualified Network.HTTP.Client as HTTP
import Network.Wreq
import qualified Network.Wreq.Types as WTypes
import Network.Payments.PayPal.Environment
type ClientID = String
type Secret = String
type Seconds = Integer
data AccessToken = AccessToken
{ aTokenScope :: [String]
, aToken :: String
, aTokenType :: String
, aTokenAppId :: String
, aTokenExpires :: Seconds
} deriving (Eq, Show)
type AccessTokenWithExpiration = (AccessToken, UTCTime)
data AccessTokenError = AccessTokenHttpError HTTP.HttpException |
AccessTokenStatusError Int |
AccessTokenParseError String LBS.ByteString
type AccessTokenResult = Either AccessTokenError AccessToken
type AccessTokenWithExpirationResult =
Either AccessTokenError AccessTokenWithExpiration
instance FromJSON AccessToken where
parseJSON (Object obj) =
AccessToken <$>
(map T.unpack <$> T.split (== ' ') <$> (obj .: "scope")) <*>
obj .: "access_token" <*>
obj .: "token_type" <*>
obj .: "app_id" <*>
obj .: "expires_in"
parseJSON _ = mzero
fetchAccessToken :: EnvironmentUrl -> ClientID -> Secret -> IO AccessTokenResult
fetchAccessToken (EnvironmentUrl url) username password = do
let usernameBS = BS8.pack username
passwordBS = BS8.pack password
fullUrl = url ++ "/v1/oauth2/token"
options' = defaults & header "Accept" .~ ["application/json"] &
auth ?~ basicAuth usernameBS passwordBS
contentType = "application/x-www-form-urlencoded"
content = "grant_type=client_credentials"
payload = WTypes.Raw contentType $ HTTP.RequestBodyBS content
responseOrErr <- (try $ postWith options' fullUrl payload) ::
IO (Either HTTP.HttpException (Response LBS.ByteString))
case responseOrErr of
Left err -> return $ Left $ AccessTokenHttpError err
Right response ->
let statusCode' = response ^. responseStatus . statusCode
in if statusCode' == 200 then
let responseText = response ^. responseBody
in return $ case eitherDecode responseText of
Left errMsg -> Left $ AccessTokenParseError errMsg responseText
Right result -> Right result
else
return $ Left $ AccessTokenStatusError statusCode'
fetchAccessTokenWithExpiration :: EnvironmentUrl -> ClientID -> Secret ->
IO AccessTokenWithExpirationResult
fetchAccessTokenWithExpiration environment username password= do
currentTime <- getCurrentTime
accessTokenOrErr <- fetchAccessToken environment username password
let getExpire accToken = (accToken, safeExpirationTime currentTime accToken)
return $ either Left (Right . getExpire) accessTokenOrErr
safeExpirationTime :: UTCTime -> AccessToken -> UTCTime
safeExpirationTime currentTime token =
let safetyBuffer = 10
seconds = aTokenExpires token safetyBuffer
in addUTCTime (fromIntegral seconds) currentTime