diff --git a/Example.hs b/Example.hs
--- a/Example.hs
+++ b/Example.hs
@@ -3,9 +3,9 @@
module Main where
import Prelude hiding (getLine, lookup, putStr, putStrLn)
-import Control.Applicative
import Data.Text (Text)
import Data.Text.IO
+
import qualified PayPal.Adaptive as PP
import qualified PayPal.Adaptive.Deposit as DP
import qualified PayPal.Adaptive.Lookup as LP
@@ -29,39 +29,57 @@
main :: IO ()
main = do
+
+ exampleWithdrawal
+
+ payKey <- startExampleDeposit
+
+ putStrLn "-- Go here and use the other account's password to approve the payment:"
+ putStrLn (DP.approvalUrl client payKey)
+ putStrLn ""
+ putStrLn "-- Once that's done press enter ..."
+ _ <- getLine
+
+ finishExampleDeposit payKey
+
+
+exampleWithdrawal :: IO ()
+exampleWithdrawal = do
putStrLn "-- Sending money to another PayPal account."
- resp <- WD.req client withdrawal
+ resp <- WD.request client withdrawal
case resp of
- Left e -> print e
+ Left e -> error (show e)
Right withdrawalResp -> do
print withdrawalResp
putStrLn ""
- putStrLn "-- Creating a payment from another account to us."
- resp2 <- DP.req client deposit
- putStrLn ""
- case resp2 of
- Left e2 -> print e2
- Right payKey -> do
- putStrLn "-- Go here and use the other account's password to approve the payment:"
- putStrLn (DP.approvalUrl client payKey)
- putStrLn ""
- putStrLn "-- Once that's done press enter ..."
- _ <- getLine
+startExampleDeposit :: IO PP.PayKey
+startExampleDeposit = do
+ putStrLn "-- Creating a payment from another account to us."
+ resp <- DP.request client deposit
+ putStrLn ""
+ case resp of
+ Left e -> error (show e)
+ Right (_,payResp) -> return (PP._prPayKey payResp)
- putStrLn "-- Now looking up the payment on PayPal to make sure it succeeded."
- resp3 <- (PP.checkComplete =<<) <$> LP.req client (LP.LookupPayKey payKey)
- case resp3 of
- Left e3 -> print e3
- Right completePayment -> print completePayment
+finishExampleDeposit :: PP.PayKey -> IO ()
+finishExampleDeposit payKey = do
+ putStrLn "-- Now looking up the payment on PayPal to make sure it succeeded."
+ resp <- LP.request client (LP.LookupPayKey payKey)
+ case resp of
+ Left e -> error (show e)
+ Right (_,payResp) ->
+ case PP.checkComplete payResp of
+ Left e2 -> error (show e2)
+ Right completePayment -> print completePayment
client :: PP.Client
client = PP.Client
{ PP._clAppId = "APP-80W284485P519543T" -- Currently the ID for all sandbox apps.
, PP._clUserId = userId
- , PP._clEnv = PP.Sandbox
+ , PP._clEnvironment = PP.Sandbox
, PP._clPassword = password
- , PP._clSig = sig
+ , PP._clSignature = sig
, PP._clAccountEmail = accountEmail
}
diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -1,6 +1,6 @@
# Intro
-A high-level Haskell client for a limited part of PayPal's [Adaptive Payments API](https://developer.paypal.com/docs/classic/products/adaptive-payments/).
+A Haskell client for a limited part of PayPal's [Adaptive Payments API](https://developer.paypal.com/docs/classic/products/adaptive-payments/).
Covers only sending, receiving, and looking up payments. Only supports handling a single payment per request, and doesn't cover sending payments that involve more than two parties.
diff --git a/paypal-adaptive-hoops.cabal b/paypal-adaptive-hoops.cabal
--- a/paypal-adaptive-hoops.cabal
+++ b/paypal-adaptive-hoops.cabal
@@ -1,5 +1,5 @@
name: paypal-adaptive-hoops
-version: 0.11.0.2
+version: 0.13.1.0
author: Ian Grant Jeffries
maintainer: ian@housejeffries.com
category: Web
@@ -15,16 +15,26 @@
library
hs-source-dirs: src
exposed-modules: PayPal.Adaptive
+ PayPal.Adaptive.Core.Internal
PayPal.Adaptive.Deposit
PayPal.Adaptive.Lookup
PayPal.Adaptive.Withdrawal
- PayPal.Adaptive.Internal
- other-modules: PayPal.Adaptive.Core
+ other-modules: Import
+ PayPal.Adaptive.Core.Client
+ PayPal.Adaptive.Core.Error
+ PayPal.Adaptive.Core.Money
+ PayPal.Adaptive.Core.PayResponse
+ PayPal.Adaptive.Core.PayResponse.PaymentInfo
+ PayPal.Adaptive.Core.PayResponse.PaymentInfo.Receiver
+ PayPal.Adaptive.Core.PayResponse.PaymentInfo.TransactionId
+ PayPal.Adaptive.Core.PayResponse.PaymentInfo.TransactionStatus
+ PayPal.Adaptive.Core.PayResponse.PayKey
+ PayPal.Adaptive.Core.PayResponse.PayStatus
+ PayPal.Adaptive.Core.Processing
default-language: Haskell2010
ghc-options: -Wall
default-extensions: OverloadedStrings
- other-extensions: GADTs
- , MultiWayIf
+ other-extensions: MultiWayIf
, TemplateHaskell
build-depends: aeson >= 0.8 && < 0.10
@@ -44,9 +54,7 @@
type: exitcode-stdio-1.0
hs-source-dirs: tests
main-is: Local.hs
- other-modules: Local.Money
- Local.Parser
- Utils
+ other-modules: Import
default-language: Haskell2010
ghc-options: -Wall
default-extensions: OverloadedStrings
@@ -56,16 +64,17 @@
, bytestring
, paypal-adaptive-hoops
, text
+ , directory >= 1.2 && < 1.3
+ , filepath >= 1.4 && < 1.5
, HUnit >= 1.2 && < 1.3
, test-framework >= 0.8 && < 0.9
, test-framework-hunit >= 0.3 && < 0.4
- , unordered-containers >= 0.2 && < 0.3
test-suite remote
type: exitcode-stdio-1.0
hs-source-dirs: tests
main-is: Remote.hs
- other-modules: Utils
+ other-modules: Import
default-language: Haskell2010
ghc-options: -Wall
default-extensions: OverloadedStrings
@@ -75,10 +84,9 @@
, bytestring
, paypal-adaptive-hoops
, text
- , HUnit >= 1.2 && < 1.3
- , test-framework >= 0.8 && < 0.9
- , test-framework-hunit >= 0.3 && < 0.4
- , unordered-containers >= 0.2 && < 0.3
+ , HUnit
+ , test-framework
+ , test-framework-hunit
executable example
main-is: Example.hs
diff --git a/src/Import.hs b/src/Import.hs
new file mode 100644
--- /dev/null
+++ b/src/Import.hs
@@ -0,0 +1,9 @@
+
+module Import (module Import) where
+
+import Control.Lens as Import hiding ((.=))
+import Data.Aeson as Import
+import Data.Monoid as Import
+import Data.Text as Import (Text)
+import Data.Traversable as Import
+import Data.Vector as Import (Vector)
diff --git a/src/PayPal/Adaptive.hs b/src/PayPal/Adaptive.hs
--- a/src/PayPal/Adaptive.hs
+++ b/src/PayPal/Adaptive.hs
@@ -1,44 +1,23 @@
-{-# LANGUAGE TemplateHaskell #-}
module PayPal.Adaptive (
-
-- * Client
- Client (..)
- , Env (..)
+ module PayPal.Adaptive.Core.Client
- -- * Errors
- , AdaptiveErr (..)
+ -- * Error
+ , module PayPal.Adaptive.Core.Error
- -- * Payment Responses
- , PayResp (..)
- , CompletePayResp (..)
- , checkComplete
- , PayExecStatus (..)
- , PayKey (..)
- , PayInfo (..)
- , Receiver (..)
- , TransactionId (..)
- , TransactionStatus(..)
+ -- * PayResponse
+ , module PayPal.Adaptive.Core.PayResponse
- -- * Money
- , Money (..)
- , m2Currency
- , m2PayPal
+ -- * Processing
+ , module PayPal.Adaptive.Core.Processing
- , module PayPal.Adaptive
+ -- * Money
+ , module PayPal.Adaptive.Core.Money
) where
-import Control.Lens
-import PayPal.Adaptive.Core
-
--- * Lenses
-$(makeLenses ''Client)
-$(makeLenses ''CompletePayResp)
-$(makePrisms ''AdaptiveErr)
-$(makePrisms ''Env)
-$(makePrisms ''PayExecStatus)
-$(makeLenses ''PayInfo)
-$(makeLenses ''PayResp)
-$(makeLenses ''Receiver)
-$(makePrisms ''TransactionId)
-$(makePrisms ''TransactionStatus)
+import PayPal.Adaptive.Core.Client
+import PayPal.Adaptive.Core.Error
+import PayPal.Adaptive.Core.Money
+import PayPal.Adaptive.Core.PayResponse
+import PayPal.Adaptive.Core.Processing
diff --git a/src/PayPal/Adaptive/Core.hs b/src/PayPal/Adaptive/Core.hs
deleted file mode 100644
--- a/src/PayPal/Adaptive/Core.hs
+++ /dev/null
@@ -1,367 +0,0 @@
-{-# LANGUAGE MultiWayIf #-}
-{-# LANGUAGE TemplateHaskell #-}
-
-module PayPal.Adaptive.Core where
-
-import Prelude hiding (mapM)
-import Control.Applicative
-import Control.Exception
-import Control.Lens hiding ((.=))
-import Data.Aeson
-import Data.Aeson.TH hiding (Options)
-import Data.Aeson.Types hiding (Options)
-import Data.ByteString.Lazy (ByteString)
-import Data.Char
-import Data.Maybe
-import Data.Monoid
-import Data.Text (Text)
-import qualified Data.Text as T
-import Data.Text.Encoding
-import Data.Text.Read
-import Data.Traversable
-import qualified Data.Vector as V
-import Network.Wreq
-
---------------------------------------------------
--- Client
---------------------------------------------------
-
-data Client = Client
- { _clAppId :: Text
- , _clUserId :: Text
- , _clEnv :: Env
- , _clPassword :: Text
- , _clSig :: Text
- -- | Not needed for authentication, but deposits are sent
- -- to here and withdrawals are sent from here. Must be the
- -- email associated with your PayPal app.
- , _clAccountEmail :: Text
- } deriving (Eq, Show)
-
-data Env = Sandbox | Production deriving (Eq, Show, Read)
-
---------------------------------------------------
--- Errors
---------------------------------------------------
-
--- | Text is an error message in all the below types.
---
--- AeShouldNotHappen is meant to cover PayPal responses to API requests
--- that this library doesn't support sending in the first place.
--- TODO: is this actually how we're using it?
-data AdaptiveErr
- = AeConnectionErr Text
- | AeDecodeFailed ByteString Text
- | AeInvalidCredentials
- -- ^ Just a wrapper around an AeErrCodes Int.
- | AeNoSuchEmail
- -- ^ Just a wrapper around an AeErrCodes Int. Raised when the Deposit
- -- sender email or the Withdrawal account email doesn't exist.
- | AeErrCodes [Int]
- | AePending PayResp
- | AeRefused PayResp
- | AeShouldNotHappen PayResp Text
- deriving (Eq, Show)
-
--- Error responses are what's returned if, e.g., your password is incorrect.
---
--- Here's an example error response. Only the parts we parse are included.
---
--- {
--- "error": [
--- {
--- "errorId": "111111",
--- }
--- ]
--- }
-instance FromJSON AdaptiveErr where
- parseJSON = withObject "error response" $ \o ->
- AeErrCodes . V.toList <$> (mapM parseErrId =<< o .: "error")
-
--- | Exported by PayPal.Adaptive.Internal
-parseErrId :: Value -> Parser Int
-parseErrId = withObject "error array item" $ \o -> do
- a <- o .: "errorId"
- case decimal a of
- Left _ -> fail "Could not parse error response code to Int"
- Right (b,_) -> return b
-
---------------------------------------------------
--- * Payment Responses
---------------------------------------------------
-
--- | Used for forgiving attempts to parse PayPal responses. For instance,
--- this library never expects more than one PayInfo. We still try to
--- parse them as a list here so we can still sucessfully parse a PayResp
--- to use in an 'AdaptiveError' if for some reason more than one 'PayInfo'
--- is returned
-data PayResp = PayResp
- { _prPayError :: Maybe Text
- , _prPayExecStatus :: PayExecStatus
- , _prPayKey :: PayKey
- , _prPayInfos :: [PayInfo]
- } deriving (Eq, Show)
-
--- | A version of 'PayResp' for completed transactions.
---
--- Status fields are omitted since they should be complete.
---
--- Has no separate field for a 'PayInfo' list since successful transactions
--- will always have exactly one. Instead the pay info fields have been
--- flattened into the top level of this structure.
-data CompletePayResp = CompletePayResp
- { _crPayKey :: PayKey
- , _crReceiver :: Receiver
- , _crSenderTransactionId :: TransactionId
- , _crTransactionId :: TransactionId
- } deriving (Eq, Show)
-
-checkComplete :: PayResp -> Either AdaptiveErr CompletePayResp
-checkComplete pr = do
- errorFieldNothing pr
- payExecStatusCompleted pr
- checkPayKey pr
- info <- getPayInfo pr
- sid <- transactionIdJust pr (_piSenderTransactionId info)
- transactionStatusCompleted pr info
- tid <- transactionIdJust pr (_piTransactionId info)
- return $ CompletePayResp (_prPayKey pr) (_piReceiver info) sid tid
-
-instance FromJSON PayResp where
- parseJSON = withObject "PayResp" $ \o -> do
- e <- o .:? "payErrorList"
- k <- o .: "payKey"
-
- s <- o .:? "paymentExecStatus"
- s' <- o .:? "status"
- status <- maybe (fail "no paymentExecStatus or status") return (if isJust s then s else s')
-
- a <- o .:? "paymentInfoList"
- case a of
- Nothing -> return $ PayResp e status k mempty
- Just v -> do
- infos <- v .:? "paymentInfo" .!= mempty
- return $ PayResp e status k infos
-
--- | This refers to the processing of this request. To make sure a payment
--- has actually gone through, check 'TransactionStatus' instead.
---
--- PayPal returns this using the JSON object key "paymentExecStatus"
--- in responses to Withdrawal and Deposit and "status" in responses to
--- LookupPayment.
-data PayExecStatus
- = PeCreated
- | PeCompleted
- | PeIncomplete
- | PeError
- | PeReversalError
- | PeProcessing
- | PePending
- deriving (Eq, Show, Read)
-
--- | Expires after three hours.
---
---
-newtype PayKey = PayKey { _unPayKey :: Text } deriving (Eq, Show)
-
-instance FromJSON PayKey where
- parseJSON = withText "PayKey" $ return . PayKey
-
-instance ToJSON PayKey where
- toJSON (PayKey a) = toJSON a
-
--- | Right toPayPal responses return a PayInfo along with a
--- _piTransactionStatus Just, with some exceptions.
---
--- 1. Withdrawals to nonexistent accounts return no PayInfos.
---
--- 2. Lookups on such transactions return one PayInfo with a
--- _piTransactionStatus of Nothing.
---
--- 3. Deposits don't return PayInfos.
---
--- 4. Lookups on such transactions return one PayInfo with a
--- _piTransactionStatus of Nothing.
---
--- NOTE: We use the same newtype for both _piSenderTransactionId and
--- _piTransactionStatus. They will have different values, but either
--- can be used to look up a payment.
-data PayInfo = PayInfo
- { _piReceiver :: Receiver
- , _piSenderTransactionId :: Maybe TransactionId
- , _piTransactionStatus :: Maybe TransactionStatus
- , _piTransactionId :: Maybe TransactionId
- } deriving (Eq, Show)
-
-data Receiver = Receiver
- { _reAmount :: Text
- -- ^ Haven't converted this to Money yet because I'm not sure how
- -- to determine its currency.
- , _reEmail :: Text
- , _reAccountId :: Text
- } deriving (Eq, Show)
-
-newtype TransactionId = TransactionId { _unTransactionId :: Text } deriving (Eq, Show)
-
-instance FromJSON TransactionId where
- parseJSON = withText "TransactionId" $ return . TransactionId
-
-instance ToJSON TransactionId where
- toJSON (TransactionId a) = toJSON a
-
-data TransactionStatus
- = TsCompleted
- | TsPending
- | TsCreated
- | TsPartiallyRefunded
- | TsDenied
- | TsProcessing
- | TsReversed
- | TsRefunded
- | TsFailed
- deriving (Eq, Show, Read)
-
---------------------------------------------------
--- Money
---------------------------------------------------
-
-data Money = USD { _usdCents :: Int } deriving (Eq, Show)
-
--- NOTE: Once we add more currencies this instance will violate the
--- Monoid laws.
-instance Monoid Money where
- mempty = USD 0
- mappend (USD c1) (USD c2) = USD $ c1 + c2
-
-m2Currency :: Money -> Text
-m2Currency (USD _) = "USD"
-
-m2PayPal :: Money -> String
-m2PayPal (USD c) =
- let s = show (abs c)
- a = case length s of
- 0 -> "0.00"
- 1 -> "0.0" <> s
- 2 -> "0." <> s
- _ -> tailInsert 2 '.' s
- in if c < 0 then '-':a else a
-
- where
- tailInsert :: Int -> a -> [a] -> [a]
- tailInsert i x xs =
- let (ys, zs) = splitAt i (reverse xs)
- in reverse (ys <> pure x <> zs)
-
---------------------------------------------------
--- Internal Helpers
---------------------------------------------------
-
--- | "en_US" is hardcoded because it's the only supported error language.
-requestEnvelope :: Value
-requestEnvelope = object ["errorLanguage" .= ("en_US" :: Text)]
-
-ppPost :: (ToJSON a) => Client -> Text -> a -> IO (Either AdaptiveErr (Response ByteString))
-ppPost c endpoint p = catch (return . Right =<< runPost) handler
- where
- runPost :: IO (Response ByteString)
- runPost = postWith opts (clBaseUrl <> T.unpack endpoint) (toJSON p)
-
- clBaseUrl :: String
- clBaseUrl =
- case _clEnv c of
- Sandbox -> "https://svcs.sandbox.paypal.com/AdaptivePayments/"
- Production -> "https://svcs.paypal.com/AdaptivePayments/"
-
- handler :: SomeException -> IO (Either AdaptiveErr (Response ByteString))
- handler e = return . Left . AeConnectionErr . T.pack . show $ e
-
- opts :: Options
- opts = defaults
- & header "X-PAYPAL-SECURITY-USERID" .~ [ encodeUtf8 (_clUserId c) ]
- & header "X-PAYPAL-SECURITY-PASSWORD" .~ [ encodeUtf8 (_clPassword c) ]
- & header "X-PAYPAL-SECURITY-SIGNATURE" .~ [ encodeUtf8 (_clSig c) ]
- & header "X-PAYPAL-APPLICATION-ID" .~ [ encodeUtf8 (_clAppId c) ]
- & header "X-PAYPAL-REQUEST-DATA-FORMAT" .~ [ "JSON" ]
- & header "X-PAYPAL-RESPONSE-DATA-FORMAT" .~ [ "JSON" ]
-
-ppDecode :: Response ByteString -> Either AdaptiveErr PayResp
-ppDecode r =
- let b = r ^. responseBody
- in case eitherDecode b of
- Right d -> Right d
- Left e -> -- If the response isn't a PayResp, it might be a PayPal error message.
- case decode b of
- Just (AeErrCodes codes) -> Left $ codeErr codes
- _ -> Left $ AeDecodeFailed b (T.pack e)
- where
- codeErr :: [Int] -> AdaptiveErr
- codeErr cs =
- if | elem 520003 cs -> AeInvalidCredentials
- | elem 589039 cs -> AeNoSuchEmail
- | otherwise -> AeErrCodes cs
-
-payExecStatusCompleted :: PayResp -> Either AdaptiveErr ()
-payExecStatusCompleted a =
- case _prPayExecStatus a of
- PeCompleted -> Right ()
- PeProcessing -> Left $ AePending a
- PePending -> Left $ AePending a
- PeError -> Left $ AeRefused a
- _ -> Left $ AeShouldNotHappen a "unsupported PayExecStatus"
-
--- | TODO: this makes the assumption that an empty PayInfo list means
--- the transaction is pending. Is this always right?
-getPayInfo :: PayResp -> Either AdaptiveErr PayInfo
-getPayInfo a =
- case _prPayInfos a of
- [] -> Left $ AePending a
- [info] -> Right info
- _ -> Left $ AeShouldNotHappen a "more than one PayInfo in reponse"
-
-transactionStatusCompleted :: PayResp -> PayInfo -> Either AdaptiveErr ()
-transactionStatusCompleted a info =
- case _piTransactionStatus info of
- Just TsCompleted -> Right ()
- Just TsPending -> Left $ AePending a
- Just TsProcessing -> Left $ AePending a
- Just TsDenied -> Left $ AeRefused a
- Just TsFailed -> Left $ AeRefused a
- _ -> Left $ AeShouldNotHappen a "unsupported TransactionStatus"
-
-errorFieldNothing :: PayResp -> Either AdaptiveErr ()
-errorFieldNothing a
- | _prPayError a == Nothing = Right ()
- | otherwise = Left $ AeShouldNotHappen a
- "PayResp error field is Just in otherwise correct payment"
-
-checkPayKey :: PayResp -> Either AdaptiveErr ()
-checkPayKey a
- | T.null . _unPayKey . _prPayKey $ a =
- Left $ AeShouldNotHappen a "got a PayKey with length zero"
- | otherwise = Right ()
-
-payExecStatusCreated :: PayResp -> Either AdaptiveErr ()
-payExecStatusCreated a =
- case _prPayExecStatus a of
- PeCreated -> Right ()
- PeProcessing -> Left $ AePending a
- PePending -> Left $ AePending a
- PeError -> Left $ AeRefused a
- _ -> Left $ AeShouldNotHappen a "unsupported PayExecStatus"
-
-noPayInfo :: PayResp -> Either AdaptiveErr ()
-noPayInfo a =
- case _prPayInfos a of
- [] -> Right ()
- _ -> Left $ AeShouldNotHappen a
- "At least one PayInfo present in otherwise successful deposit resp"
-
-transactionIdJust :: PayResp -> Maybe TransactionId -> Either AdaptiveErr TransactionId
-transactionIdJust a Nothing = Left $ AeShouldNotHappen a "expected a Just for Maybe TransactionId"
-transactionIdJust _ (Just tid) = Right tid
-
-
-$(deriveFromJSON defaultOptions { constructorTagModifier = map toUpper . drop 2 } ''PayExecStatus)
-$(deriveFromJSON defaultOptions { fieldLabelModifier = (\(x:xs) -> toLower x:xs) . drop 3 } ''PayInfo)
-$(deriveFromJSON defaultOptions { fieldLabelModifier = (\(x:xs) -> toLower x:xs) . drop 3 } ''Receiver)
-$(deriveFromJSON defaultOptions { constructorTagModifier = map toUpper . camelTo '_' . drop 2 } ''TransactionStatus)
diff --git a/src/PayPal/Adaptive/Core/Client.hs b/src/PayPal/Adaptive/Core/Client.hs
new file mode 100644
--- /dev/null
+++ b/src/PayPal/Adaptive/Core/Client.hs
@@ -0,0 +1,27 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module PayPal.Adaptive.Core.Client where
+
+import Data.Aeson.TH
+import Data.Aeson.Types (camelTo)
+
+import Import
+
+data Client = Client
+ { _clAppId :: Text
+ , _clUserId :: Text
+ , _clEnvironment :: Environment
+ , _clPassword :: Text
+ , _clSignature :: Text
+ , _clAccountEmail :: Text
+ -- ^ Not needed for authentication, but deposits are sent
+ -- to here and withdrawals are sent from here. Must be the
+ -- email associated with your PayPal app.
+ } deriving (Eq, Show)
+
+data Environment = Sandbox | Production deriving (Eq, Show, Read)
+
+$(deriveJSON defaultOptions { fieldLabelModifier = camelTo '_' . drop 3 } ''Client)
+$(deriveJSON defaultOptions { constructorTagModifier = id } ''Environment)
+$(makeLenses ''Client)
+$(makePrisms ''Environment)
diff --git a/src/PayPal/Adaptive/Core/Error.hs b/src/PayPal/Adaptive/Core/Error.hs
new file mode 100644
--- /dev/null
+++ b/src/PayPal/Adaptive/Core/Error.hs
@@ -0,0 +1,60 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module PayPal.Adaptive.Core.Error where
+
+import Control.Exception
+import Data.ByteString.Lazy (ByteString)
+import Data.Text.Read
+import qualified Data.Vector as V
+
+import Import
+
+-- | Text is an error message in all the below types.
+--
+-- AeShouldNotHappen is meant to cover PayPal responses to API requests
+-- that this library doesn't support sending in the first place.
+-- TODO: is this actually how we're using it?
+data AdaptiveError
+ = AeConnectionError SomeException
+ | AeDecodeFailed ByteString Text
+ | AeErrorResponse ByteString ErrorResponse
+ deriving Show -- Eq can't be automatically derived because there's no Eq instance for SomeException.
+
+data ErrorResponse = ErrorResponse { _unErrorResponse :: [PayError] } deriving (Eq, Show)
+
+-- Error responses are what's returned if, e.g., your password is incorrect.
+instance FromJSON ErrorResponse where
+ parseJSON = withObject "ErrorResponse" $ \o ->
+ ErrorResponse . V.toList <$> (traverse parseJSON =<< o .: "error")
+
+data PayError = PayError { _errorCode :: ErrorCode
+ , _errorMessage :: Text
+ } deriving (Eq, Show)
+
+instance FromJSON PayError where
+ parseJSON = withObject "PayError" $ \o -> PayError <$> o .: "errorId" <*> o .: "message"
+
+newtype ErrorCode = ErrorCode { _unErrorCode :: Int } deriving Eq
+
+instance Show ErrorCode where
+ show n | n == invalidCredentials = "Error code " <> show (_unErrorCode n) <> " - invalid credentials"
+ | n == noSuchEmail = "Error code " <> show (_unErrorCode n) <> " - no such email"
+ | otherwise = "Error code " <> show (_unErrorCode n)
+
+instance FromJSON ErrorCode where
+ parseJSON = withText "ErrorCode" $ \t ->
+ case decimal t of
+ Left _ -> fail "Could not parse error response code to Int"
+ Right (b,_) -> return (ErrorCode b)
+
+invalidCredentials :: ErrorCode
+invalidCredentials = ErrorCode 520003
+
+-- | Raised when the Deposit sender email or the Withdrawal account email doesn't exist.
+noSuchEmail :: ErrorCode
+noSuchEmail = ErrorCode 589039
+
+$(makeLenses ''ErrorCode)
+$(makeLenses ''ErrorResponse)
+$(makeLenses ''PayError)
+$(makePrisms ''AdaptiveError)
diff --git a/src/PayPal/Adaptive/Core/Internal.hs b/src/PayPal/Adaptive/Core/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/PayPal/Adaptive/Core/Internal.hs
@@ -0,0 +1,51 @@
+{-# LANGUAGE MultiWayIf #-}
+
+module PayPal.Adaptive.Core.Internal where
+
+import Control.Exception
+import Data.ByteString.Lazy (ByteString)
+import qualified Data.Text as T
+import Data.Text.Encoding
+import Network.Wreq
+
+import Import
+import PayPal.Adaptive.Core.Client
+import PayPal.Adaptive.Core.Error
+import PayPal.Adaptive.Core.PayResponse
+
+ppPost :: (ToJSON a) => Client -> Text -> a -> IO (Either AdaptiveError ByteString)
+ppPost c endpoint p = catch (return . Right . (^.responseBody) =<< runPost) handler
+ where
+ runPost :: IO (Response ByteString)
+ runPost = postWith opts (clBaseUrl <> T.unpack endpoint) (toJSON p)
+
+ clBaseUrl :: String
+ clBaseUrl =
+ case _clEnvironment c of
+ Sandbox -> "https://svcs.sandbox.paypal.com/AdaptivePayments/"
+ Production -> "https://svcs.paypal.com/AdaptivePayments/"
+
+ handler :: SomeException -> IO (Either AdaptiveError ByteString)
+ handler e = return . Left . AeConnectionError $ e
+
+ opts :: Options
+ opts = defaults
+ & header "X-PAYPAL-SECURITY-USERID" .~ [ encodeUtf8 (_clUserId c) ]
+ & header "X-PAYPAL-SECURITY-PASSWORD" .~ [ encodeUtf8 (_clPassword c) ]
+ & header "X-PAYPAL-SECURITY-SIGNATURE" .~ [ encodeUtf8 (_clSignature c) ]
+ & header "X-PAYPAL-APPLICATION-ID" .~ [ encodeUtf8 (_clAppId c) ]
+ & header "X-PAYPAL-REQUEST-DATA-FORMAT" .~ [ "JSON" ]
+ & header "X-PAYPAL-RESPONSE-DATA-FORMAT" .~ [ "JSON" ]
+
+ppDecode :: ByteString -> Either AdaptiveError PayResponse
+ppDecode b =
+ case eitherDecode b of
+ Right d -> Right d
+ Left e ->
+ case decode b of -- If the response isn't a PayResponse, it might be a PayPal error message.
+ Just res@(ErrorResponse _) -> Left $ AeErrorResponse b res
+ _ -> Left $ AeDecodeFailed b (T.pack e)
+
+-- | "en_US" is hardcoded because it's the only supported error language.
+requestEnvelope :: Value
+requestEnvelope = object ["errorLanguage" .= ("en_US" :: Text)]
diff --git a/src/PayPal/Adaptive/Core/Money.hs b/src/PayPal/Adaptive/Core/Money.hs
new file mode 100644
--- /dev/null
+++ b/src/PayPal/Adaptive/Core/Money.hs
@@ -0,0 +1,31 @@
+
+module PayPal.Adaptive.Core.Money where
+
+import Import
+
+data Money = USD { _usdCents :: Int } deriving (Eq, Show)
+
+-- NOTE: Once we add more currencies this instance will violate the
+-- Monoid laws.
+instance Monoid Money where
+ mempty = USD 0
+ mappend (USD c1) (USD c2) = USD $ c1 + c2
+
+m2Currency :: Money -> Text
+m2Currency (USD _) = "USD"
+
+m2PayPal :: Money -> String
+m2PayPal (USD c) =
+ let s = show (abs c)
+ a = case length s of
+ 0 -> "0.00"
+ 1 -> "0.0" <> s
+ 2 -> "0." <> s
+ _ -> tailInsert 2 '.' s
+ in if c < 0 then '-':a else a
+
+ where
+ tailInsert :: Int -> a -> [a] -> [a]
+ tailInsert i x xs =
+ let (ys, zs) = splitAt i (reverse xs)
+ in reverse (ys <> pure x <> zs)
diff --git a/src/PayPal/Adaptive/Core/PayResponse.hs b/src/PayPal/Adaptive/Core/PayResponse.hs
new file mode 100644
--- /dev/null
+++ b/src/PayPal/Adaptive/Core/PayResponse.hs
@@ -0,0 +1,46 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module PayPal.Adaptive.Core.PayResponse
+ ( module Export
+ , module PayPal.Adaptive.Core.PayResponse
+ ) where
+
+import Data.Maybe (isJust)
+
+import Import
+import PayPal.Adaptive.Core.PayResponse.PayKey as Export
+import PayPal.Adaptive.Core.PayResponse.PaymentInfo as Export
+import PayPal.Adaptive.Core.PayResponse.PayStatus as Export
+
+-- | Used for forgiving attempts to parse PayPal responses. For instance,
+-- this library never expects more than one PaymentInfo. We still try to
+-- parse them as a list here so we can still sucessfully parse a PayResp
+-- to use in an 'AdaptiveError' if for some reason more than one 'PaymentInfo'
+-- is returned.
+--
+--
+data PayResponse = PayResponse
+ { _prPayError :: Maybe Text
+ -- ^ payErrorList (string) -- Information about why a payment failed.
+ , _prPayStatus :: PayStatus
+ , _prPayKey :: PayKey
+ , _prPaymentInfos :: [PaymentInfo]
+ } deriving (Eq, Show)
+
+instance FromJSON PayResponse where
+ parseJSON = withObject "PayResp" $ \o -> do
+ e <- o .:? "payErrorList"
+ k <- o .: "payKey"
+
+ s <- o .:? "paymentExecStatus"
+ s' <- o .:? "status"
+ status <- maybe (fail "no paymentExecStatus or status") return (if isJust s then s else s')
+
+ a <- o .:? "paymentInfoList"
+ case a of
+ Nothing -> return $ PayResponse e status k mempty
+ Just v -> do
+ infos <- v .:? "paymentInfo" .!= mempty
+ return $ PayResponse e status k infos
+
+$(makeLenses ''PayResponse)
diff --git a/src/PayPal/Adaptive/Core/PayResponse/PayKey.hs b/src/PayPal/Adaptive/Core/PayResponse/PayKey.hs
new file mode 100644
--- /dev/null
+++ b/src/PayPal/Adaptive/Core/PayResponse/PayKey.hs
@@ -0,0 +1,18 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module PayPal.Adaptive.Core.PayResponse.PayKey where
+
+import Import
+
+-- | Expires after three hours.
+--
+--
+newtype PayKey = PayKey { _unPayKey :: Text } deriving (Eq, Show)
+
+instance FromJSON PayKey where
+ parseJSON = withText "PayKey" $ return . PayKey
+
+instance ToJSON PayKey where
+ toJSON (PayKey a) = toJSON a
+
+$(makeLenses ''PayKey)
diff --git a/src/PayPal/Adaptive/Core/PayResponse/PayStatus.hs b/src/PayPal/Adaptive/Core/PayResponse/PayStatus.hs
new file mode 100644
--- /dev/null
+++ b/src/PayPal/Adaptive/Core/PayResponse/PayStatus.hs
@@ -0,0 +1,42 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module PayPal.Adaptive.Core.PayResponse.PayStatus where
+
+import Data.Aeson.TH
+import Data.Char (toUpper)
+
+import Import
+
+-- | This refers to the processing of this request. To make sure a payment
+-- has actually gone through, check 'TransactionStatus' as well.
+--
+-- PayPal returns this using the JSON object key "paymentExecStatus"
+-- in responses to Withdrawal and Deposit and "status" in responses to
+-- LookupPayment.
+--
+-- https://developer.paypal.com/docs/classic/api/adaptive-payments/PaymentDetails_API_Operation/
+data PayStatus
+ = PeCreated
+ -- ^ CREATED – The payment request was received; funds will be transferred once the payment is approved
+ | PeCompleted
+ -- ^ COMPLETED – The payment was successful
+ | PePending
+ -- ^ PENDING – The payment is awaiting processing
+ | PeProcessing
+ -- ^ PROCESSING – The payment is in progress
+ | PeIncomplete
+ -- ^ INCOMPLETE – Some transfers succeeded and some failed for a parallel payment or,
+ -- for a delayed chained payment, secondary receivers have not been paid
+ | PeExpired
+ -- ^ EXPIRED
+ --
+ -- NOTE: This occurs in practice, but isn't in the documentation.
+ | PeError
+ -- ^ ERROR – The payment failed and all attempted transfers failed or all completed transfers
+ -- were successfully reversed
+ | PeReversalError
+ -- ^ REVERSALERROR – One or more transfers failed when attempting to reverse a payment
+ deriving (Eq, Show, Read)
+
+$(deriveFromJSON defaultOptions { constructorTagModifier = map toUpper . drop 2 } ''PayStatus)
+$(makePrisms ''PayStatus)
diff --git a/src/PayPal/Adaptive/Core/PayResponse/PaymentInfo.hs b/src/PayPal/Adaptive/Core/PayResponse/PaymentInfo.hs
new file mode 100644
--- /dev/null
+++ b/src/PayPal/Adaptive/Core/PayResponse/PaymentInfo.hs
@@ -0,0 +1,46 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module PayPal.Adaptive.Core.PayResponse.PaymentInfo
+ ( module Export
+ , module PayPal.Adaptive.Core.PayResponse.PaymentInfo
+ ) where
+
+import Data.Aeson.TH
+import Data.Char (toLower)
+
+import Import
+import PayPal.Adaptive.Core.PayResponse.PaymentInfo.Receiver as Export
+import PayPal.Adaptive.Core.PayResponse.PaymentInfo.TransactionId as Export
+import PayPal.Adaptive.Core.PayResponse.PaymentInfo.TransactionStatus as Export
+
+-- | Right toPayPal responses return a PayInfo along with a
+-- _piTransactionStatus Just, with some exceptions.
+--
+-- 1. Withdrawals to nonexistent accounts return no PayInfos.
+--
+-- 2. Lookups on such transactions return one PayInfo with a
+-- _piTransactionStatus of Nothing.
+--
+-- 3. Deposits don't return PayInfos.
+--
+-- 4. Lookups on such transactions return one PayInfo with a
+-- _piTransactionStatus of Nothing.
+--
+-- NOTE: We use the same newtype for both _piSenderTransactionId and
+-- _piTransactionStatus. They will have different values, but either
+-- can be used to look up a payment.
+--
+--
+-- https://developer.paypal.com/docs/classic/api/adaptive-payments/PaymentDetails_API_Operation/
+--
+-- Represents the payment attempt made to a receiver of a PayRequest. If the execution of the payment has not yet completed, there are no transaction details returned.
+data PaymentInfo = PaymentInfo
+ { _piReceiver :: Receiver
+ , _piTransactionId :: Maybe TransactionId
+ , _piTransactionStatus :: Maybe TransactionStatus
+ , _piSenderTransactionId :: Maybe TransactionId
+ , _piSenderTransactionStatus :: Maybe TransactionStatus
+ } deriving (Eq, Show)
+
+$(deriveFromJSON defaultOptions { fieldLabelModifier = (\(x:xs) -> toLower x:xs) . drop 3 } ''PaymentInfo)
+$(makeLenses ''PaymentInfo)
diff --git a/src/PayPal/Adaptive/Core/PayResponse/PaymentInfo/Receiver.hs b/src/PayPal/Adaptive/Core/PayResponse/PaymentInfo/Receiver.hs
new file mode 100644
--- /dev/null
+++ b/src/PayPal/Adaptive/Core/PayResponse/PaymentInfo/Receiver.hs
@@ -0,0 +1,19 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module PayPal.Adaptive.Core.PayResponse.PaymentInfo.Receiver where
+
+import Data.Aeson.TH
+import Data.Char (toLower)
+
+import Import
+
+data Receiver = Receiver
+ { _reAmount :: Text
+ -- ^ Haven't converted this to Money yet because I'm not sure how
+ -- to determine its currency.
+ , _reEmail :: Text
+ , _reAccountId :: Text
+ } deriving (Eq, Show)
+
+$(deriveFromJSON defaultOptions { fieldLabelModifier = (\(x:xs) -> toLower x:xs) . drop 3 } ''Receiver)
+$(makeLenses ''Receiver)
diff --git a/src/PayPal/Adaptive/Core/PayResponse/PaymentInfo/TransactionId.hs b/src/PayPal/Adaptive/Core/PayResponse/PaymentInfo/TransactionId.hs
new file mode 100644
--- /dev/null
+++ b/src/PayPal/Adaptive/Core/PayResponse/PaymentInfo/TransactionId.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module PayPal.Adaptive.Core.PayResponse.PaymentInfo.TransactionId where
+
+import Import
+
+newtype TransactionId = TransactionId { _unTransactionId :: Text } deriving (Eq, Show)
+
+instance FromJSON TransactionId where
+ parseJSON = withText "TransactionId" $ return . TransactionId
+
+instance ToJSON TransactionId where
+ toJSON (TransactionId a) = toJSON a
+
+$(makeLenses ''TransactionId)
diff --git a/src/PayPal/Adaptive/Core/PayResponse/PaymentInfo/TransactionStatus.hs b/src/PayPal/Adaptive/Core/PayResponse/PaymentInfo/TransactionStatus.hs
new file mode 100644
--- /dev/null
+++ b/src/PayPal/Adaptive/Core/PayResponse/PaymentInfo/TransactionStatus.hs
@@ -0,0 +1,38 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module PayPal.Adaptive.Core.PayResponse.PaymentInfo.TransactionStatus where
+
+import Data.Aeson.TH
+import Data.Aeson.Types (camelTo)
+import Data.Char (toUpper)
+
+import Import
+
+-- | PaymentInfos have both a transactionStatus and senderTransactionStatus field.
+-- As far as I can tell the same data type can represent both of them.
+-- The comments for the data constructors come from senderTransactionStatus.
+--
+-- https://developer.paypal.com/docs/classic/api/adaptive-payments/Pay_API_Operation/
+data TransactionStatus
+ = TsCreated
+ -- ^ CREATED – The payment request was received; funds will be transferred once approval is received
+ | TsPending
+ -- ^ PENDING – The transaction is awaiting further processing
+ | TsProcessing
+ -- ^ PROCESSING – The transaction is in progress
+ | TsCompleted
+ -- ^ COMPLETED – The sender's transaction has completed
+ | TsDenied
+ -- ^ DENIED – The transaction was rejected by the receiver
+ | TsFailed
+ -- ^ FAILED – The payment failed
+ | TsRefunded
+ -- ^ REFUNDED – The payment was refunded
+ | TsPartiallyRefunded
+ -- ^ PARTIALLY_REFUNDED – Transaction was partially refunded
+ | TsReversed
+ -- ^ REVERSED – The payment was returned to the sender
+ deriving (Eq, Show, Read)
+
+$(deriveFromJSON defaultOptions { constructorTagModifier = map toUpper . camelTo '_' . drop 2 } ''TransactionStatus)
+$(makePrisms ''TransactionStatus)
diff --git a/src/PayPal/Adaptive/Core/Processing.hs b/src/PayPal/Adaptive/Core/Processing.hs
new file mode 100644
--- /dev/null
+++ b/src/PayPal/Adaptive/Core/Processing.hs
@@ -0,0 +1,92 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module PayPal.Adaptive.Core.Processing where
+
+import qualified Data.Text as T
+
+import Import
+import PayPal.Adaptive.Core.PayResponse
+
+-- | A version of 'PayResponse' for completed transactions.
+--
+-- Status fields are omitted since they should be complete.
+--
+-- Has no separate field for a 'PaymentInfo' list since successful transactions
+-- will always have exactly one. Instead the pay info fields have been
+-- flattened into the top level of this structure.
+data CompletePayResponse = CompletePayResponse
+ { _cpPayKey :: PayKey
+ , _cpReceiver :: Receiver
+ , _cpTransactionId :: TransactionId
+ , _cpSenderTransactionId :: TransactionId
+ } deriving (Eq, Show)
+
+-- | A high level data type that tries to summarize the status
+-- of a payment in simple terms (meant to be used in an 'Either',
+-- e.g. 'Either' 'NotComplete' 'CompletePayResponse').
+data NotComplete
+ = NcIncomplete Text
+ | NcFailed Text
+ | NcShouldNotHappen Text
+ deriving (Eq, Show)
+
+checkComplete :: PayResponse -> Either NotComplete CompletePayResponse
+checkComplete pr = do
+ payStatusCompleted pr
+ info <- getPaymentInfo pr
+ sid <- transactionIdJust (_piSenderTransactionId info)
+ transactionStatusCompleted (_piTransactionStatus info)
+ transactionStatusCompleted (_piSenderTransactionStatus info)
+ tid <- transactionIdJust (_piTransactionId info)
+ errorFieldNothing pr
+ return $ CompletePayResponse (_prPayKey pr) (_piReceiver info) sid tid
+ where
+ transactionIdJust :: Maybe TransactionId -> Either NotComplete TransactionId
+ transactionIdJust Nothing = Left $ NcShouldNotHappen "expected a Just for Maybe TransactionId"
+ transactionIdJust (Just tid) = Right tid
+
+ errorFieldNothing :: PayResponse -> Either NotComplete ()
+ errorFieldNothing a
+ | _prPayError a == Nothing = Right ()
+ | otherwise =
+ Left $ NcShouldNotHappen "PayResponse error field is Just in otherwise correct payment"
+
+ transactionStatusCompleted :: Maybe TransactionStatus -> Either NotComplete ()
+ transactionStatusCompleted Nothing = Left (NcShouldNotHappen "TransactionStatus is Nothing")
+ transactionStatusCompleted (Just status) =
+ let msg = "TransactionStatus " <> T.pack (show status)
+ in case status of
+ TsCreated -> Left (NcIncomplete msg)
+ TsPending -> Left (NcIncomplete msg)
+ TsProcessing -> Left (NcIncomplete msg)
+ TsCompleted -> Right ()
+ TsDenied -> Left (NcFailed msg)
+ TsFailed -> Left (NcFailed msg)
+ TsRefunded -> Left (NcShouldNotHappen msg)
+ TsPartiallyRefunded -> Left (NcShouldNotHappen msg)
+ TsReversed -> Left (NcShouldNotHappen msg)
+
+ payStatusCompleted :: PayResponse -> Either NotComplete ()
+ payStatusCompleted a =
+ let status = _prPayStatus a
+ msg = "_prPayStatus: " <> T.pack (show status)
+ in case status of
+ PeCreated -> Left (NcIncomplete msg)
+ PeCompleted -> Right ()
+ PePending -> Left (NcIncomplete msg)
+ PeProcessing -> Left (NcIncomplete msg)
+ PeIncomplete -> Left (NcShouldNotHappen msg) -- PeIncomplete has to do with delayed or chained
+ -- payments, which we don't support.
+ PeExpired -> Left (NcFailed msg)
+ PeError -> Left (NcFailed msg)
+ PeReversalError -> Left (NcShouldNotHappen msg)
+
+getPaymentInfo :: PayResponse -> Either NotComplete PaymentInfo
+getPaymentInfo a =
+ case _prPaymentInfos a of
+ [] -> Left $ NcIncomplete "no PaymentInfo"
+ [info] -> Right info
+ _ -> Left $ NcShouldNotHappen "more than one PaymentInfo"
+
+$(makeLenses ''CompletePayResponse)
+$(makePrisms ''NotComplete)
diff --git a/src/PayPal/Adaptive/Deposit.hs b/src/PayPal/Adaptive/Deposit.hs
--- a/src/PayPal/Adaptive/Deposit.hs
+++ b/src/PayPal/Adaptive/Deposit.hs
@@ -17,12 +17,15 @@
module PayPal.Adaptive.Deposit where
-import Control.Lens hiding ((.=))
-import Data.Aeson
-import Data.Monoid
-import Data.Text (Text)
-import PayPal.Adaptive.Core
+import Data.ByteString.Lazy (ByteString)
+import Import
+import PayPal.Adaptive.Core.Client
+import PayPal.Adaptive.Core.Error
+import PayPal.Adaptive.Core.Internal
+import PayPal.Adaptive.Core.Money
+import PayPal.Adaptive.Core.PayResponse
+
data Deposit = Deposit
{ _amount :: Money
, _senderEmail :: Text
@@ -36,40 +39,32 @@
instance ToJSON SerializeDeposit where
toJSON (SerializeDeposit p accountEmail) = object
[ "actionType" .= ("PAY" :: Text)
- , "currencyCode" .= (m2Currency . _amount) p
- , "receiverList" .=
- object
- [ "receiver" .= [ object
- ["amount" .= m2PayPal (_amount p)
- , "email" .= accountEmail
- ]
- ]]
+ , "currencyCode" .= m2Currency (_amount p)
+ , "receiverList" .= object
+ [ "receiver" .=
+ [ object
+ [ "amount" .= m2PayPal (_amount p)
+ , "email" .= accountEmail
+ ]
+ ]
+ ]
, "returnUrl" .= _returnUrl p
, "cancelUrl" .= _cancelUrl p
, "requestEnvelope" .= requestEnvelope
, "senderEmail" .= _senderEmail p
]
-req :: Client -> Deposit -> IO (Either AdaptiveErr PayKey)
-req c d = do
+request :: Client -> Deposit -> IO (Either AdaptiveError (ByteString,PayResponse) )
+request c d = do
resp <- ppPost c "Pay" $ SerializeDeposit d (_clAccountEmail c)
- return $ do
- pr <- ppDecode =<< resp
- payExecStatusCreated pr
- noPayInfo pr
- errorFieldNothing pr
- checkPayKey pr
- Right (_prPayKey pr)
+ case resp of
+ Left e -> return $ Left e
+ Right bts -> return $ (,) bts <$> ppDecode bts
approvalUrl :: Client -> PayKey -> Text
approvalUrl c k =
- case _clEnv c of
- Sandbox ->
- "https://www.sandbox.paypal.com/cgi-bin/webscr?cmd=_ap-payment&paykey="
- <> _unPayKey k
- Production ->
- "https://www.paypal.com/cgi-bin/webscr?cmd=_ap-payment&paykey="
- <> _unPayKey k
+ case _clEnvironment c of
+ Sandbox -> "https://www.sandbox.paypal.com/cgi-bin/webscr?cmd=_ap-payment&paykey=" <> _unPayKey k
+ Production -> "https://www.paypal.com/cgi-bin/webscr?cmd=_ap-payment&paykey=" <> _unPayKey k
--- * Lenses
$(makeLenses ''Deposit)
diff --git a/src/PayPal/Adaptive/Internal.hs b/src/PayPal/Adaptive/Internal.hs
deleted file mode 100644
--- a/src/PayPal/Adaptive/Internal.hs
+++ /dev/null
@@ -1,16 +0,0 @@
-module PayPal.Adaptive.Internal
- ( ppPost
- , ppDecode
- , parseErrId
- , requestEnvelope
- , payExecStatusCompleted
- , getPayInfo
- , transactionStatusCompleted
- , errorFieldNothing
- , checkPayKey
- , payExecStatusCreated
- , noPayInfo
- , transactionIdJust
- ) where
-
-import PayPal.Adaptive.Core
diff --git a/src/PayPal/Adaptive/Lookup.hs b/src/PayPal/Adaptive/Lookup.hs
--- a/src/PayPal/Adaptive/Lookup.hs
+++ b/src/PayPal/Adaptive/Lookup.hs
@@ -1,21 +1,21 @@
-{-# LANGUAGE GADTs #-}
-
-- | Look up information about a payment.
--
--
module PayPal.Adaptive.Lookup where
-import Control.Applicative
-import Data.Aeson
-import PayPal.Adaptive.Core
+import Data.ByteString.Lazy (ByteString)
-data LookupPayment a where
- LookupTrID :: TransactionId -> LookupPayment TransactionId
- LookupPayKey :: PayKey -> LookupPayment PayKey
+import Import
+import PayPal.Adaptive.Core.Client
+import PayPal.Adaptive.Core.Error
+import PayPal.Adaptive.Core.Internal
+import PayPal.Adaptive.Core.PayResponse
-instance ToJSON (LookupPayment a) where
- toJSON (LookupTrID (TransactionId p)) =
+data LookupPayment = LookupTransactionID TransactionId | LookupPayKey PayKey deriving (Eq, Show)
+
+instance ToJSON LookupPayment where
+ toJSON (LookupTransactionID (TransactionId p)) =
object [ "transactionId" .= p
, "requestEnvelope" .= requestEnvelope
]
@@ -24,5 +24,9 @@
, "requestEnvelope" .= requestEnvelope
]
-req :: Client -> LookupPayment a -> IO (Either AdaptiveErr PayResp)
-req c l = (>>= ppDecode) <$> ppPost c "PaymentDetails" l
+request :: Client -> LookupPayment -> IO (Either AdaptiveError (ByteString,PayResponse) )
+request c l = do
+ resp <- ppPost c "PaymentDetails" l
+ case resp of
+ Left e -> return $ Left e
+ Right bts -> return $ (,) bts <$> ppDecode bts
diff --git a/src/PayPal/Adaptive/Withdrawal.hs b/src/PayPal/Adaptive/Withdrawal.hs
--- a/src/PayPal/Adaptive/Withdrawal.hs
+++ b/src/PayPal/Adaptive/Withdrawal.hs
@@ -13,11 +13,15 @@
module PayPal.Adaptive.Withdrawal where
-import Control.Lens hiding ((.=))
-import Data.Aeson
-import Data.Text (Text)
-import PayPal.Adaptive.Core
+import Data.ByteString.Lazy (ByteString)
+import Import
+import PayPal.Adaptive.Core.Client
+import PayPal.Adaptive.Core.Error
+import PayPal.Adaptive.Core.Internal
+import PayPal.Adaptive.Core.Money
+import PayPal.Adaptive.Core.PayResponse
+
data Withdrawal = Withdrawal
{ _amount :: Money
, _receiverEmail :: Text
@@ -29,7 +33,7 @@
instance ToJSON SerializeWithdrawal where
toJSON (SerializeWithdrawal p accountEmail) = object
[ "actionType" .= ("PAY" :: Text)
- , "currencyCode" .= (m2Currency . _amount) p
+ , "currencyCode" .= m2Currency (_amount p)
, "receiverList" .= object
[ "receiver" .=
[ object
@@ -46,10 +50,11 @@
-- | If a PayPal account doesn't exist yet PayPal responds with an empty
-- list of PayInfos. We return this as Left 'AePending'.
-req :: Client -> Withdrawal -> IO (Either AdaptiveErr CompletePayResp)
-req c w = do
+request :: Client -> Withdrawal -> IO (Either AdaptiveError (ByteString,PayResponse) )
+request c w = do
resp <- ppPost c "Pay" $ SerializeWithdrawal w (_clAccountEmail c)
- return $ checkComplete =<< ppDecode =<< resp
+ case resp of
+ Left e -> return $ Left e
+ Right bts -> return $ (,) bts <$> ppDecode bts
--- * Lenses
$(makeLenses ''Withdrawal)
diff --git a/tests/Import.hs b/tests/Import.hs
new file mode 100644
--- /dev/null
+++ b/tests/Import.hs
@@ -0,0 +1,29 @@
+
+module Import (module Import) where
+
+import Control.Applicative as Import
+import Data.Aeson as Import
+import Data.Foldable as Import
+import Data.Monoid as Import
+import Data.Text as Import (Text)
+import Data.Traversable as Import
+
+import Test.HUnit
+
+assertJust :: String -> Maybe a -> IO a
+assertJust s a =
+ case a of
+ Nothing -> assertFailure s >> fail "assertJust failed"
+ Just b -> return b
+
+assertRight :: (Show a) => Either a b -> IO b
+assertRight a =
+ case a of
+ Left e -> assertFailure (show e) >> fail "assertRight failed"
+ Right b -> return b
+
+assertLeft :: (Show b) => Either a b -> IO a
+assertLeft a =
+ case a of
+ Left e -> return e
+ Right b -> assertFailure (show b) >> fail "assertLeft failed"
diff --git a/tests/Local.hs b/tests/Local.hs
--- a/tests/Local.hs
+++ b/tests/Local.hs
@@ -1,11 +1,13 @@
+
module Main where
+import Local.BulkParser
import Local.Money
import Local.Parser
import Test.Framework (Test, defaultMain)
tests :: [Test]
-tests = [unitMoney, unitParser]
+tests = [unitMoney, unitParser, bulkParser]
main :: IO ()
main = defaultMain tests
diff --git a/tests/Local/Money.hs b/tests/Local/Money.hs
deleted file mode 100644
--- a/tests/Local/Money.hs
+++ /dev/null
@@ -1,46 +0,0 @@
-module Local.Money (unitMoney) where
-
-import PayPal.Adaptive
-import Test.Framework
-import Test.Framework.Providers.HUnit (testCase)
-import Test.HUnit (Assertion, (@=?))
-
-unitMoney :: Test
-unitMoney = testGroup "money"
- [ testCase "handle large negative amount correctly" largeNegative
- , testCase "handle negative amount correctly" negative
- , testCase "handle 0 correctly" zero
- , testCase "handle 1 correctly" oneDigit
- , testCase "handle 10 correctly" twoDigitsTrailingZero
- , testCase "show both decimals even if both are zero" threeDigitsTrailingZeros
- , testCase "show both decimals even if the second is zero" threeDigitsTrailingZero
- , testCase "handles large amount correctly" largeAmount
- ]
-
-testM2P :: Int -> String -> Assertion
-testM2P input correct =
- correct @=? m2PayPal USD { _usdCents = input }
-
-largeNegative :: Assertion
-largeNegative = testM2P (-98783) "-987.83"
-
-negative :: Assertion
-negative = testM2P (-1) "-0.01"
-
-zero :: Assertion
-zero = testM2P 0 "0.00"
-
-oneDigit :: Assertion
-oneDigit = testM2P 1 "0.01"
-
-twoDigitsTrailingZero :: Assertion
-twoDigitsTrailingZero = testM2P 10 "0.10"
-
-threeDigitsTrailingZeros :: Assertion
-threeDigitsTrailingZeros = testM2P 100 "1.00"
-
-threeDigitsTrailingZero :: Assertion
-threeDigitsTrailingZero = testM2P 110 "1.10"
-
-largeAmount :: Assertion
-largeAmount = testM2P 792874 "7928.74"
diff --git a/tests/Local/Parser.hs b/tests/Local/Parser.hs
deleted file mode 100644
--- a/tests/Local/Parser.hs
+++ /dev/null
@@ -1,121 +0,0 @@
-module Local.Parser (unitParser) where
-
-import Data.Aeson
-import qualified Data.ByteString.Lazy as B
-import qualified Data.ByteString.Lazy.Char8 as BSC
-import Data.Char (isSpace)
-import PayPal.Adaptive
-import qualified PayPal.Adaptive.Deposit as DP
-import qualified PayPal.Adaptive.Withdrawal as WD
-import Test.Framework (Test, testGroup)
-import Test.Framework.Providers.HUnit (testCase)
-import Test.HUnit (Assertion, (@=?))
-import Utils
-
-unitParser :: Test
-unitParser = testGroup "parsers"
- [ testCase "correctly encodes a Withdrawal" serializeWithdrawal
- , testCase "correctly encodes a Deposit" serializeDeposit
- , testCase "correctly decodes a Withdrawal response" parseWithdrawalResp
- , testCase "correctly decodes a Deposit response" parseDepositResp
- , testCase "correctly decodes a LookupPayment response" parseLookupResp
- , testCase "correctly decodes an error code response" parseErrResp
- ]
-
-eqSerialized :: (ToJSON a) => FilePath -> a -> Assertion
-eqSerialized x y = do
- expected <- B.readFile x
- let actual = encode y
- filterBS expected @=? filterBS actual
- where
- filterBS :: BSC.ByteString -> BSC.ByteString
- filterBS = BSC.filter (not . isSpace)
-
-eqParsed :: (Show a, Eq a, FromJSON a) => a -> FilePath -> Assertion
-eqParsed expected x = do
- b <- B.readFile x
- actual <- assertRight (eitherDecode b)
- expected @=? actual
-
-serializeWithdrawal :: Assertion
-serializeWithdrawal = "tests/Local/json/serializeWithdrawal.json" `eqSerialized` a
- where
- a :: WD.SerializeWithdrawal
- a = WD.SerializeWithdrawal b "payments@mail.com"
-
- b :: WD.Withdrawal
- b = WD.Withdrawal
- { WD._amount = USD 100
- , WD._receiverEmail = "user@mail.com"
- }
-
-serializeDeposit :: Assertion
-serializeDeposit = "tests/Local/json/serializeDeposit.json" `eqSerialized` a
- where
- a :: DP.SerializeDeposit
- a = DP.SerializeDeposit b "payments@mail.com"
-
- b :: DP.Deposit
- b = DP.Deposit
- { DP._amount = USD 100
- , DP._senderEmail = "user@mail.com"
- , DP._returnUrl = "https://example.com/"
- , DP._cancelUrl = "https://example.com/cancel"
- }
-
-parseWithdrawalResp :: Assertion
-parseWithdrawalResp = expected `eqParsed` "tests/Local/json/parseWithdrawalResp.json"
- where
- expected = PayResp
- { _prPayError = Nothing
- , _prPayExecStatus = PeCompleted
- , _prPayKey = PayKey "AP-21C62741YR509274N"
- , _prPayInfos = [p]
- }
- p = PayInfo
- { _piReceiver = r
- , _piSenderTransactionId = Just (TransactionId "7TU31598YN877045D")
- , _piTransactionStatus = Just TsCompleted
- , _piTransactionId = Just (TransactionId "1DG71997KF688883E")
- }
- r = Receiver
- { _reAmount = "1.00"
- , _reEmail = "user@mail.com"
- , _reAccountId = "69D9D7KVA6WAN"
- }
-
-parseDepositResp :: Assertion
-parseDepositResp = expected `eqParsed` "tests/Local/json/parseDepositResp.json"
- where
- expected = PayResp
- { _prPayError = Nothing
- , _prPayExecStatus = PeCreated
- , _prPayKey = PayKey "AP-3NL080742J1818731"
- , _prPayInfos = []
- }
-
-parseLookupResp :: Assertion
-parseLookupResp = expected `eqParsed` "tests/Local/json/parseLookupResp.json"
- where
- expected = PayResp
- { _prPayError = Nothing
- , _prPayExecStatus = PeCompleted
- , _prPayKey = PayKey "AP-5XY65045XE4097324"
- , _prPayInfos = [p]
- }
- p = PayInfo
- { _piReceiver = r
- , _piSenderTransactionId = Just (TransactionId "9U084775U2533540T")
- , _piTransactionStatus = Just TsCompleted
- , _piTransactionId = Just (TransactionId "0CL88103PF900230J")
- }
- r = Receiver
- { _reAmount = "1.00"
- , _reEmail = "user@mail.com"
- , _reAccountId = "69D9D7KVA6WAN"
- }
-
-parseErrResp :: Assertion
-parseErrResp = expected `eqParsed` "tests/Local/json/parseErrResp.json"
- where
- expected = AeErrCodes [560022]
diff --git a/tests/Remote.hs b/tests/Remote.hs
--- a/tests/Remote.hs
+++ b/tests/Remote.hs
@@ -2,21 +2,17 @@
module Main where
-import Control.Applicative
import Control.Monad
-import Data.Aeson
import qualified Data.ByteString.Lazy as B
-import Data.HashMap.Strict as H
-import Data.Text (Text)
+import Test.Framework (Test, defaultMain, testGroup)
+import Test.Framework.Providers.HUnit (testCase)
+import Test.HUnit hiding (Test)
+
+import Import
import PayPal.Adaptive
import qualified PayPal.Adaptive.Deposit as DP
-import PayPal.Adaptive.Internal
import qualified PayPal.Adaptive.Lookup as LP
import qualified PayPal.Adaptive.Withdrawal as WD
-import Test.Framework (Test, defaultMain, testGroup)
-import Test.Framework.Providers.HUnit (testCase)
-import Test.HUnit hiding (Test)
-import Utils
main :: IO ()
main = defaultMain [integrationRemote]
@@ -46,29 +42,17 @@
depositUserAddressDNE
]
--- | Currently the ID for all sandbox apps.
-appId :: Text
-appId = "APP-80W284485P519543T"
+newtype TestSettings = TestSettings { _unTestSettings :: (Client, Text, Text) }
-instance FromJSON Client where
- parseJSON = withObject "client credentials" $ \o ->
- Client appId <$>
- o .: "sandboxClientUid" <*>
- pure Sandbox <*>
- o .: "sandboxClientPassword" <*>
- o .: "sandboxClientSig" <*>
- o .: "sandboxAccountEmail"
+instance FromJSON TestSettings where
+ parseJSON = withObject "TestSettings" $ \o -> do
+ client <- o .: "client"
+ userEmail <- (.: "email_with_paypal_account") =<< o .: "other"
+ nonSandboxEmail <- (.: "email_without_paypal_account") =<< o .: "other"
+ return $ TestSettings (client,userEmail,nonSandboxEmail)
config :: IO (Client, Text, Text)
-config = do
- b <- B.readFile "sandbox.json"
- client <- assertRight (eitherDecode b)
- Object o <- assertRight (eitherDecode b)
- String userEmail <- assertJust "sandboxUserEmail not found"
- $ H.lookup "sandboxUserEmail" o
- String notSandboxEmail <- assertJust "randomNonSandboxUserEmail not found"
- $ H.lookup "randomNonSandboxUserEmail" o
- return (client, userEmail, notSandboxEmail)
+config = fmap _unTestSettings . assertRight . eitherDecode =<< B.readFile "sandbox.json"
incorrectEmailClient :: Text -> Client -> Client
incorrectEmailClient badAccountEmail (Client a b c d e _) = Client a b c d e badAccountEmail
@@ -91,47 +75,48 @@
correctWithdrawal :: Assertion
correctWithdrawal = do
(client, userEmail, _) <- config
- wdResp <- assertRight =<< WD.req client (withdrawal userEmail)
- lpResp <- assertRight =<< LP.req client (LP.LookupPayKey $ _crPayKey wdResp)
+ wdResp <- assertRight . checkComplete =<< fmap snd . assertRight =<< WD.request client (withdrawal userEmail)
+ lpResp <- fmap snd . assertRight =<< LP.request client (LP.LookupPayKey $ _cpPayKey wdResp)
void $ assertRight (checkComplete lpResp)
withdrawalAccountAddressDNE :: Assertion
withdrawalAccountAddressDNE = do
(client, userEmail, notSandboxEmail) <- config
let c = incorrectEmailClient notSandboxEmail client
- adaptiveErr <- assertLeft =<< WD.req c (withdrawal userEmail)
- assertEqual "send error due to a nonexistent account address" AeNoSuchEmail adaptiveErr
+ adaptiveErr <- assertLeft =<< WD.request c (withdrawal userEmail)
+ case adaptiveErr of
+ AeErrorResponse _ (ErrorResponse [PayError code _]) ->
+ assertEqual "send error due to a nonexistent account address" noSuchEmail code
+ e -> assertFailure $ "withdrawalAccountAddressDNE got unexpected error " <> show e
withdrawalUserAddressDNE :: Assertion
withdrawalUserAddressDNE = do
(client, _, notSandboxEmail) <- config
- payResp <- assertExpected =<< assertLeft =<< WD.req client (withdrawal notSandboxEmail)
- assertLookup =<< assertRight =<< LP.req client (LP.LookupPayKey $ _prPayKey payResp)
+ payResp <- fmap snd . assertRight =<< WD.request client (withdrawal notSandboxEmail)
+ assertExpected payResp
+ assertLookup =<< fmap snd . assertRight =<< LP.request client (LP.LookupPayKey $ _prPayKey payResp)
where
- assertExpected :: AdaptiveErr -> IO PayResp
- assertExpected (AePending payResp) = do
- assertEqual
- "withdraw to nonexistent user addresses return no PayInfos"
- 0 (length $ _prPayInfos payResp)
- return payResp
- assertExpected _ =
- assertFalse "send error due to a nonexistent user address didn't return AePending"
- >> fail "checkResp failed"
+ assertExpected :: PayResponse -> IO ()
+ assertExpected payResp = do
+ void . assertLeft $ checkComplete payResp
+ assertEqual "withdraw to nonexistent user addresses return no PayInfos"
+ 0
+ (length $ _prPaymentInfos payResp)
- assertLookup :: PayResp -> Assertion
+ assertLookup :: PayResponse -> Assertion
assertLookup a = do
- info <- assertRight $ do
- payExecStatusCompleted a
- errorFieldNothing a
- checkPayKey a
- getPayInfo a
+ assertEqual "withdrawalAccountAddressDNE _prPayStatus" PeCompleted (_prPayStatus a)
+ info <- assertRight (getPaymentInfo a)
assertEqual "pending withdrawal transaction status" Nothing (_piTransactionStatus info)
withdrawalNotEnoughFunds :: Assertion
withdrawalNotEnoughFunds = do
(client, userEmail, _) <- config
- adaptiveErr <- assertLeft =<< WD.req client (largeWithdrawal userEmail)
- assertEqual "send error due to not enough funds" (AeErrCodes [520009]) adaptiveErr
+ adaptiveErr <- assertLeft =<< WD.request client (largeWithdrawal userEmail)
+ case adaptiveErr of
+ AeErrorResponse _ (ErrorResponse [PayError code _]) ->
+ assertEqual "send error due to not enough funds" (ErrorCode 520009) code
+ e -> assertFailure $ "withdrawalAccountAddressDNE got unexpected error " <> show e
where
largeWithdrawal :: Text -> WD.Withdrawal
largeWithdrawal userAddr = WD.Withdrawal
@@ -142,36 +127,33 @@
correctDepositBeginning :: Assertion
correctDepositBeginning = do
(client, userEmail, _) <- config
- payKey <- assertRight =<< DP.req client (deposit userEmail)
- assertExpected =<< assertRight =<< LP.req client (LP.LookupPayKey payKey)
+ payKey <- fmap (_prPayKey . snd) . assertRight =<< DP.request client (deposit userEmail)
+ assertExpected =<< fmap snd . assertRight =<< LP.request client (LP.LookupPayKey payKey)
where
- assertExpected :: PayResp -> Assertion
+ assertExpected :: PayResponse -> Assertion
assertExpected a = do
- info <- assertRight $ do
- payExecStatusCreated a
- errorFieldNothing a
- checkPayKey a
- getPayInfo a
+ assertEqual "correctDepositBeginning _prPayStatus" PeCreated (_prPayStatus a)
+ info <- assertRight (getPaymentInfo a)
assertEqual "pending deposit transaction status" Nothing (_piTransactionStatus info)
depositAccountAddressDNE :: Assertion
depositAccountAddressDNE = do
(client, userEmail, notSandboxEmail) <- config
let c = incorrectEmailClient notSandboxEmail client
- payKey <- assertRight =<< DP.req c (deposit userEmail)
- assertExpected =<< assertRight =<< LP.req client (LP.LookupPayKey payKey)
+ payKey <- fmap (_prPayKey . snd) . assertRight =<< DP.request c (deposit userEmail)
+ assertExpected . snd =<< assertRight =<< LP.request client (LP.LookupPayKey payKey)
where
- assertExpected :: PayResp -> Assertion
+ assertExpected :: PayResponse -> Assertion
assertExpected a = do
- info <- assertRight $ do
- payExecStatusCreated a
- errorFieldNothing a
- checkPayKey a
- getPayInfo a
+ assertEqual "depositUserAddressDNE _prPayStatus" PeCreated (_prPayStatus a)
+ info <- assertRight (getPaymentInfo a)
assertEqual "status for deposit where to address isn't an account" Nothing (_piTransactionStatus info)
depositUserAddressDNE :: Assertion
depositUserAddressDNE = do
(client, _, notSandboxEmail) <- config
- adaptiveErr <- assertLeft =<< DP.req client (deposit notSandboxEmail)
- assertEqual "create error due to a nonexistent user address" AeNoSuchEmail adaptiveErr
+ adaptiveErr <- assertLeft =<< DP.request client (deposit notSandboxEmail)
+ case adaptiveErr of
+ AeErrorResponse _ (ErrorResponse [PayError code _]) ->
+ assertEqual "create error due to a nonexistent user address" noSuchEmail code
+ e -> assertFailure $ "withdrawalAccountAddressDNE got unexpected error " <> show e
diff --git a/tests/Utils.hs b/tests/Utils.hs
deleted file mode 100644
--- a/tests/Utils.hs
+++ /dev/null
@@ -1,24 +0,0 @@
-module Utils where
-
-import Test.HUnit
-
-assertFalse :: String -> IO ()
-assertFalse s = assertFailure s >> fail "assertFalse"
-
-assertJust :: String -> Maybe a -> IO a
-assertJust s a =
- case a of
- Nothing -> assertFailure s >> fail "assertJust failed"
- Just b -> return b
-
-assertRight :: (Show a) => Either a b -> IO b
-assertRight a =
- case a of
- Left e -> assertFailure (show e) >> fail "assertRight failed"
- Right b -> return b
-
-assertLeft :: (Show b) => Either a b -> IO a
-assertLeft a =
- case a of
- Left e -> return e
- Right b -> assertFailure (show b) >> fail "assertLeft failed"