diff --git a/Example.hs b/Example.hs
--- a/Example.hs
+++ b/Example.hs
@@ -2,11 +2,14 @@
module Main where
-import Prelude hiding (getLine, lookup, putStr, putStrLn)
-import Data.Default
-import Data.Text (Text)
+import Prelude hiding (getLine, lookup, putStr, putStrLn)
+import Control.Applicative
+import Data.Text (Text)
import Data.Text.IO
-import qualified Web.PayPal.Adaptive as PP
+import qualified PayPal.Adaptive as PP
+import qualified PayPal.Adaptive.Deposit as DP
+import qualified PayPal.Adaptive.Lookup as LP
+import qualified PayPal.Adaptive.Withdrawal as WD
-- You need to create a sandbox app on PayPal and enter its credentials
-- below for this app to run.
@@ -27,46 +30,31 @@
main :: IO ()
main = do
putStrLn "-- Sending money to another PayPal account."
- PP.toPayPal client withdrawal >>= print
- putStrLn ""
-
- putStrLn "-- Creating a payment from another account to us."
- r <- PP.toPayPal client deposit
- print r
- putStrLn ""
- case r of
- Left _ -> putStrLn "Stopping on payment creation failure."
- Right payResp -> do
- let payKey = PP._prPayKey payResp
- putStrLn "-- Go here and use the other account's password to approve the payment:"
- putStrLn $ PP.approvalUrl client payKey
+ resp <- WD.req client withdrawal
+ case resp of
+ Left e -> print e
+ Right withdrawalResp -> do
+ print withdrawalResp
putStrLn ""
- putStrLn "-- Once that's done press enter ..."
- _ <- getLine
- putStrLn "-- Now looking up the payment on PayPal to make sure it succeeded."
- lookupAttempt <- PP.toPayPal client (PP.LookupPayKey payKey)
- case lookupAttempt of
- Right lookupResp ->
- case PP._prPayInfo lookupResp of
- [info] -> do
- case PP._piTransactionStatus info of
- Just PP.TsCompleted -> putStrLn "Withdrawal complete."
- _ -> do
- putStrLn "The payment has not gone through yet. Expected the PayInfo in"
- putStrLn "the response to have a _piTransactionStatus of Just TsCompleted:"
- putStrLn ""
- print lookupResp
- _ -> do
- putStrLn "The payment has not gone through yet."
- putStrLn "Expected exactly one PayInfo in the response:"
- putStrLn ""
- print lookupResp
- Left lookupError -> do
- putStrLn "Error getting information about the payment:"
+ 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 ""
- print lookupError
+ putStrLn "-- Once that's done press enter ..."
+ _ <- getLine
+ 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
+
client :: PP.Client
client = PP.Client
{ PP._clAppId = "APP-80W284485P519543T" -- Currently the ID for all sandbox apps.
@@ -77,14 +65,16 @@
, PP._clAccountEmail = accountEmail
}
-withdrawal :: PP.Withdrawal
-withdrawal = def
- { PP._wdAmount = PP.USD 100
- , PP._wdReceiverEmail = sandboxTestUser
+withdrawal :: WD.Withdrawal
+withdrawal = WD.Withdrawal
+ { WD._amount = PP.USD 100
+ , WD._receiverEmail = sandboxTestUser
}
-deposit :: PP.Deposit
-deposit = def
- { PP._dpAmount = PP.USD 100
- , PP._dpSenderEmail = sandboxTestUser
+deposit :: DP.Deposit
+deposit = DP.Deposit
+ { DP._amount = PP.USD 100
+ , DP._senderEmail = sandboxTestUser
+ , DP._returnUrl = "https://example.com/"
+ , DP._cancelUrl = "https://example.com/"
}
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.10.0.2
+version: 0.11.0.0
author: Ian Grant Jeffries
maintainer: ian@housejeffries.com
category: Web
@@ -14,9 +14,12 @@
library
hs-source-dirs: src
- exposed-modules: Web.PayPal.Adaptive
- Web.PayPal.Adaptive.Internal
- other-modules: Web.PayPal.Adaptive.Core
+ exposed-modules: PayPal.Adaptive
+ PayPal.Adaptive.Deposit
+ PayPal.Adaptive.Lookup
+ PayPal.Adaptive.Withdrawal
+ PayPal.Adaptive.Internal
+ other-modules: PayPal.Adaptive.Core
default-language: Haskell2010
ghc-options: -Wall
default-extensions: OverloadedStrings
@@ -27,7 +30,6 @@
build-depends: aeson >= 0.8 && < 0.9
, base >= 4.6 && < 4.9
, bytestring >= 0.10 && < 0.11
- , data-default >= 0.5 && < 0.6
, errors >= 1.4 && < 1.5
, http-client >= 0.4.2 && < 0.5
, lens >= 4.6 && < 5.0
@@ -52,7 +54,6 @@
build-depends: aeson
, base
, bytestring
- , data-default
, paypal-adaptive-hoops
, text
, HUnit >= 1.2 && < 1.3
@@ -72,7 +73,6 @@
build-depends: aeson
, base
, bytestring
- , data-default
, paypal-adaptive-hoops
, text
, HUnit >= 1.2 && < 1.3
@@ -87,7 +87,6 @@
other-extensions: OverloadedStrings
build-depends: base
- , data-default
, paypal-adaptive-hoops
, text
diff --git a/src/PayPal/Adaptive.hs b/src/PayPal/Adaptive.hs
new file mode 100644
--- /dev/null
+++ b/src/PayPal/Adaptive.hs
@@ -0,0 +1,44 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module PayPal.Adaptive (
+
+ -- * Client
+ Client (..)
+ , Env (..)
+
+ -- * Errors
+ , AdaptiveErr (..)
+
+ -- * Payment Responses
+ , PayResp (..)
+ , CompletePayResp (..)
+ , checkComplete
+ , PayExecStatus (..)
+ , PayKey (..)
+ , PayInfo (..)
+ , Receiver (..)
+ , TransactionId (..)
+ , TransactionStatus(..)
+
+ -- * Money
+ , Money (..)
+ , m2Currency
+ , m2PayPal
+
+ , module PayPal.Adaptive
+ ) 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)
diff --git a/src/PayPal/Adaptive/Core.hs b/src/PayPal/Adaptive/Core.hs
new file mode 100644
--- /dev/null
+++ b/src/PayPal/Adaptive/Core.hs
@@ -0,0 +1,367 @@
+{-# 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/Deposit.hs b/src/PayPal/Adaptive/Deposit.hs
new file mode 100644
--- /dev/null
+++ b/src/PayPal/Adaptive/Deposit.hs
@@ -0,0 +1,75 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+-- | Start the process of someone paying you. You have to redirect the payer's
+-- browser to PayPal to finish it.
+--
+-- "Pay" operation docs:
+--
+--
+-- This is a "Simple Payment" which means there's a single sender
+-- and receiver (same as Withdrawal).
+--
+-- It uses the "Explicit" payment approval type, meaning the payer must go to
+-- PayPal in their browser to approve the payment. Here's an example payment
+-- approval URL with a PayKey of "foo":
+--
+-- https://www.paypal.com/cgi-bin/webscr?cmd=_ap-payment&paykey=foo
+
+module PayPal.Adaptive.Deposit where
+
+import Control.Lens hiding ((.=))
+import Data.Aeson
+import Data.Monoid
+import Data.Text (Text)
+import PayPal.Adaptive.Core
+
+data Deposit = Deposit
+ { _amount :: Money
+ , _senderEmail :: Text
+ , _returnUrl :: Text
+ , _cancelUrl :: Text
+ } deriving (Eq, Show)
+
+-- | For internal use.
+data SerializeDeposit = SerializeDeposit Deposit Text
+
+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
+ ]
+ ]]
+ , "returnUrl" .= _returnUrl p
+ , "cancelUrl" .= _cancelUrl p
+ , "requestEnvelope" .= requestEnvelope
+ , "senderEmail" .= _senderEmail p
+ ]
+
+req :: Client -> Deposit -> IO (Either AdaptiveErr PayKey)
+req 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)
+
+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
+
+-- * Lenses
+$(makeLenses ''Deposit)
diff --git a/src/PayPal/Adaptive/Internal.hs b/src/PayPal/Adaptive/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/PayPal/Adaptive/Internal.hs
@@ -0,0 +1,16 @@
+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
new file mode 100644
--- /dev/null
+++ b/src/PayPal/Adaptive/Lookup.hs
@@ -0,0 +1,28 @@
+{-# LANGUAGE GADTs #-}
+
+-- | Look up information about a payment.
+--
+--
+
+module PayPal.Adaptive.Lookup where
+
+import Control.Applicative
+import Data.Aeson
+import PayPal.Adaptive.Core
+
+data LookupPayment a where
+ LookupTrID :: TransactionId -> LookupPayment TransactionId
+ LookupPayKey :: PayKey -> LookupPayment PayKey
+
+instance ToJSON (LookupPayment a) where
+ toJSON (LookupTrID (TransactionId p)) =
+ object [ "transactionId" .= p
+ , "requestEnvelope" .= requestEnvelope
+ ]
+ toJSON (LookupPayKey (PayKey p)) =
+ object [ "payKey" .= p
+ , "requestEnvelope" .= requestEnvelope
+ ]
+
+req :: Client -> LookupPayment a -> IO (Either AdaptiveErr PayResp)
+req c l = (>>= ppDecode) <$> ppPost c "PaymentDetails" l
diff --git a/src/PayPal/Adaptive/Withdrawal.hs b/src/PayPal/Adaptive/Withdrawal.hs
new file mode 100644
--- /dev/null
+++ b/src/PayPal/Adaptive/Withdrawal.hs
@@ -0,0 +1,55 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+-- | Send a single payment from your account.
+--
+-- "Pay" operation docs:
+--
+--
+-- This is a "Simple Payment" which means there's a single sender
+-- and receiver (same as Deposit).
+--
+-- It uses the "Implicit" payment approval type, meaning the application
+-- making the API call must also be the sender of the payment.
+
+module PayPal.Adaptive.Withdrawal where
+
+import Control.Lens hiding ((.=))
+import Data.Aeson
+import Data.Text (Text)
+import PayPal.Adaptive.Core
+
+data Withdrawal = Withdrawal
+ { _amount :: Money
+ , _receiverEmail :: Text
+ } deriving (Eq, Show)
+
+-- | For internal use.
+data SerializeWithdrawal = SerializeWithdrawal Withdrawal Text
+
+instance ToJSON SerializeWithdrawal where
+ toJSON (SerializeWithdrawal p accountEmail) = object
+ [ "actionType" .= ("PAY" :: Text)
+ , "currencyCode" .= (m2Currency . _amount) p
+ , "receiverList" .= object
+ [ "receiver" .=
+ [ object
+ [ "amount" .= m2PayPal (_amount p)
+ , "email" .= _receiverEmail p
+ ]
+ ]
+ ]
+ , "returnUrl" .= ("https://example.com/" :: Text)
+ , "cancelUrl" .= ("https://example.com/" :: Text)
+ , "requestEnvelope" .= requestEnvelope
+ , "senderEmail" .= accountEmail
+ ]
+
+-- | 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
+ resp <- ppPost c "Pay" $ SerializeWithdrawal w (_clAccountEmail c)
+ return $ checkComplete =<< ppDecode =<< resp
+
+-- * Lenses
+$(makeLenses ''Withdrawal)
diff --git a/src/Web/PayPal/Adaptive.hs b/src/Web/PayPal/Adaptive.hs
deleted file mode 100644
--- a/src/Web/PayPal/Adaptive.hs
+++ /dev/null
@@ -1,22 +0,0 @@
-module Web.PayPal.Adaptive
- ( Client (..)
- , Env (..)
- , AdaptiveAPI (..)
- , AdaptiveErr (..)
- , Withdrawal (..)
- , Deposit (..)
- , approvalUrl
- , LookupPayment (..)
- , PayResp (..)
- , PayExecStatus (..)
- , PayKey (..)
- , PayInfo (..)
- , Receiver (..)
- , TransactionId (..)
- , TransactionStatus(..)
- , Money (..)
- , m2Currency
- , m2PayPal
- ) where
-
-import Web.PayPal.Adaptive.Core
diff --git a/src/Web/PayPal/Adaptive/Core.hs b/src/Web/PayPal/Adaptive/Core.hs
deleted file mode 100644
--- a/src/Web/PayPal/Adaptive/Core.hs
+++ /dev/null
@@ -1,537 +0,0 @@
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE MultiWayIf #-}
-{-# LANGUAGE TemplateHaskell #-}
-
-module Web.PayPal.Adaptive.Core where
-
-import Prelude hiding (mapM)
-import Control.Applicative
-import Control.Exception
-import Control.Lens hiding ((.=))
-import Control.Monad ((>=>))
-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.Default
-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)
-
---------------------------------------------------
--- API class
---------------------------------------------------
-
-class AdaptiveAPI a where
- toPayPal :: Client -> a -> IO (Either AdaptiveErr PayResp)
-
--- | Exported by Web.PayPal.Adaptive.Internal
-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" ]
-
--- | Exported by Web.PayPal.Adaptive.Internal
-ppDecode :: (FromJSON a) => Response ByteString -> Either AdaptiveErr a
-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
-
---------------------------------------------------
--- 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.
- | AeInvalidCredentials
- -- | AeNoSuchEmail is just a wrapper around an AeErrCodes Int.
- -- It's raised when the Deposit sender email or the Withdrawal
- -- account email doesn't exist.
- | AeNoSuchEmail
- | 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 Web.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 Utils
---------------------------------------------------
-
--- | Exported by Web.PayPal.Adaptive.Internal
---
--- "en_US" is hardcoded because it's the only supported error language.
-requestEnvelope :: Value
-requestEnvelope = object ["errorLanguage" .= ("en_US" :: Text)]
-
--- | Exported by Web.PayPal.Adaptive.Internal
-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"
-
--- | Exported by Web.PayPal.Adaptive.Internal
---
--- 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 _prPayInfo a of
- [] -> Left $ AePending a
- [info] -> Right info
- _ -> Left $ AeShouldNotHappen a "more than one PayInfo in reponse"
-
--- | Exported by Web.PayPal.Adaptive.Internal
-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"
-
--- | Exported by Web.PayPal.Adaptive.Internal
-errorFieldNothing :: PayResp -> Either AdaptiveErr ()
-errorFieldNothing a
- | _prPayError a == Nothing = Right ()
- | otherwise = Left $ AeShouldNotHappen a
- "PayResp error field is Just in otherwise correct payment"
-
--- | Exported by Web.PayPal.Adaptive.Internal
-checkPayKey :: PayResp -> Either AdaptiveErr ()
-checkPayKey a
- | T.null . _unPayKey . _prPayKey $ a =
- Left $ AeShouldNotHappen a "Length zero PayKey in otherwise correct deposit resp"
- | otherwise = Right ()
-
--- | Exported by Web.PayPal.Adaptive.Internal
-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"
-
--- | Exported by Web.PayPal.Adaptive.Internal
-noPayInfo :: PayResp -> Either AdaptiveErr ()
-noPayInfo a =
- case _prPayInfo a of
- [] -> Right ()
- _ -> Left $ AeShouldNotHappen a
- "At least one PayInfo present in otherwise successful deposit resp"
-
---------------------------------------------------
--- Withdrawals
---------------------------------------------------
-
--- | Send a single payment from your account.
---
--- "Pay" operation docs:
---
---
--- This is a "Simple Payment" which means there's a single sender
--- and receiver (same as Deposit).
---
--- It uses the "Implicit" payment approval type, meaning the application
--- making the API call must also be the sender of the payment.
-data Withdrawal = Withdrawal
- { _wdAmount :: Money
- , _wdReceiverEmail :: Text
- , _wdReturnUrl :: Text
- , _wdCancelUrl :: Text
- } deriving (Eq, Show)
-
-instance Default Withdrawal where
- def = Withdrawal
- { _wdAmount = mempty
- , _wdReceiverEmail = mempty
- , _wdReturnUrl = "https://example.com/"
- , _wdCancelUrl = "https://example.com/cancel"
- }
-
--- | Exported by Web.PayPal.Adaptive.Internal
-data SerializeWithdrawal = SerializeWithdrawal Withdrawal Text
-
-instance ToJSON SerializeWithdrawal where
- toJSON (SerializeWithdrawal p accountEmail) = object
- [ "actionType" .= ("PAY" :: Text)
- , "currencyCode" .= (m2Currency . _wdAmount) p
- , "receiverList" .=
- object
- [ "receiver" .= [ object
- ["amount" .= m2PayPal (_wdAmount p)
- , "email" .= _wdReceiverEmail p
- ]
- ]]
- , "returnUrl" .= _wdReturnUrl p
- , "cancelUrl" .= _wdCancelUrl p
- , "requestEnvelope" .= requestEnvelope
- , "senderEmail" .= accountEmail
- ]
-
--- | Sending a payment to a PayPal account that doesn't exist yet
--- returns a PayResp with an empty list of PayInfos. We return this
--- as Left 'AePending'.
-instance AdaptiveAPI Withdrawal where
- toPayPal c p = (>>= ppDecode >=> ensureSucceeded) <$> ppPost c "Pay" serializeWithdrawal
- where
- serializeWithdrawal :: SerializeWithdrawal
- serializeWithdrawal = SerializeWithdrawal p (_clAccountEmail c)
-
- ensureSucceeded :: PayResp -> Either AdaptiveErr PayResp
- ensureSucceeded a = do
- payExecStatusCompleted a
- info <- getPayInfo a
- transactionStatusCompleted a info
- errorFieldNothing a
- checkPayKey a
- Right a
-
---------------------------------------------------
--- Deposits
---------------------------------------------------
-
--- | Start the process of someone paying you. You have to redirect the payer's
--- browser to PayPal to finish it.
---
--- "Pay" operation docs:
---
---
--- This is a "Simple Payment" which means there's a single sender
--- and receiver (same as Withdrawal).
---
--- It uses the "Explicit" payment approval type, meaning the payer must go to
--- PayPal in their browser to approve the payment. Here's an example payment
--- approval URL with a PayKey of "foo":
---
--- https://www.paypal.com/cgi-bin/webscr?cmd=_ap-payment&paykey=foo
-data Deposit = Deposit
- { _dpAmount :: Money
- , _dpSenderEmail :: Text
- , _dpReturnUrl :: Text
- , _dpCancelUrl :: Text
- } deriving (Eq, Show)
-
-instance Default Deposit where
- def = Deposit
- { _dpAmount = mempty
- , _dpSenderEmail = mempty
- , _dpReturnUrl = "https://example.com/"
- , _dpCancelUrl = "https://example.com/cancel"
- }
-
--- | Exported by Web.PayPal.Adaptive.Internal
-data SerializeDeposit = SerializeDeposit Deposit Text
-
-instance ToJSON SerializeDeposit where
- toJSON (SerializeDeposit p accountEmail) = object
- [ "actionType" .= ("PAY" :: Text)
- , "currencyCode" .= (m2Currency . _dpAmount) p
- , "receiverList" .=
- object
- [ "receiver" .= [ object
- ["amount" .= m2PayPal (_dpAmount p)
- , "email" .= accountEmail
- ]
- ]]
- , "returnUrl" .= _dpReturnUrl p
- , "cancelUrl" .= _dpCancelUrl p
- , "requestEnvelope" .= requestEnvelope
- , "senderEmail" .= _dpSenderEmail p
- ]
-
-instance AdaptiveAPI Deposit where
- toPayPal c p = (>>= ppDecode >=> ensureSucceeded) <$> ppPost c "Pay" serializeDeposit
- where
- serializeDeposit :: SerializeDeposit
- serializeDeposit = SerializeDeposit p (_clAccountEmail c)
-
- ensureSucceeded :: PayResp -> Either AdaptiveErr PayResp
- ensureSucceeded a = do
- payExecStatusCreated a
- noPayInfo a
- errorFieldNothing a
- checkPayKey a
- Right a
-
-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
-
---------------------------------------------------
--- Lookup Payment
---------------------------------------------------
-
--- | Look up information about a payment.
---
---
-data LookupPayment a where
- LookupTrID :: TransactionId -> LookupPayment TransactionId
- LookupPayKey :: PayKey -> LookupPayment PayKey
-
-instance ToJSON (LookupPayment a) where
- toJSON (LookupTrID (TransactionId p)) =
- object [ "transactionId" .= p
- , "requestEnvelope" .= requestEnvelope
- ]
- toJSON (LookupPayKey (PayKey p)) =
- object [ "payKey" .= p
- , "requestEnvelope" .= requestEnvelope
- ]
-
-instance AdaptiveAPI (LookupPayment a) where
- toPayPal c p = (>>= ppDecode) <$> ppPost c "PaymentDetails" p
-
---------------------------------------------------
--- Payment Responses
---------------------------------------------------
-
-data PayResp = PayResp
- { _prPayError :: Maybe Text
- , _prPayExecStatus :: PayExecStatus
- , _prPayKey :: PayKey
- , _prPayInfo :: [PayInfo]
- } deriving (Eq, Show)
-
-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
- -- Haven't converted this to Money yet because I'm not sure how
- -- to determine its currency.
- { _reAmount :: Text
- , _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)
-
-
-$(deriveFromJSON defaultOptions { fieldLabelModifier = (\(x:xs) -> toLower x:xs) . drop 3 } ''PayInfo)
-$(deriveFromJSON defaultOptions { constructorTagModifier = map toUpper . drop 2 } ''PayExecStatus)
-$(deriveFromJSON defaultOptions { fieldLabelModifier = (\(x:xs) -> toLower x:xs) . drop 3 } ''Receiver)
-$(deriveFromJSON defaultOptions { constructorTagModifier = map toUpper . camelTo '_' . drop 2 } ''TransactionStatus)
-
-$(makePrisms ''AdaptiveErr)
-$(makeLenses ''Client)
-$(makeLenses ''Deposit)
-$(makePrisms ''Env)
-$(makePrisms ''PayExecStatus)
-$(makeLenses ''PayInfo)
-$(makeLenses ''PayResp)
-$(makeLenses ''Receiver)
-$(makeLenses ''Withdrawal)
-$(makePrisms ''TransactionId)
-$(makePrisms ''TransactionStatus)
diff --git a/src/Web/PayPal/Adaptive/Internal.hs b/src/Web/PayPal/Adaptive/Internal.hs
deleted file mode 100644
--- a/src/Web/PayPal/Adaptive/Internal.hs
+++ /dev/null
@@ -1,17 +0,0 @@
-module Web.PayPal.Adaptive.Internal
- ( ppPost
- , ppDecode
- , parseErrId
- , requestEnvelope
- , payExecStatusCompleted
- , getPayInfo
- , transactionStatusCompleted
- , errorFieldNothing
- , checkPayKey
- , payExecStatusCreated
- , noPayInfo
- , SerializeDeposit (..)
- , SerializeWithdrawal(..)
- ) where
-
-import Web.PayPal.Adaptive.Core
diff --git a/tests/Local/Money.hs b/tests/Local/Money.hs
--- a/tests/Local/Money.hs
+++ b/tests/Local/Money.hs
@@ -1,9 +1,9 @@
module Local.Money (unitMoney) where
+import PayPal.Adaptive
import Test.Framework
import Test.Framework.Providers.HUnit (testCase)
-import Test.HUnit ((@=?), Assertion)
-import Web.PayPal.Adaptive
+import Test.HUnit (Assertion, (@=?))
unitMoney :: Test
unitMoney = testGroup "money"
diff --git a/tests/Local/Parser.hs b/tests/Local/Parser.hs
--- a/tests/Local/Parser.hs
+++ b/tests/Local/Parser.hs
@@ -1,16 +1,16 @@
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 Data.Default
-import Test.Framework (Test, testGroup)
-import Test.Framework.Providers.HUnit (testCase)
-import Test.HUnit (Assertion, (@=?))
-import Utils
-import Web.PayPal.Adaptive
-import Web.PayPal.Adaptive.Internal
+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"
@@ -40,25 +40,27 @@
serializeWithdrawal :: Assertion
serializeWithdrawal = "tests/Local/json/serializeWithdrawal.json" `eqSerialized` a
where
- a :: SerializeWithdrawal
- a = SerializeWithdrawal b "payments@mail.com"
+ a :: WD.SerializeWithdrawal
+ a = WD.SerializeWithdrawal b "payments@mail.com"
- b :: Withdrawal
- b = def
- { _wdAmount = USD 100
- , _wdReceiverEmail = "user@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 :: SerializeDeposit
- a = SerializeDeposit b "payments@mail.com"
+ a :: DP.SerializeDeposit
+ a = DP.SerializeDeposit b "payments@mail.com"
- b :: Deposit
- b = def
- { _dpAmount = USD 100
- , _dpSenderEmail = "user@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
@@ -68,7 +70,7 @@
{ _prPayError = Nothing
, _prPayExecStatus = PeCompleted
, _prPayKey = PayKey "AP-21C62741YR509274N"
- , _prPayInfo = [p]
+ , _prPayInfos = [p]
}
p = PayInfo
{ _piReceiver = r
@@ -89,7 +91,7 @@
{ _prPayError = Nothing
, _prPayExecStatus = PeCreated
, _prPayKey = PayKey "AP-3NL080742J1818731"
- , _prPayInfo = []
+ , _prPayInfos = []
}
parseLookupResp :: Assertion
@@ -99,7 +101,7 @@
{ _prPayError = Nothing
, _prPayExecStatus = PeCompleted
, _prPayKey = PayKey "AP-5XY65045XE4097324"
- , _prPayInfo = [p]
+ , _prPayInfos = [p]
}
p = PayInfo
{ _piReceiver = r
diff --git a/tests/Local/json/serializeWithdrawal.json b/tests/Local/json/serializeWithdrawal.json
--- a/tests/Local/json/serializeWithdrawal.json
+++ b/tests/Local/json/serializeWithdrawal.json
@@ -1,6 +1,6 @@
{
"currencyCode": "USD",
- "cancelUrl": "https://example.com/cancel",
+ "cancelUrl": "https://example.com/",
"receiverList": {
"receiver": [
{
diff --git a/tests/Remote.hs b/tests/Remote.hs
--- a/tests/Remote.hs
+++ b/tests/Remote.hs
@@ -2,19 +2,21 @@
module Main where
-import Control.Applicative
-import Control.Monad
-import Data.Aeson
-import qualified Data.ByteString.Lazy as B
-import Data.Default
-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 Utils
-import Web.PayPal.Adaptive
-import Web.PayPal.Adaptive.Internal
+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 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]
@@ -35,7 +37,7 @@
withdrawalNotEnoughFunds
, testCase
"deposit succeeds with good arguments"
- correctDeposit
+ correctDepositBeginning
, testCase
"deposit with a bad account address does NOT produce an error"
depositAccountAddressDNE
@@ -71,118 +73,105 @@
incorrectEmailClient :: Text -> Client -> Client
incorrectEmailClient badAccountEmail (Client a b c d e _) = Client a b c d e badAccountEmail
-withdrawal :: Text -> Withdrawal
-withdrawal userAddr = def
- { _wdAmount = USD 1
- , _wdReceiverEmail = userAddr
+withdrawal :: Text -> WD.Withdrawal
+withdrawal userAddr = WD.Withdrawal
+ { WD._amount = USD 1
+ , WD._receiverEmail = userAddr
}
-deposit :: Text -> Deposit
-deposit userAddr = def
- { _dpAmount = USD 1
- , _dpSenderEmail = userAddr
+deposit :: Text -> DP.Deposit
+deposit userAddr = DP.Deposit
+ { DP._amount = USD 1
+ , DP._senderEmail = userAddr
+ , DP._returnUrl = "https://example.com/"
+ , DP._cancelUrl = "https://example.com/cancel"
}
-assrt :: Either AdaptiveErr () -> IO ()
-assrt (Left e) = assertFailure (show e) >> fail "check failed"
-assrt (Right _) = return ()
-
correctWithdrawal :: Assertion
correctWithdrawal = do
(client, userEmail, _) <- config
- payResp <- assertRight =<< toPayPal client (withdrawal userEmail)
- (assrt . checkLookup) =<< assertRight =<< toPayPal client (LookupPayKey . _prPayKey $ payResp)
- where
- checkLookup :: PayResp -> Either AdaptiveErr ()
- checkLookup a = do
- payExecStatusCompleted a
- info <- getPayInfo a
- transactionStatusCompleted a info
- errorFieldNothing a
- checkPayKey a
- Right ()
+ wdResp <- assertRight =<< WD.req client (withdrawal userEmail)
+ lpResp <- assertRight =<< LP.req client (LP.LookupPayKey $ _crPayKey wdResp)
+ void $ assertRight (checkComplete lpResp)
withdrawalAccountAddressDNE :: Assertion
withdrawalAccountAddressDNE = do
(client, userEmail, notSandboxEmail) <- config
let c = incorrectEmailClient notSandboxEmail client
- adaptiveErr <- assertLeft =<< toPayPal c (withdrawal userEmail)
+ adaptiveErr <- assertLeft =<< WD.req c (withdrawal userEmail)
assertEqual "send error due to a nonexistent account address" AeNoSuchEmail adaptiveErr
withdrawalUserAddressDNE :: Assertion
withdrawalUserAddressDNE = do
(client, _, notSandboxEmail) <- config
- payResp <- checkResp =<< assertLeft =<< toPayPal client (withdrawal notSandboxEmail)
- (assrt . checkLookup) =<< assertRight =<< toPayPal client (LookupPayKey . _prPayKey $ payResp)
+ payResp <- assertExpected =<< assertLeft =<< WD.req client (withdrawal notSandboxEmail)
+ assertLookup =<< assertRight =<< LP.req client (LP.LookupPayKey $ _prPayKey payResp)
where
- checkResp :: AdaptiveErr -> IO PayResp
- checkResp (AePending payResp) = do
+ assertExpected :: AdaptiveErr -> IO PayResp
+ assertExpected (AePending payResp) = do
assertEqual
- "withdraw to nonexistent user addresses return no PayResps"
- 0 (length $ _prPayInfo payResp)
+ "withdraw to nonexistent user addresses return no PayInfos"
+ 0 (length $ _prPayInfos payResp)
return payResp
- checkResp _ =
+ assertExpected _ =
assertFalse "send error due to a nonexistent user address didn't return AePending"
>> fail "checkResp failed"
- checkLookup :: PayResp -> Either AdaptiveErr ()
- checkLookup a = do
- payExecStatusCompleted a
- info <- getPayInfo a
- unless (_piTransactionStatus info == Nothing) $ Left (AeShouldNotHappen a
- "a pending withdrawal should not have transaction status in this situation")
- errorFieldNothing a
- checkPayKey a
- Right ()
+ assertLookup :: PayResp -> Assertion
+ assertLookup a = do
+ info <- assertRight $ do
+ payExecStatusCompleted a
+ errorFieldNothing a
+ checkPayKey a
+ getPayInfo a
+ assertEqual "pending withdrawal transaction status" Nothing (_piTransactionStatus info)
withdrawalNotEnoughFunds :: Assertion
withdrawalNotEnoughFunds = do
(client, userEmail, _) <- config
- adaptiveErr <- assertLeft =<< toPayPal client (largeWithdrawal userEmail)
+ adaptiveErr <- assertLeft =<< WD.req client (largeWithdrawal userEmail)
assertEqual "send error due to not enough funds" (AeErrCodes [520009]) adaptiveErr
where
- largeWithdrawal :: Text -> Withdrawal
- largeWithdrawal userAddr = def
- { _wdAmount = USD 1000000
- , _wdReceiverEmail = userAddr
+ largeWithdrawal :: Text -> WD.Withdrawal
+ largeWithdrawal userAddr = WD.Withdrawal
+ { WD._amount = USD 100000000
+ , WD._receiverEmail = userAddr
}
-correctDeposit :: Assertion
-correctDeposit = do
+correctDepositBeginning :: Assertion
+correctDepositBeginning = do
(client, userEmail, _) <- config
- payResp <- assertRight =<< toPayPal client (deposit userEmail)
- (assrt . checkLookup) =<< assertRight =<< toPayPal client (LookupPayKey . _prPayKey $ payResp)
+ payKey <- assertRight =<< DP.req client (deposit userEmail)
+ assertExpected =<< assertRight =<< LP.req client (LP.LookupPayKey payKey)
where
- checkLookup :: PayResp -> Either AdaptiveErr ()
- checkLookup a = do
- payExecStatusCreated a
- info <- getPayInfo a
- unless (_piTransactionStatus info == Nothing) $ Left (AeShouldNotHappen a
- "an uncompleted deposit should not have transaction status in this situation")
- errorFieldNothing a
- checkPayKey a
- Right ()
+ assertExpected :: PayResp -> Assertion
+ assertExpected a = do
+ info <- assertRight $ do
+ payExecStatusCreated a
+ errorFieldNothing a
+ checkPayKey a
+ getPayInfo a
+ assertEqual "pending deposit transaction status" Nothing (_piTransactionStatus info)
depositAccountAddressDNE :: Assertion
depositAccountAddressDNE = do
(client, userEmail, notSandboxEmail) <- config
let c = incorrectEmailClient notSandboxEmail client
- payResp <- assertRight =<< toPayPal c (deposit userEmail)
- (assrt . checkLookup) =<< assertRight =<< toPayPal client (LookupPayKey . _prPayKey $ payResp)
+ payKey <- assertRight =<< DP.req c (deposit userEmail)
+ assertExpected =<< assertRight =<< LP.req client (LP.LookupPayKey payKey)
where
- checkLookup :: PayResp -> Either AdaptiveErr ()
- checkLookup a = do
- payExecStatusCreated a
- info <- getPayInfo a
- unless (_piTransactionStatus info == Nothing) $ Left (AeShouldNotHappen a
- "a deposit should not have transaction status in this situation")
- errorFieldNothing a
- checkPayKey a
- Right ()
+ assertExpected :: PayResp -> Assertion
+ assertExpected a = do
+ info <- assertRight $ do
+ payExecStatusCreated a
+ errorFieldNothing a
+ checkPayKey a
+ getPayInfo a
+ assertEqual "status for deposit where to address isn't an account" Nothing (_piTransactionStatus info)
depositUserAddressDNE :: Assertion
depositUserAddressDNE = do
(client, _, notSandboxEmail) <- config
- adaptiveErr <- assertLeft =<< toPayPal client (deposit notSandboxEmail)
+ adaptiveErr <- assertLeft =<< DP.req client (deposit notSandboxEmail)
assertEqual "create error due to a nonexistent user address" AeNoSuchEmail adaptiveErr