summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--LICENSE20
-rw-r--r--Setup.hs2
-rw-r--r--paypal-rest-client.cabal55
-rw-r--r--src/Network/Payments/PayPal.hs151
-rw-r--r--src/Network/Payments/PayPal/Auth.hs128
-rw-r--r--src/Network/Payments/PayPal/Environment.hs24
-rw-r--r--src/Network/Payments/PayPal/Payments.hs294
-rw-r--r--src/Network/Payments/PayPal/Types/Address.hs113
-rw-r--r--src/Network/Payments/PayPal/Types/Currency.hs49
-rw-r--r--src/Network/Payments/PayPal/Types/FundingInstrument.hs97
-rw-r--r--src/Network/Payments/PayPal/Types/Hateoas.hs50
-rw-r--r--src/Network/Payments/PayPal/Types/Paging.hs69
-rw-r--r--src/Network/Payments/PayPal/Types/Payer.hs90
-rw-r--r--src/Network/Payments/PayPal/Types/Transaction.hs150
14 files changed, 1292 insertions, 0 deletions
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..8c0dc00
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,20 @@
+Copyright (c) 2016 Braden Walters
+
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
+
+The above copyright notice and this permission notice shall be included
+in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 0000000..9a994af
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/paypal-rest-client.cabal b/paypal-rest-client.cabal
new file mode 100644
index 0000000..91fc90f
--- /dev/null
+++ b/paypal-rest-client.cabal
@@ -0,0 +1,55 @@
+name: paypal-rest-client
+version: 0.1.0
+synopsis: A client to connect to PayPal's REST API (v1)
+license: MIT
+license-file: LICENSE
+homepage: https://github.com/meoblast001/paypal-rest-client
+author: Braden Walters
+maintainer: vc@braden-walters.info
+category: Network
+stability: experimental
+build-type: Simple
+cabal-version: >= 1.10
+Tested-With: GHC == 7.8.4, GHC == 7.10.2, GHC == 8.0.1
+
+description:
+ Library to connect with and use PayPal's
+ <https://developer.paypal.com/docs/api/ REST API v1>. For documentation, see
+ the <https://github.com/meoblast001/paypal-rest-client/blob/master/README.md README>.
+ During releases under 1.0.0, please use exact version numbers as bug fixes may
+ require breaking changes while this library is unstable.
+
+library
+ exposed-modules:
+ Network.Payments.PayPal
+ , Network.Payments.PayPal.Environment
+ , Network.Payments.PayPal.Auth
+ , Network.Payments.PayPal.Payments
+ , Network.Payments.PayPal.Types.Address
+ , Network.Payments.PayPal.Types.Currency
+ , Network.Payments.PayPal.Types.FundingInstrument
+ , Network.Payments.PayPal.Types.Hateoas
+ , Network.Payments.PayPal.Types.Paging
+ , Network.Payments.PayPal.Types.Payer
+ , Network.Payments.PayPal.Types.Transaction
+ build-depends:
+ base >= 4 && < 5
+ , bytestring >= 0.10.0
+ , containers >= 0.1.0
+ , safe >= 0.2
+ , wreq >= 0.4.0 && < 0.5.0
+ , http-client >= 0.4.6 && < 0.5.0
+ , http-types >= 0.8
+ , lens >= 4.5
+ , text >= 1.2
+ , aeson >= 0.10
+ , Decimal >= 0.3.1 && < 0.5
+ , country-codes >= 0.1.3
+ , time >= 1.5 && < 1.7
+ hs-source-dirs: src
+ default-language: Haskell2010
+ ghc-options: -Wall
+
+source-repository head
+ type: git
+ location: https://github.com/meoblast001/paypal-rest-client.git
diff --git a/src/Network/Payments/PayPal.hs b/src/Network/Payments/PayPal.hs
new file mode 100644
index 0000000..f912b23
--- /dev/null
+++ b/src/Network/Payments/PayPal.hs
@@ -0,0 +1,151 @@
+-- |
+-- Module: Network.Payments.PayPal
+-- Copyright: (C) 2016 Braden Walters
+-- License: MIT (see LICENSE file)
+-- Maintainer: Braden Walters <vc@braden-walters.info>
+-- Stability: experimental
+-- Portability: ghc
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Network.Payments.PayPal
+( UseHttpMethod(..)
+, PayPalOperations(..)
+, JSONText
+, ErrorMessage
+, PayPalError(..)
+, execPayPal
+, execPayPalOpers
+) where
+
+#if __GLASGOW_HASKELL__ < 710
+import Control.Applicative
+#endif
+import Control.Exception
+import Control.Lens
+import Data.Aeson
+import qualified Data.ByteString.Char8 as BS8
+import qualified Data.ByteString.Lazy as LBS
+import Data.Time.Clock
+import qualified Network.HTTP.Client as HTTPClient
+import Network.Payments.PayPal.Auth
+import Network.Payments.PayPal.Environment
+import Network.Wreq
+
+-- |HTTP method to use in the request (GET/POST).
+data UseHttpMethod = UseHttpGet | UseHttpPost Payload | UseHttpPatch Payload
+
+-- Instance of show that ignores the payload.
+instance Show UseHttpMethod where
+ show UseHttpGet = "HttpGet"
+ show (UseHttpPost _) = "HttpPost"
+ show (UseHttpPatch _) = "HttpPatch"
+
+-- |A monad composing multiple PayPal operations which are to be performed.
+-- The result can be executed using the execPayPal function.
+data PayPalOperations :: * -> * where
+ PPOPure :: a -> PayPalOperations a
+ PPOBind :: PayPalOperations a -> (a -> PayPalOperations b) ->
+ PayPalOperations b
+ PayPalOperation :: FromJSON a =>
+ { ppoMethod :: UseHttpMethod
+ , ppoUrl :: String
+ , ppoOptions :: Options
+ } -> PayPalOperations a
+
+instance Functor PayPalOperations where
+ fmap f m = PPOBind m (PPOPure . f)
+
+instance Applicative PayPalOperations where
+ pure x = PPOPure x
+ mf <*> mx = PPOBind mf (\f -> PPOBind mx (\x -> PPOPure (f x)))
+
+instance Monad PayPalOperations where
+ m >>= f = PPOBind m f
+
+type JSONText = LBS.ByteString
+type ErrorMessage = String
+
+data PayPalError = HttpStatusError Int |
+ ResponseParseError ErrorMessage JSONText |
+ HttpError HTTPClient.HttpException | OtherError String
+ deriving (Show)
+
+-- |Authenticate with PayPal and then interact with the service.
+execPayPal :: FromJSON a => EnvironmentUrl -> ClientID -> Secret ->
+ PayPalOperations a -> IO (Either PayPalError a)
+execPayPal envUrl username password operations = do
+ accessTokenOrErr <- fetchAccessTokenWithExpiration envUrl username password
+ case accessTokenOrErr of
+ -- Failure to fetch access token.
+ Left (AccessTokenHttpError httpErr) -> return $ Left $ HttpError httpErr
+ Left (AccessTokenStatusError statusCode') ->
+ return $ Left $ HttpStatusError statusCode'
+ Left (AccessTokenParseError errMsg text) ->
+ return $ Left $ ResponseParseError errMsg text
+ -- Successfully acquired, execute operations.
+ Right accTokenWithEx -> do
+ result <- execPayPalOpers envUrl username password accTokenWithEx
+ operations
+ case result of
+ Left err -> return $ Left err
+ Right (result', _) -> return $ Right result'
+
+-- |Executes a PayPalOperations monad as IO. Because the access token can
+-- expire and needs to be renewed, this function returns the desired value and
+-- the most current access token when successful.
+execPayPalOpers :: EnvironmentUrl -> ClientID -> Secret ->
+ AccessTokenWithExpiration -> PayPalOperations a ->
+ IO (Either PayPalError (a, AccessTokenWithExpiration))
+execPayPalOpers _ _ _ accTokenWithEx (PPOPure a) =
+ return $ Right (a, accTokenWithEx)
+execPayPalOpers envUrl' username password accTokenWithEx (PPOBind m f) = do
+ treeLeftResult <- execPayPalOpers envUrl' username password accTokenWithEx m
+ either (return . Left)
+ (\(res, newAccTk) -> execPayPalOpers envUrl' username password
+ newAccTk $ f res)
+ treeLeftResult
+execPayPalOpers env@(EnvironmentUrl baseUrl) username password
+ accTokenWithEx@(accessToken, expiration)
+ (PayPalOperation method url preOptions) = do
+ -- Check the validity of the access token and renew it if it expired.
+ curTime <- getCurrentTime
+ latestAccTkOrErr <- if diffUTCTime expiration curTime <= 0
+ then fetchAccessTokenWithExpiration env username password
+ else return $ Right accTokenWithEx
+ case latestAccTkOrErr of
+ -- Failure to refresh access token.
+ Left (AccessTokenHttpError httpErr) -> return $ Left $ HttpError httpErr
+ Left (AccessTokenStatusError statusCode') ->
+ return $ Left $ HttpStatusError statusCode'
+ Left (AccessTokenParseError errMsg text) ->
+ return $ Left $ ResponseParseError errMsg text
+ -- Either existing access token is still valid or new access token was
+ -- retrieved.
+ Right latestAccTk -> do
+ -- Perform the request.
+ let accToken = aToken accessToken
+ opts = preOptions &
+ header "Authorization" .~ [BS8.pack ("Bearer " ++ accToken)]
+ responseOrErr <- try $ case method of
+ UseHttpGet -> getWith opts (baseUrl ++ url)
+ UseHttpPost payload -> postWith opts (baseUrl ++ url) payload
+ UseHttpPatch payload ->
+ customPayloadMethodWith "PATCH" opts (baseUrl ++ url) payload
+ case responseOrErr of
+ -- HTTP request failed.
+ Left err -> return $ Left $ HttpError err
+ -- HTTP request successful.
+ Right response -> do
+ let statusCode' = response ^. responseStatus . statusCode
+ if statusCode' == 200 then
+ let responseText = response ^. responseBody
+ in case eitherDecode responseText of
+ Left errMsg ->
+ return $ Left $ ResponseParseError errMsg responseText
+ Right result -> return $ Right (result, latestAccTk)
+ else
+ return $ Left $ HttpStatusError statusCode'
diff --git a/src/Network/Payments/PayPal/Auth.hs b/src/Network/Payments/PayPal/Auth.hs
new file mode 100644
index 0000000..8793096
--- /dev/null
+++ b/src/Network/Payments/PayPal/Auth.hs
@@ -0,0 +1,128 @@
+-- |
+-- Module: Network.Payments.PayPal.Auth
+-- Copyright: (C) 2016 Braden Walters
+-- License: MIT (see LICENSE file)
+-- Maintainer: Braden Walters <vc@braden-walters.info>
+-- Stability: experimental
+-- Portability: ghc
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+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
+
+-- |PayPal client ID with which to execute actions.
+type ClientID = String
+
+-- |PayPal secret of user with which to execute actions.
+type Secret = String
+
+-- |Number representing seconds of time.
+type Seconds = Integer
+
+-- |Access token returned from OAuth.
+data AccessToken = AccessToken
+ { aTokenScope :: [String]
+ , aToken :: String
+ , aTokenType :: String
+ , aTokenAppId :: String
+ , aTokenExpires :: Seconds
+ } deriving (Eq, Show)
+
+-- |An access token from OAuth together with its UTC expiration time.
+type AccessTokenWithExpiration = (AccessToken, UTCTime)
+
+-- |Error while fetching access token.
+data AccessTokenError = AccessTokenHttpError HTTP.HttpException |
+ AccessTokenStatusError Int |
+ -- Contains error message and JSON text.
+ AccessTokenParseError String LBS.ByteString
+
+-- |Either an access token or the error encountered while fetching it.
+type AccessTokenResult = Either AccessTokenError AccessToken
+
+-- |Either an access token with an expiration or the error encountered while
+-- fetching it
+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
+
+-- |Use a PayPal environment and login credentials to get an OAuth access token.
+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'
+
+-- |Use a PayPal environment and login credentials to get an OAuth access token
+-- with an expiration time.
+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
+
+-- |Time at which the token should be considered expired. This is a few seconds
+-- before the time that PayPal gives us. Parameters are the time at which the
+-- access token was retrieved and the access token.
+safeExpirationTime :: UTCTime -> AccessToken -> UTCTime
+safeExpirationTime currentTime token =
+ let safetyBuffer = 10 -- Seconds.
+ seconds = aTokenExpires token - safetyBuffer
+ in addUTCTime (fromIntegral seconds) currentTime
diff --git a/src/Network/Payments/PayPal/Environment.hs b/src/Network/Payments/PayPal/Environment.hs
new file mode 100644
index 0000000..2e43818
--- /dev/null
+++ b/src/Network/Payments/PayPal/Environment.hs
@@ -0,0 +1,24 @@
+-- |
+-- Module: Network.Payments.PayPal.Auth
+-- Copyright: (C) 2016 Braden Walters
+-- License: MIT (see LICENSE file)
+-- Maintainer: Braden Walters <vc@braden-walters.info>
+-- Stability: experimental
+-- Portability: ghc
+
+module Network.Payments.PayPal.Environment
+( EnvironmentUrl(..)
+, sandboxUrl
+, liveUrl
+) where
+
+-- |URL of a PayPal environment.
+newtype EnvironmentUrl = EnvironmentUrl String deriving (Eq, Show)
+
+-- |URL to sandbox environment.
+sandboxUrl :: EnvironmentUrl
+sandboxUrl = EnvironmentUrl "https://api.sandbox.paypal.com"
+
+-- |URL to live environment.
+liveUrl :: EnvironmentUrl
+liveUrl = EnvironmentUrl "https://api.paypal.com"
diff --git a/src/Network/Payments/PayPal/Payments.hs b/src/Network/Payments/PayPal/Payments.hs
new file mode 100644
index 0000000..9650efa
--- /dev/null
+++ b/src/Network/Payments/PayPal/Payments.hs
@@ -0,0 +1,294 @@
+-- |
+-- Module: Network.Payments.PayPal.Payments
+-- Copyright: (C) 2016 Braden Walters
+-- License: MIT (see LICENSE file)
+-- Maintainer: Braden Walters <vc@braden-walters.info>
+-- Stability: experimental
+-- Portability: ghc
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Network.Payments.PayPal.Payments
+( URL
+, PaymentID
+, Intent(..)
+, RedirectUrls(..)
+, ReturnLinkParams(..)
+, CreateRequest(..)
+, CreateResponse(..)
+, ExecuteRequest(..)
+, ExecuteResponse(..)
+, FindResponse(..)
+, ListResponse(..)
+, createPayment
+, approvalUrlFromCreate
+, executePayment
+, findPaymentById
+, listPayments
+, returnLinkParams
+) where
+
+#if __GLASGOW_HASKELL__ < 710
+import Control.Applicative
+#endif
+import Control.Monad
+import Data.Aeson
+import Data.Aeson.Types
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as BS8
+import qualified Data.Map as M
+import Data.Maybe
+#if __GLASGOW_HASKELL__ < 710
+import Data.Monoid
+#endif
+import Data.Time.Clock
+import Data.Time.Format
+import qualified Network.HTTP.Client as HTTP
+import Network.Payments.PayPal
+import Network.Payments.PayPal.Types.Hateoas
+import Network.Payments.PayPal.Types.Paging
+import Network.Payments.PayPal.Types.Payer
+import Network.Payments.PayPal.Types.Transaction
+import Network.Wreq
+import qualified Network.Wreq.Types as WTypes
+
+-- A string representing a URL.
+type URL = String
+
+-- The ID of a payment provided by PayPal.
+type PaymentID = String
+
+-- |Payment intent.
+data Intent = SaleIntent | AuthoriseIntent | OrderIntent
+ deriving (Eq, Read, Show)
+
+instance ToJSON Intent where
+ toJSON SaleIntent = "sale"
+ toJSON AuthoriseIntent = "authorize"
+ toJSON OrderIntent = "order"
+
+instance FromJSON Intent where
+ parseJSON (String "sale") = return SaleIntent
+ parseJSON (String "authorize") = return AuthoriseIntent
+ parseJSON (String "order") = return OrderIntent
+ parseJSON _ = mzero
+
+data RedirectUrls = RedirectUrls
+ { redirUrlReturn :: URL
+ , redirUrlCancel :: URL
+ } deriving (Eq, Show)
+
+instance ToJSON RedirectUrls where
+ toJSON urls =
+ object ["return_url" .= redirUrlReturn urls,
+ "cancel_url" .= redirUrlCancel urls]
+
+instance FromJSON RedirectUrls where
+ parseJSON (Object obj) =
+ RedirectUrls <$>
+ obj .: "return_url" <*>
+ obj .: "cancel_url"
+ parseJSON _ = mzero
+
+data ReturnLinkParams = ReturnLinkParams
+ { retLinkParamPayId :: PaymentID
+ , retLinkParamToken :: String
+ , retLinkParamPayerId :: String
+ } deriving (Eq, Show)
+
+-- |Current status of the PayPal payment.
+data PaymentState = PayStateCreated | PayStateApproved | PayStateFailed |
+ PayStateCancelled | PayStateExpired | PayStatePending
+ deriving (Eq, Read, Show)
+
+instance FromJSON PaymentState where
+ parseJSON (String "created") = return PayStateCreated
+ parseJSON (String "approved") = return PayStateApproved
+ parseJSON (String "failed") = return PayStateFailed
+ parseJSON (String "canceled") = return PayStateCancelled
+ parseJSON (String "expired") = return PayStateExpired
+ parseJSON (String "pending") = return PayStatePending
+ parseJSON _ = mzero
+
+-- |Contains data sent to PayPal to create a payment.
+data CreateRequest = CreateRequest
+ { createReqIntent :: Intent
+ , createReqPayer :: Payer
+ , createReqTransactions :: [Transaction]
+ , createReqRedirectUrls :: Maybe RedirectUrls
+ } deriving (Eq, Show)
+
+instance ToJSON CreateRequest where
+ toJSON req =
+ object (["intent" .= createReqIntent req,
+ "payer" .= createReqPayer req,
+ "transactions" .= createReqTransactions req] ++
+ maybeToList (("redirect_urls" .=) <$> createReqRedirectUrls req))
+
+-- |Contains a parsed response from PayPal after making a create payment
+-- request.
+data CreateResponse = CreateResponse
+ { createResIntent :: Intent
+ , createResPayer :: Payer
+ , createResTransactions :: [Transaction]
+ , createResRedirectUrls :: Maybe RedirectUrls
+ , createResPayId :: PaymentID
+ , createResCreateTime :: UTCTime
+ , createResPayState :: PaymentState
+ , createResUpdateTime :: Maybe UTCTime
+ , createResHateoasLinks :: [HateoasLink]
+ } deriving (Eq, Show)
+
+instance FromJSON CreateResponse where
+ parseJSON (Object obj) =
+ CreateResponse <$>
+ obj .: "intent" <*>
+ obj .: "payer" <*>
+ obj .: "transactions" <*>
+ obj .:? "redirect_urls" <*>
+ obj .: "id" <*>
+ (obj .: "create_time" >>= parseTimeIso8106) <*>
+ obj .: "state" <*>
+ (obj .:? "update_time" >>=
+ maybe (return Nothing) (\str -> Just <$> parseTimeIso8106 str)) <*>
+ obj .: "links"
+ parseJSON _ = mzero
+
+-- |Executing a payment has a special transaction object which only contains the
+-- amount.
+data ExecuteTransaction = ExecuteTransaction
+ { executeTransactionAmount :: Amount
+ } deriving (Eq, Show)
+
+instance ToJSON ExecuteTransaction where
+ toJSON trans = object ["amount" .= executeTransactionAmount trans]
+
+-- |Request to execute a payment.
+data ExecuteRequest = ExecuteRequest
+ { executeReqPayerId :: String
+ , executeReqTransactions :: [ExecuteTransaction]
+ } deriving (Eq, Show)
+
+instance ToJSON ExecuteRequest where
+ toJSON req =
+ let transactions = if length (executeReqTransactions req) > 0
+ then ["transactions" .= executeReqTransactions req]
+ else []
+ in object (["payer_id" .= executeReqPayerId req] ++ transactions)
+
+-- |Response from an execute payment request.
+data ExecuteResponse = ExecuteResponse
+ { executeResIntent :: Intent
+ , executeResPayer :: Payer
+ , executeResTransactions :: [Transaction]
+ , executeResHateoasLinks :: [HateoasLink]
+ } deriving (Eq, Show)
+
+instance FromJSON ExecuteResponse where
+ parseJSON (Object obj) =
+ ExecuteResponse <$>
+ obj .: "intent" <*>
+ obj .: "payer" <*>
+ obj .: "transactions" <*>
+ obj .: "links"
+ parseJSON _ = mzero
+
+-- |Contains a parsed response from a find payment request.
+data FindResponse = FindResponse
+ { findResIntent :: Intent
+ , findResPayer :: Payer
+ , findResTransactions :: [Transaction]
+ , findResRedirectUrls :: Maybe RedirectUrls
+ , findResPayId :: PaymentID
+ , findResCreateTime :: UTCTime
+ , findResPayState :: PaymentState
+ , findResUpdateTime :: Maybe UTCTime
+ } deriving (Eq, Show)
+
+instance FromJSON FindResponse where
+ parseJSON (Object obj) =
+ FindResponse <$>
+ obj .: "intent" <*>
+ obj .: "payer" <*>
+ obj .: "transactions" <*>
+ obj .:? "redirect_urls" <*>
+ obj .: "id" <*>
+ (obj .: "create_time" >>= parseTimeIso8106) <*>
+ obj .: "state" <*>
+ (obj .:? "update_time" >>= maybe (return Nothing)
+ (\str -> Just <$> parseTimeIso8106 str))
+ parseJSON _ = mzero
+
+-- Response to a payment list request.
+data ListResponse = ListResponse
+ { listResPayments :: [CreateResponse]
+ , listResCount :: Integer
+ , listResNextId :: Maybe PaymentID
+ } deriving (Eq, Show)
+
+instance FromJSON ListResponse where
+ parseJSON (Object obj) =
+ ListResponse <$>
+ (fromMaybe [] <$> obj .:? "payments") <*>
+ obj .: "count" <*>
+ obj .:? "next_id"
+ parseJSON _ = mzero
+
+-- |Creates a new payment using payment data.
+createPayment :: CreateRequest -> PayPalOperations CreateResponse
+createPayment request =
+ let url = "/v1/payments/payment"
+ contentType = "application/json"
+ content = encode request
+ payload = WTypes.Raw contentType $ HTTP.RequestBodyLBS content
+ in PayPalOperation (UseHttpPost payload) url defaults
+
+-- |Extracts an approval URL, if there is one, from a create response
+approvalUrlFromCreate :: CreateResponse -> Maybe URL
+approvalUrlFromCreate response =
+ let criteriaFunction hateoas =
+ hateoasRel hateoas == "approval_url" &&
+ hateoasMethod hateoas == HateoasRedirect
+ maybeHateoas =
+ listToMaybe $ filter criteriaFunction $ createResHateoasLinks response
+ in hateoasHref <$> maybeHateoas
+
+-- |Execute (or complete) a payment that has been approved by the payer.
+executePayment :: PaymentID -> ExecuteRequest ->
+ PayPalOperations ExecuteResponse
+executePayment id' request =
+ let url = "/v1/payments/payment/" ++ id' ++ "/execute"
+ contentType = "application/json"
+ content = encode request
+ payload = WTypes.Raw contentType $ HTTP.RequestBodyLBS content
+ in PayPalOperation (UseHttpPost payload) url defaults
+
+-- |Looks up a payment by ID.
+findPaymentById :: PaymentID -> PayPalOperations FindResponse
+findPaymentById id' =
+ let url = "/v1/payments/payment/" ++ id'
+ in PayPalOperation UseHttpGet url defaults
+
+-- |Lists payments, possibly with paging.
+listPayments :: Maybe PagingRequest -> PayPalOperations ListResponse
+listPayments pagingRequest =
+ let url = "/v1/payments/payment/" ++
+ (maybe mempty (\req -> "?" ++ pagingReqToQuery req) pagingRequest)
+ in PayPalOperation UseHttpGet url defaults
+
+-- |Use this function to parse GET parameters passed from PayPal to the return
+-- URL. Takes a map of query parameters (name to value) and returns a structure
+-- containing these parameters if possible. Otherwise PayPal didn't give you
+-- required data.
+returnLinkParams :: M.Map BS.ByteString BS.ByteString -> Maybe ReturnLinkParams
+returnLinkParams query = do
+ paymentId <- BS8.unpack <$> M.lookup "paymentId" query
+ token <- BS8.unpack <$> M.lookup "token" query
+ payerId <- BS8.unpack <$> M.lookup "PayerID" query
+ return $ ReturnLinkParams paymentId token payerId
+
+-- Parses a time in ISO 8106 format to a UTCTime.
+parseTimeIso8106 :: String -> Parser UTCTime
+parseTimeIso8106 str =
+ parseTimeM True defaultTimeLocale (iso8601DateFormat $ Just "%H:%M:%SZ") str
diff --git a/src/Network/Payments/PayPal/Types/Address.hs b/src/Network/Payments/PayPal/Types/Address.hs
new file mode 100644
index 0000000..f54973c
--- /dev/null
+++ b/src/Network/Payments/PayPal/Types/Address.hs
@@ -0,0 +1,113 @@
+-- |
+-- Module: Network.Payments.PayPal.Types.Address
+-- Copyright: (C) 2016 Braden Walters
+-- License: MIT (see LICENSE file)
+-- Maintainer: Braden Walters <vc@braden-walters.info>
+-- Stability: experimental
+-- Portability: ghc
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Network.Payments.PayPal.Types.Address
+( Address(..)
+, ShippingAddressType(..)
+, ShippingAddress(..)
+) where
+
+#if __GLASGOW_HASKELL__ < 710
+import Control.Applicative
+#endif
+import Control.Monad
+import Data.Aeson
+import Data.CountryCodes
+import Data.Maybe
+
+-- |Billing address of the payer.
+data Address = Address
+ { addressLine1 :: String
+ , addressLine2 :: Maybe String
+ , addressCity :: String
+ , addressCountryCode :: CountryCode
+ , addressPostalCode :: Maybe String
+ , addressState :: Maybe String
+ , addressPhone :: String
+ } deriving (Eq, Show)
+
+instance ToJSON Address where
+ toJSON addr =
+ object (["line1" .= addressLine1 addr,
+ "city" .= addressCity addr,
+ "country_code" .= toText (addressCountryCode addr),
+ "phone" .= addressPhone addr] ++
+ maybeToList (("line2" .=) <$> addressLine2 addr) ++
+ maybeToList (("postal_code" .=) <$> addressPostalCode addr) ++
+ maybeToList (("state" .=) <$> addressState addr))
+
+instance FromJSON Address where
+ parseJSON (Object obj) =
+ Address <$>
+ obj .: "line1" <*>
+ obj .:? "line2" <*>
+ obj .: "city" <*>
+ (fmap fromMText (obj .: "country_code") >>= maybe mzero return) <*>
+ obj .:? "postal_code" <*>
+ obj .:? "state" <*>
+ obj .: "phone"
+ parseJSON _ = mzero
+
+-- |The type of the address.
+data ShippingAddressType =
+ ShipAddrResidential | ShipAddrBusiness | ShipAddrMailbox
+ deriving (Eq, Read, Show)
+
+instance ToJSON ShippingAddressType where
+ toJSON ShipAddrResidential = "residential"
+ toJSON ShipAddrBusiness = "business"
+ toJSON ShipAddrMailbox = "mailbox"
+
+instance FromJSON ShippingAddressType where
+ parseJSON (String "residential") = return ShipAddrResidential
+ parseJSON (String "business") = return ShipAddrBusiness
+ parseJSON (String "mailbox") = return ShipAddrMailbox
+ parseJSON _ = mzero
+
+-- |The payer's shipping address.
+data ShippingAddress = ShippingAddress
+ { shipAddrRecipientName :: Maybe String
+ , shipAddrType :: Maybe ShippingAddressType
+ , shipAddrLine1 :: String
+ , shipAddrLine2 :: Maybe String
+ , shipAddrCity :: String
+ , shipAddrCountryCode :: CountryCode
+ , shipAddrPostalCode :: Maybe String
+ , shipAddrState :: Maybe String
+ , shipAddrPhone :: Maybe String
+ } deriving (Eq, Show)
+
+instance ToJSON ShippingAddress where
+ toJSON addr =
+ object (maybeToList (("recipient_name" .=) <$>
+ shipAddrRecipientName addr) ++
+ ["line1" .= shipAddrLine1 addr,
+ "city" .= shipAddrCity addr,
+ "country_code" .= toText (shipAddrCountryCode addr)] ++
+ maybeToList (("type" .=) <$> shipAddrType addr) ++
+ maybeToList (("line2" .=) <$> shipAddrLine2 addr) ++
+ maybeToList (("postal_code" .=) <$> shipAddrPostalCode addr) ++
+ maybeToList (("state" .=) <$> shipAddrState addr) ++
+ maybeToList (("phone" .=) <$> shipAddrPhone addr))
+
+instance FromJSON ShippingAddress where
+ parseJSON (Object obj) =
+ ShippingAddress <$>
+ obj .:? "recipient_name" <*>
+ obj .:? "type" <*>
+ obj .: "line1" <*>
+ obj .:? "line2" <*>
+ obj .: "city" <*>
+ obj .: "country_code" <*>
+ obj .:? "postal_code" <*>
+ obj .:? "state" <*>
+ obj .:? "phone"
+ parseJSON _ = mzero
diff --git a/src/Network/Payments/PayPal/Types/Currency.hs b/src/Network/Payments/PayPal/Types/Currency.hs
new file mode 100644
index 0000000..2b57d9d
--- /dev/null
+++ b/src/Network/Payments/PayPal/Types/Currency.hs
@@ -0,0 +1,49 @@
+-- |
+-- Module: Network.Payments.PayPal.Types.Currency
+-- Copyright: (C) 2016 Braden Walters
+-- License: MIT (see LICENSE file)
+-- Maintainer: Braden Walters <vc@braden-walters.info>
+-- Stability: experimental
+-- Portability: ghc
+
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Network.Payments.PayPal.Types.Currency
+( Currency(..)
+, MonetaryAmount(..)
+) where
+
+import Control.Monad
+import Data.Decimal
+import qualified Data.Text as T
+import Data.Aeson
+import Safe
+
+-- |Currencies supported by PayPal.
+data Currency =
+ AUD | BRL | CAD | CZK | DKK | EUR | HKD | HUF | ILS | JPY | MYR | MXN | TWD |
+ NZD | NOK | PHP | PLN | GBP | RUB | SGD | SEK | CHF | THB | TRY | USD
+ deriving (Eq, Read, Show)
+
+instance ToJSON Currency where
+ toJSON currency = String $ T.pack $ show currency
+
+instance FromJSON Currency where
+ parseJSON (String txt) = maybe mzero return $ readMay $ T.unpack txt
+ parseJSON _ = mzero
+
+-- |Type based on Decimal which is used for holding monetary amounts and can be
+-- encoded to and decoded from JSON. Encodes to a string, decodes from string or
+-- number.
+newtype MonetaryAmount = MonetaryAmount Decimal
+ deriving (Eq, Fractional, Num, Ord, Read, Real, RealFrac, Show)
+
+instance ToJSON MonetaryAmount where
+ toJSON (MonetaryAmount value) = String $ T.pack $ show $ roundTo 2 value
+
+instance FromJSON MonetaryAmount where
+ parseJSON (String value) =
+ return $ MonetaryAmount $ roundTo 2 $ read $ T.unpack value
+ parseJSON (Number value) = return $ MonetaryAmount $ realFracToDecimal 2 value
+ parseJSON _ = mzero
diff --git a/src/Network/Payments/PayPal/Types/FundingInstrument.hs b/src/Network/Payments/PayPal/Types/FundingInstrument.hs
new file mode 100644
index 0000000..23fdcad
--- /dev/null
+++ b/src/Network/Payments/PayPal/Types/FundingInstrument.hs
@@ -0,0 +1,97 @@
+-- |
+-- Module: Network.Payments.PayPal.Types.FundingInstrument
+-- Copyright: (C) 2016 Braden Walters
+-- License: MIT (see LICENSE file)
+-- Maintainer: Braden Walters <vc@braden-walters.info>
+-- Stability: experimental
+-- Portability: ghc
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Network.Payments.PayPal.Types.FundingInstrument
+( CreditCardType(..)
+, CreditCard(..)
+, FundingInstrument(..)
+) where
+
+#if __GLASGOW_HASKELL__ < 710
+import Control.Applicative
+#endif
+import Control.Monad
+import Data.Aeson
+import Data.Maybe
+import qualified Data.Text as T
+import Network.Payments.PayPal.Types.Address
+
+-- |Type of credit card being used.
+data CreditCardType = VisaCC | MasterCardCC | DiscoverCC | AMEXCC
+ deriving (Eq, Read, Show)
+
+instance ToJSON CreditCardType where
+ toJSON VisaCC = "visa"
+ toJSON MasterCardCC = "mastercard"
+ toJSON DiscoverCC = "discover"
+ toJSON AMEXCC = "amex"
+
+instance FromJSON CreditCardType where
+ parseJSON (String text) =
+ -- Lower case is documented but sometimes PayPal likes to return upper
+ -- case...
+ case T.toLower text of
+ "visa" -> return VisaCC
+ "mastercard" -> return MasterCardCC
+ "discover" -> return DiscoverCC
+ "amex" -> return AMEXCC
+ _ -> mzero
+ parseJSON _ = mzero
+
+-- |Information about a credit card.
+data CreditCard = CreditCard
+ { creditCardNumber :: String
+ , creditCardType :: CreditCardType
+ , creditCardExpireMonth :: Int
+ , creditCardExpireYear :: Int
+ , creditCardCVV2 :: Maybe String
+ , creditCardFirstName :: Maybe String
+ , creditCardLastName :: Maybe String
+ , creditCardBillingAddress :: Maybe Address
+ } deriving (Eq, Show)
+
+instance ToJSON CreditCard where
+ toJSON cc =
+ object (["number" .= creditCardNumber cc,
+ "type" .= creditCardType cc,
+ "expire_month" .= show (creditCardExpireMonth cc),
+ "expire_year" .= show (creditCardExpireYear cc)] ++
+ maybeToList (("cvv2" .=) <$> creditCardCVV2 cc) ++
+ maybeToList (("first_name" .=) <$> creditCardFirstName cc) ++
+ maybeToList (("last_name" .=) <$> creditCardLastName cc) ++
+ maybeToList (("billing_address" .=) <$>
+ creditCardBillingAddress cc))
+
+instance FromJSON CreditCard where
+ parseJSON (Object obj) =
+ CreditCard <$>
+ obj .: "number" <*>
+ obj .: "type" <*>
+ fmap read (obj .: "expire_month") <*>
+ fmap read (obj .: "expire_year") <*>
+ obj .:? "ccv2" <*>
+ obj .:? "first_name" <*>
+ obj .:? "last_name" <*>
+ obj .:? "billing_address"
+ parseJSON _ = mzero
+
+-- |Representation of either a new credit card or existing credit card data.
+data FundingInstrument = FundingInstrument
+ { fundInstCreditCard :: Maybe CreditCard
+ } deriving (Eq, Show)
+
+instance ToJSON FundingInstrument where
+ toJSON fundInstr =
+ object (maybeToList (("credit_card" .=) <$> fundInstCreditCard fundInstr))
+
+instance FromJSON FundingInstrument where
+ parseJSON (Object obj) = FundingInstrument <$> obj .:? "credit_card"
+ parseJSON _ = mzero
diff --git a/src/Network/Payments/PayPal/Types/Hateoas.hs b/src/Network/Payments/PayPal/Types/Hateoas.hs
new file mode 100644
index 0000000..3243651
--- /dev/null
+++ b/src/Network/Payments/PayPal/Types/Hateoas.hs
@@ -0,0 +1,50 @@
+-- |
+-- Module: Network.Payments.PayPal.Types.Hateoas
+-- Copyright: (C) 2016 Braden Walters
+-- License: MIT (see LICENSE file)
+-- Maintainer: Braden Walters <vc@braden-walters.info>
+-- Stability: experimental
+-- Portability: ghc
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Network.Payments.PayPal.Types.Hateoas
+( HateoasMethod(..)
+, HateoasLink(..)
+) where
+
+#if __GLASGOW_HASKELL__ < 710
+import Control.Applicative
+#endif
+import Control.Monad
+import qualified Data.Text as T
+import Data.Aeson
+
+type URL = String
+
+-- |HATEOAS method.
+data HateoasMethod = HateoasGet | HateoasPost | HateoasPatch | HateoasRedirect |
+ HateoasOther String deriving (Eq, Read, Show)
+
+-- |HATEOAS link.
+data HateoasLink = HateoasLink
+ { hateoasHref :: URL
+ , hateoasRel :: String
+ , hateoasMethod :: HateoasMethod
+ } deriving (Eq, Show)
+
+instance FromJSON HateoasLink where
+ parseJSON (Object obj) =
+ HateoasLink <$>
+ obj .: "href" <*>
+ obj .: "rel" <*>
+ ((obj .: "method") >>= parseHttpMethod)
+ where
+ parseHttpMethod (String "GET") = return HateoasGet
+ parseHttpMethod (String "POST") = return HateoasPost
+ parseHttpMethod (String "PATCH") = return HateoasPatch
+ parseHttpMethod (String "REDIRECT") = return HateoasRedirect
+ parseHttpMethod (String other) = return $ HateoasOther $ T.unpack other
+ parseHttpMethod _ = mzero
+ parseJSON _ = mzero
diff --git a/src/Network/Payments/PayPal/Types/Paging.hs b/src/Network/Payments/PayPal/Types/Paging.hs
new file mode 100644
index 0000000..c23371c
--- /dev/null
+++ b/src/Network/Payments/PayPal/Types/Paging.hs
@@ -0,0 +1,69 @@
+-- |
+-- Module: Network.Payments.PayPal.Types.Paging
+-- Copyright: (C) 2016 Braden Walters
+-- License: MIT (see LICENSE file)
+-- Maintainer: Braden Walters <vc@braden-walters.info>
+-- Stability: experimental
+-- Portability: ghc
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Network.Payments.PayPal.Types.Paging
+( PagingSortBy(..)
+, PagingSortOrder(..)
+, PagingRequest(..)
+, pagingReqToQuery
+) where
+
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as BS8
+#if __GLASGOW_HASKELL__ < 710
+import Data.Functor
+#endif
+import Data.Time.Clock
+import Data.Time.Format
+import Network.HTTP.Types.URI
+
+-- |Sort by create or update time.
+data PagingSortBy = PagingSortCreated | PagingSortUpdated deriving (Eq, Read)
+
+instance Show PagingSortBy where
+ show PagingSortCreated = "create_time"
+ show PagingSortUpdated = "update_time"
+
+-- |Sort order.
+data PagingSortOrder = PagingSortAsc | PagingSortDesc deriving (Eq, Read)
+
+instance Show PagingSortOrder where
+ show PagingSortAsc = "asc"
+ show PagingSortDesc = "desc"
+
+-- |Request query parameters to page lists of data in a response.
+data PagingRequest = PagingRequest
+ { pagingCount :: Maybe Integer
+ , pagingStartId :: Maybe String
+ , pagingStartTime :: UTCTime
+ , pagingEndTime :: UTCTime
+ , pagingSortBy :: Maybe PagingSortBy
+ , pagingSortOrder :: Maybe PagingSortOrder
+ } deriving (Eq, Show)
+
+-- |Create a query string from a paging request.
+pagingReqToQuery :: PagingRequest -> String
+pagingReqToQuery req =
+ let queryItems = [("count", showToBS <$> pagingCount req),
+ ("start_id", stringToBS <$> pagingStartId req),
+ ("start_time", Just $ timeToBS $ pagingStartTime req),
+ ("end_time", Just $ timeToBS $ pagingEndTime req),
+ ("sort_by", showToBS <$> pagingSortBy req),
+ ("sort_order", showToBS <$> pagingSortOrder req)]
+ in BS8.unpack $ renderQuery False queryItems
+ where
+ stringToBS :: String -> BS.ByteString
+ stringToBS x = BS8.pack x
+ timeToBS :: UTCTime -> BS.ByteString
+ timeToBS x = BS8.pack $ formatTime defaultTimeLocale
+ (iso8601DateFormat $ Just "%H:%M:%SZ") x
+ showToBS :: Show a => a -> BS.ByteString
+ showToBS x = BS8.pack $ show x
diff --git a/src/Network/Payments/PayPal/Types/Payer.hs b/src/Network/Payments/PayPal/Types/Payer.hs
new file mode 100644
index 0000000..08ca0f5
--- /dev/null
+++ b/src/Network/Payments/PayPal/Types/Payer.hs
@@ -0,0 +1,90 @@
+-- |
+-- Module: Network.Payments.PayPal.Types.Payer
+-- Copyright: (C) 2016 Braden Walters
+-- License: MIT (see LICENSE file)
+-- Maintainer: Braden Walters <vc@braden-walters.info>
+-- Stability: experimental
+-- Portability: ghc
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Network.Payments.PayPal.Types.Payer
+( PayerInfo(..)
+, PaymentMethod(..)
+, PayerStatus(..)
+, Payer(..)
+) where
+
+#if __GLASGOW_HASKELL__ < 710
+import Control.Applicative
+#endif
+import Control.Monad
+import Data.Aeson
+import qualified Data.Foldable as F
+import Data.Maybe
+import Network.Payments.PayPal.Types.FundingInstrument
+
+-- |Optional additional information about the payer.
+data PayerInfo = PayerInfo
+ { payerInfoEmail :: String
+ } deriving (Eq, Show)
+
+instance ToJSON PayerInfo where
+ toJSON info = object ["email" .= payerInfoEmail info]
+
+instance FromJSON PayerInfo where
+ parseJSON (Object obj) = PayerInfo <$> obj .: "email"
+ parseJSON _ = mzero
+
+-- |Method of payment.
+data PaymentMethod = PayMethodPayPal | PayMethodCreditCard
+ deriving (Eq, Read, Show)
+
+instance ToJSON PaymentMethod where
+ toJSON PayMethodPayPal = "paypal"
+ toJSON PayMethodCreditCard = "credit_card"
+
+instance FromJSON PaymentMethod where
+ parseJSON (String "paypal") = return PayMethodPayPal
+ parseJSON (String "credit_card") = return PayMethodCreditCard
+ parseJSON _ = mzero
+
+-- |Account verification status of the payer.
+data PayerStatus = PayerStatusVerified | PayerStatusUnverified
+ deriving (Eq, Read, Show)
+
+instance FromJSON PayerStatus where
+ parseJSON (String "VERIFIED") = return PayerStatusVerified
+ parseJSON (String "UNVERIFIED") = return PayerStatusUnverified
+ parseJSON _ = mzero
+
+instance ToJSON PayerStatus where
+ toJSON PayerStatusVerified = "VERIFIED"
+ toJSON PayerStatusUnverified = "UNVERIFIED"
+
+-- |Information about the payer in a transaction.
+data Payer = Payer
+ { payerPaymentMethod :: PaymentMethod
+ , payerFundingInstruments :: [FundingInstrument]
+ , payerInfo :: Maybe PayerInfo
+ , payerStatus :: Maybe PayerStatus
+ } deriving (Eq, Show)
+
+instance ToJSON Payer where
+ toJSON payer =
+ let fundingInstr = if null $ payerFundingInstruments payer then Nothing
+ else Just $ payerFundingInstruments payer
+ in object (["payment_method" .= payerPaymentMethod payer] ++
+ maybeToList (("funding_instruments" .=) <$> fundingInstr) ++
+ maybeToList (("payer_info" .=) <$> payerInfo payer) ++
+ maybeToList (("status" .=) <$> payerStatus payer))
+
+instance FromJSON Payer where
+ parseJSON (Object obj) =
+ Payer <$>
+ obj .: "payment_method" <*>
+ (obj .:? "funding_instruments" >>= return . F.concat) <*>
+ obj .:? "payer_info" <*>
+ obj .:? "status"
+ parseJSON _ = mzero
diff --git a/src/Network/Payments/PayPal/Types/Transaction.hs b/src/Network/Payments/PayPal/Types/Transaction.hs
new file mode 100644
index 0000000..76e0731
--- /dev/null
+++ b/src/Network/Payments/PayPal/Types/Transaction.hs
@@ -0,0 +1,150 @@
+-- |
+-- Module: Network.Payments.PayPal.Types.Transaction
+-- Copyright: (C) 2016 Braden Walters
+-- License: MIT (see LICENSE file)
+-- Maintainer: Braden Walters <vc@braden-walters.info>
+-- Stability: experimental
+-- Portability: ghc
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Network.Payments.PayPal.Types.Transaction
+( Details(..)
+, Amount(..)
+, Item(..)
+, ItemList(..)
+, Transaction(..)
+) where
+
+#if __GLASGOW_HASKELL__ < 710
+import Control.Applicative
+#endif
+import Control.Monad
+import Data.Aeson
+import Data.Aeson.Types
+import Data.Maybe
+import qualified Data.Text as T
+import Network.Payments.PayPal.Types.Address
+import Network.Payments.PayPal.Types.Currency
+
+-- |Details about the amount of a transaction.
+data Details = Details
+ { detailsShipping :: MonetaryAmount
+ , detailsSubtotal :: MonetaryAmount
+ , detailsTax :: MonetaryAmount
+ } deriving (Eq, Show)
+
+instance ToJSON Details where
+ toJSON details =
+ object ["shipping" .= detailsShipping details,
+ "subtotal" .= detailsSubtotal details,
+ "tax" .= detailsTax details]
+
+instance FromJSON Details where
+ parseJSON (Object obj) =
+ Details <$>
+ obj .: "shipping" <*>
+ obj .: "subtotal" <*>
+ obj .: "tax"
+ parseJSON _ = mzero
+
+-- |Amount of a transaction and its currency. The details must sum up to the
+-- total or the request is rejected.
+data Amount = Amount
+ { amountCurrency :: Currency
+ , amountTotal :: MonetaryAmount
+ , amountDetails :: Details
+ } deriving (Eq, Show)
+
+instance ToJSON Amount where
+ toJSON amt =
+ object ["currency" .= amountCurrency amt,
+ "total" .= amountTotal amt,
+ "details" .= amountDetails amt]
+
+instance FromJSON Amount where
+ parseJSON (Object obj) =
+ Amount <$>
+ obj .: "currency" <*>
+ obj .: "total" <*>
+ obj .: "details"
+ parseJSON _ = mzero
+
+-- |An individual item being purchased.
+data Item = Item
+ { itemQuantity :: Integer
+ , itemName :: String
+ , itemPrice :: MonetaryAmount
+ , itemCurrency :: Currency
+ , itemSku :: String
+ , itemDescription :: Maybe String
+ } deriving (Eq, Show)
+
+instance ToJSON Item where
+ toJSON item =
+ object (["quantity" .= itemQuantity item,
+ "name" .= itemName item,
+ "price" .= itemPrice item,
+ "currency" .= itemCurrency item,
+ "sku" .= itemSku item] ++
+ maybeToList (("description" .=) <$> itemDescription item))
+
+instance FromJSON Item where
+ parseJSON (Object obj) =
+ Item <$>
+ (obj .: "quantity" >>= parseFuzzyJSONInt) <*>
+ obj .: "name" <*>
+ obj .: "price" <*>
+ obj .: "currency" <*>
+ obj .: "sku" <*>
+ obj .:? "description"
+ parseJSON _ = mzero
+
+-- |A list of items being purchased and the shipping address if one exists.
+data ItemList = ItemList
+ { itemListItems :: [Item]
+ , itemListShippingAddress :: Maybe ShippingAddress
+ } deriving (Eq, Show)
+
+instance ToJSON ItemList where
+ toJSON list =
+ object (["items" .= itemListItems list] ++
+ maybeToList (("shipping_address" .=) <$>
+ itemListShippingAddress list))
+
+instance FromJSON ItemList where
+ parseJSON (Object obj) =
+ ItemList <$>
+ obj .: "items" <*>
+ obj .:? "shipping_address"
+ parseJSON _ = mzero
+
+-- |Details about a financial transaction over PayPal.
+data Transaction = Transaction
+ { transactAmount :: Amount
+ , transactDescription :: Maybe String
+ , transactItemList :: ItemList
+ } deriving (Eq, Show)
+
+instance ToJSON Transaction where
+ toJSON trans =
+ object (["amount" .= transactAmount trans,
+ "item_list" .= transactItemList trans] ++
+ maybeToList (("description" .=) <$> transactDescription trans))
+
+instance FromJSON Transaction where
+ parseJSON (Object obj) =
+ Transaction <$>
+ obj .: "amount" <*>
+ obj .:? "description" <*>
+ obj .: "item_list"
+ parseJSON _ = mzero
+
+-- |This takes either a string or a number and tries to produce an integer out
+-- of it. This is necessary because PayPal apparently returns different types
+-- for the same data depending on the usage...
+parseFuzzyJSONInt :: (Integral a, Read a) => Value -> Parser a
+parseFuzzyJSONInt (String txt) = return $ read $ T.unpack txt
+parseFuzzyJSONInt (Number num) = return $ round num
+parseFuzzyJSONInt _ = mzero