paypal-adaptive-hoops 0.8.0.0 → 0.9.0.0

raw patch · 17 files changed

+499/−293 lines, 17 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Example.hs +24/−29
• README.md +6/−2
• paypal-adaptive-hoops.cabal +1/−1
• src/Web/PayPal/Adaptive.hs +4/−5
• src/Web/PayPal/Adaptive/Core.hs +196/−118
• src/Web/PayPal/Adaptive/Internal.hs +11/−2
• tests/Local/Parser.hs +27/−26
• tests/Local/json/parseCreateResp.json +0/−10
• tests/Local/json/parseDepositResp.json +10/−0
• tests/Local/json/parseSendResp.json +0/−30
• tests/Local/json/parseWithdrawalResp.json +30/−0
• tests/Local/json/serializeCreatePayment.json +0/−18
• tests/Local/json/serializeDeposit.json +18/−0
• tests/Local/json/serializeSendPayment.json +0/−18
• tests/Local/json/serializeWithdrawal.json +18/−0
• tests/Remote.hs +145/−34
• tests/Utils.hs +9/−0

@@ -6,18 +6,18 @@ import           Data.Default import           Data.Text           (Text) import           Data.Text.IO-import           Web.PayPal.Adaptive+import qualified Web.PayPal.Adaptive as PP  -- You need to create a sandbox app on PayPal and enter its credentials -- below for this app to run. -- -- Also, the email associated with the sandbox app will need at least -- a dollar in its sandbox account.-accountEmail, userId, password, sig :: Text-accountEmail = "foo@example.com"+userId, password, sig, accountEmail :: Text userId       = "foo_api1.example.com" password     = "bar" sig          = "baz"+accountEmail = "foo@example.com"  -- You must also create a sandbox user on PayPal. Enter its email here. -- This is the account we'll be sending money to and from.@@ -27,20 +27,20 @@ main :: IO () main = do   putStrLn "-- Sending money to another PayPal account."-  toPayPal client send >>= print+  PP.toPayPal client withdrawal >>= print   putStrLn ""    putStrLn "-- Creating a payment from another account to us."-  r <- toPayPal client create+  r <- PP.toPayPal client deposit   print r   putStrLn ""   case r of     Left _        -> putStrLn "Stopping on create payment failure."     Right payResp -> do -      let payKey = _prPayKey payResp+      let payKey = PP._prPayKey payResp       putStrLn "-- Go here and use the other account's password to approve the payment:"-      putStrLn $ approvalUrl client payKey+      putStrLn $ PP.approvalUrl client payKey       putStrLn ""        putStrLn "-- Once that's done press enter ..."@@ -48,31 +48,26 @@        putStrLn "-- Now looking up the payment on PayPal to make sure that succeeded."       putStrLn "-- If it did _prPayExecStatus will have changed from PeCreated to PeCompleted."-      toPayPal client (LookupPayKey payKey) >>= print+      PP.toPayPal client (PP.LookupPayKey payKey) >>= print -client :: PpClient-client = PpClient-  { _clAppId    = "APP-80W284485P519543T" -- Currently the ID for all sandbox apps.-  , _clEnv      = PpSandbox-  , _clPassword = password-  , _clSig      = sig-  , _clUserId   = userId+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._clPassword     = password+  , PP._clSig          = sig+  , PP._clAccountEmail = accountEmail   } -send :: SendPayment-send = def-  { _spReceiverList = ReceiverList-    { _rlAmount = USD 100-    , _rlEmail = sandboxTestUser-    }-  , _spSenderEmail = accountEmail+withdrawal :: PP.Withdrawal+withdrawal = def+  { PP._wdAmount = PP.USD 100+  , PP._wdReceiverEmail = sandboxTestUser   } -create :: CreatePayment-create = def-  { _cpReceiverList = ReceiverList-    { _rlAmount = USD 100-    , _rlEmail = accountEmail-    }-  , _cpSenderEmail = sandboxTestUser+deposit :: PP.Deposit+deposit = def+  { PP._dpAmount = PP.USD 100+  , PP._dpSenderEmail = sandboxTestUser   }

@@ -1,6 +1,6 @@ # Intro -A Haskell client for a limited part of PayPal's [Adaptive Payments API](https://developer.paypal.com/docs/classic/products/adaptive-payments/).+A high-level 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. @@ -10,13 +10,17 @@  Getting production approval for the Adaptive Payments API takes some time. You should start the process well before you actually need to go into production. Detailed instructions for doing so are out of the scope of this project, but you can get started [here](https://developer.paypal.com/docs/classic/lifecycle/goingLive/). +# Future Plans++Only supports USD. More currencies would be a nice-to-have.+ # Local Tests  `cabal test local`  # Integration Tests -Requires an internet connection, a PayPal sandbox app account, and a PayPal sandbox test user account. The test accounts must each have at least a penny in them.+Requires an internet connection, a PayPal sandbox app account, and a PayPal sandbox test user account. The test accounts should have balances between a few dollars and a million dollars (they send pennies around, but expect million dollar transaction attempts to fail from lack of funds).  1. `cp sandbox-template.json sandbox.json` 

@@ -1,5 +1,5 @@ name:                 paypal-adaptive-hoops-version:              0.8.0.0+version:              0.9.0.0 author:               Ian Grant Jeffries maintainer:           ian@housejeffries.com category:             Web

@@ -1,11 +1,10 @@ module Web.PayPal.Adaptive-  ( PpClient         (..)-  , PpEnv            (..)+  ( Client           (..)+  , Env              (..)   , AdaptiveAPI      (..)   , AdaptiveErr      (..)-  , ReceiverList     (..)-  , SendPayment      (..)-  , CreatePayment    (..)+  , Withdrawal       (..)+  , Deposit          (..)   , approvalUrl   , LookupPayment    (..)   , PayResp          (..)

@@ -29,25 +29,29 @@ -- Client -------------------------------------------------- -data PpClient = PpClient-  { _clAppId    :: Text-  , _clEnv      :: PpEnv-  , _clPassword :: Text-  , _clSig      :: Text-  , _clUserId   :: Text+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 PpEnv = PpSandbox | PpProduction deriving (Eq, Show, Read)+data Env = Sandbox | Production deriving (Eq, Show, Read)  -------------------------------------------------- -- API class --------------------------------------------------  class AdaptiveAPI a where-  toPayPal :: PpClient -> a -> IO (Either AdaptiveErr PayResp)+  toPayPal :: Client -> a -> IO (Either AdaptiveErr PayResp)  -- | Exported by Web.PayPal.Adaptive.Internal-ppPost :: (ToJSON a) => PpClient -> Text -> a -> IO (Either AdaptiveErr (Response ByteString))+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)@@ -56,8 +60,8 @@     clBaseUrl :: String     clBaseUrl =       case _clEnv c of-        PpSandbox    -> "https://svcs.sandbox.paypal.com/AdaptivePayments/"-        PpProduction -> "https://svcs.paypal.com/AdaptivePayments/"+        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@@ -98,16 +102,14 @@ -- 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?------ Both AeInvalidCredentials and AeNoSuchEmail are just--- a convenient wrapper around certain AeErrCodes. 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 CreatePayment sender email doesn't exist.+  -- It's raised when the Deposit sender email or the Withdrawal+  -- account email doesn't exist.   | AeNoSuchEmail   | AeErrCodes        [Int]   | AePending         PayResp@@ -139,153 +141,220 @@     Right (b,_) -> return b  ----------------------------------------------------- Common payload things+-- Payment Utils -------------------------------------------------- -data ReceiverList = ReceiverList-  { _rlAmount :: Money-  , _rlEmail  :: Text-  } deriving (Eq, Show)--instance ToJSON ReceiverList where-  toJSON (ReceiverList a e) =-    object [ "receiver" .= [ object ["amount" .= m2PayPal a, "email" .= e] ] ]- -- | 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"+ ----------------------------------------------------- Send Payment+-- Withdrawals --------------------------------------------------  -- | Send a single payment from your account. ----- -- "Pay" operation docs: -- <https://developer.paypal.com/docs/classic/api/adaptive-payments/Pay_API_Operation/> -- -- This is a "Simple Payment" which means there's a single sender--- and receiver (same as CreatePayment).+-- 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 SendPayment = SendPayment-  { _spReceiverList :: ReceiverList-  , _spReturnUrl    :: Text-  , _spCancelUrl    :: Text-  , _spSenderEmail  :: Text+data Withdrawal = Withdrawal+  { _wdAmount        :: Money+  , _wdReceiverEmail :: Text+  , _wdReturnUrl     :: Text+  , _wdCancelUrl     :: Text   } deriving (Eq, Show) -instance Default SendPayment where-  def = SendPayment-    { _spReceiverList = ReceiverList mempty mempty-    , _spReturnUrl    = "https://example.com/"-    , _spCancelUrl    = "https://example.com/cancel"-    , _spSenderEmail  = mempty+instance Default Withdrawal where+  def = Withdrawal+    { _wdAmount        = mempty+    , _wdReceiverEmail = mempty+    , _wdReturnUrl    = "https://example.com/"+    , _wdCancelUrl    = "https://example.com/cancel"     } -instance ToJSON SendPayment where-  toJSON p = object+-- | 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 . _rlAmount . _spReceiverList) p-    , "receiverList"    .= _spReceiverList p-    , "returnUrl"       .= _spReturnUrl p-    , "cancelUrl"       .= _spCancelUrl p+    , "currencyCode"    .= (m2Currency . _wdAmount) p+    , "receiverList"    .=+      object+        [ "receiver" .= [ object+          ["amount" .= m2PayPal (_wdAmount p)+          , "email" .= _wdReceiverEmail p+          ]+        ]]+    , "returnUrl"       .= _wdReturnUrl p+    , "cancelUrl"       .= _wdCancelUrl p     , "requestEnvelope" .= requestEnvelope-    , "senderEmail"     .= _spSenderEmail p+    , "senderEmail"     .= accountEmail     ] -instance AdaptiveAPI SendPayment where-  toPayPal c p = (>>= ppDecode >=> ensureSucceeded) <$> ppPost c "Pay" p+-- | 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 =-        case _prPayExecStatus a of-          PeProcessing -> Left $ AePending a-          PePending    -> Left $ AePending a-          PeError      -> Left $ AeRefused a-          PeCompleted  ->-            let infos = _prPayInfo a-            in if length infos /= 1-              then Left $ AeShouldNotHappen a "sendPayment expects one PayInfo in reponse"-              else-                let info = head infos-                in case _piTransactionStatus info of-                Just TsCompleted  -> Right a-                Just TsPending    -> Left $ AePending a-                Just TsProcessing -> Left $ AePending a-                Just TsDenied     -> Left $ AeRefused a-                Just TsFailed     -> Left $ AeRefused a-                _ -> Left $ AeShouldNotHappen a "got unsupported TransactionStatus"-          _ -> Left $ AeShouldNotHappen a "got unsupported PayExecStatus"+      ensureSucceeded a = do+        payExecStatusCompleted a+        info <- getPayInfo a+        transactionStatusCompleted a info+        errorFieldNothing a+        checkPayKey a+        Right a  ----------------------------------------------------- Create Payment+-- Deposits --------------------------------------------------  -- | Start the process of someone paying you. You have to redirect the payer's -- browser to PayPal to finish it. ----- -- "Pay" operation docs: -- <https://developer.paypal.com/docs/classic/api/adaptive-payments/Pay_API_Operation/> -- -- This is a "Simple Payment" which means there's a single sender--- and receiver (same as SendPayment).+-- 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 CreatePayment = CreatePayment-  { _cpReceiverList :: ReceiverList-  , _cpReturnUrl    :: Text-  , _cpCancelUrl    :: Text-  , _cpSenderEmail  :: Text+data Deposit = Deposit+  { _dpAmount       :: Money+  , _dpSenderEmail  :: Text+  , _dpReturnUrl    :: Text+  , _dpCancelUrl    :: Text   } deriving (Eq, Show) -instance Default CreatePayment where-  def = CreatePayment-    { _cpReceiverList = ReceiverList mempty mempty-    , _cpReturnUrl    = "https://example.com/"-    , _cpCancelUrl    = "https://example.com/cancel"-    , _cpSenderEmail  = mempty+instance Default Deposit where+  def = Deposit+    { _dpAmount       = mempty+    , _dpSenderEmail  = mempty+    , _dpReturnUrl    = "https://example.com/"+    , _dpCancelUrl    = "https://example.com/cancel"     } -instance ToJSON CreatePayment where-  toJSON p = object+-- | 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 . _rlAmount . _cpReceiverList) p-    , "receiverList"    .= _cpReceiverList p-    , "returnUrl"       .= _cpReturnUrl p-    , "cancelUrl"       .= _cpCancelUrl p+    , "currencyCode"    .= (m2Currency . _dpAmount) p+    , "receiverList"    .=+      object+        [ "receiver" .= [ object+          ["amount" .= m2PayPal (_dpAmount p)+          , "email" .= accountEmail+          ]+        ]]+    , "returnUrl"       .= _dpReturnUrl p+    , "cancelUrl"       .= _dpCancelUrl p     , "requestEnvelope" .= requestEnvelope-    , "senderEmail"     .= _cpSenderEmail p+    , "senderEmail"     .= _dpSenderEmail p     ] -instance AdaptiveAPI CreatePayment where-  toPayPal c p = (>>= ppDecode >=> ensureSucceeded) <$> ppPost c "Pay" 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 =-        case _prPayExecStatus a of-          PeCreated    -> Right a-          PeProcessing -> Left $ AePending a-          PePending    -> Left $ AePending a-          PeError      -> Left $ AeRefused a-          _            -> Left $ AeShouldNotHappen a "got unsupported PayExecStatus"+      ensureSucceeded a = do+        payExecStatusCreated a+        noPayInfo a+        errorFieldNothing a+        checkPayKey a+        Right a -approvalUrl :: PpClient -> PayKey -> Text+approvalUrl :: Client -> PayKey -> Text approvalUrl c k =   case _clEnv c of-    PpSandbox ->+    Sandbox ->       "https://www.sandbox.paypal.com/cgi-bin/webscr?cmd=_ap-payment&paykey="       <> _unPayKey k-    PpProduction ->+    Production ->       "https://www.paypal.com/cgi-bin/webscr?cmd=_ap-payment&paykey="       <> _unPayKey k @@ -293,7 +362,7 @@ -- Lookup Payment -------------------------------------------------- --- | Lookup information about a payment.+-- | Look up information about a payment. -- -- <https://developer.paypal.com/docs/classic/api/adaptive-payments/PaymentDetails_API_Operation/> data LookupPayment a where@@ -318,10 +387,10 @@ --------------------------------------------------  data PayResp = PayResp-  { _prPayError      :: Maybe Text -- Nothing for all Right responses+  { _prPayError      :: Maybe Text   , _prPayExecStatus :: PayExecStatus   , _prPayKey        :: PayKey-  , _prPayInfo       :: [PayInfo] -- Empty in CreatePayment responses+  , _prPayInfo       :: [PayInfo]   } deriving (Eq, Show)  instance FromJSON PayResp where@@ -340,8 +409,12 @@         infos <- v .:? "paymentInfo" .!= mempty         return $ PayResp e status k infos --- | This is "paymentExecStatus" in responses to sendPayment and createPayment.--- It's called "status" in responses to lookupPayment.+-- 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@@ -352,7 +425,7 @@   | PePending   deriving (Eq, Show, Read) --- | Defaults to expiring after three hours:+-- | Expires after three hours. -- -- <https://developer.paypal.com/docs/classic/api/adaptive-payments/Pay_API_Operation/> newtype PayKey = PayKey { _unPayKey :: Text } deriving (Eq, Show)@@ -363,16 +436,22 @@ instance ToJSON PayKey where   toJSON (PayKey a) = toJSON a --- | All the API calls we support return a PayInfo along with three Justs, with two--- exceptions.+-- | Right toPayPal responses return a PayInfo along with a+-- _piTransactionStatus Just, with some exceptions. -----     1. toPayPal CreatePayment returns no PayInfo at all.+--     1. Withdrawals to nonexistent accounts return no PayInfos. -----     2. toPayPal LookupPayment on such a payment does return a PayInfo, but with--- three Nothings.+--     2. Lookups on such transactions return one PayInfo with a+--     _piTransactionStatus of Nothing. ----- NOTE: _piSenderTransactionId and _piTransactionStatus will be different, but--- both can be used to look up a payment.+--     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@@ -446,14 +525,13 @@ $(deriveFromJSON defaultOptions { constructorTagModifier = map toUpper . camelTo '_' . drop 2 } ''TransactionStatus)  $(makePrisms ''AdaptiveErr)-$(makeLenses ''PpClient)-$(makeLenses ''CreatePayment)-$(makePrisms ''PpEnv)+$(makeLenses ''Client)+$(makeLenses ''Deposit)+$(makePrisms ''Env) $(makePrisms ''PayExecStatus) $(makeLenses ''PayInfo) $(makeLenses ''PayResp) $(makeLenses ''Receiver)-$(makeLenses ''ReceiverList)-$(makeLenses ''SendPayment)+$(makeLenses ''Withdrawal) $(makePrisms ''TransactionId) $(makePrisms ''TransactionStatus)

@@ -1,8 +1,17 @@ module Web.PayPal.Adaptive.Internal-  ( parseErrId+  ( ppPost   , ppDecode-  , ppPost+  , parseErrId   , requestEnvelope+  , payExecStatusCompleted+  , getPayInfo+  , transactionStatusCompleted+  , errorFieldNothing+  , checkPayKey+  , payExecStatusCreated+  , noPayInfo+  , SerializeDeposit   (..)+  , SerializeWithdrawal(..)   ) where  import Web.PayPal.Adaptive.Core

@@ -10,13 +10,14 @@ import Test.HUnit (Assertion, (@=?)) import Utils import Web.PayPal.Adaptive+import Web.PayPal.Adaptive.Internal  unitParser :: Test unitParser = testGroup "parsers"-  [ testCase "correctly encodes a SendPayment"            serializeSendPayment-  , testCase "correctly encodes a CreatePayment"          serializeCreatePayment-  , testCase "correctly decodes a SendPayment response"   parseSendResp-  , testCase "correctly decodes a CreatePayment response" parseCreateResp+  [ 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   ]@@ -36,32 +37,32 @@   actual <- assertRight (eitherDecode b)   expected @=? actual -serializeSendPayment :: Assertion-serializeSendPayment = "tests/Local/json/serializeSendPayment.json" `eqSerialized` a+serializeWithdrawal :: Assertion+serializeWithdrawal = "tests/Local/json/serializeWithdrawal.json" `eqSerialized` a   where-    a = def-      { _spReceiverList = rl-      , _spSenderEmail  = "payments@mail.com"-      }-    rl = ReceiverList-      { _rlAmount = USD 100-      , _rlEmail  = "user@mail.com"+    a :: SerializeWithdrawal+    a = SerializeWithdrawal b "payments@mail.com"++    b :: Withdrawal+    b = def+      { _wdAmount = USD 100+      , _wdReceiverEmail = "user@mail.com"       } -serializeCreatePayment :: Assertion-serializeCreatePayment = "tests/Local/json/serializeCreatePayment.json" `eqSerialized` a+serializeDeposit :: Assertion+serializeDeposit = "tests/Local/json/serializeDeposit.json" `eqSerialized` a   where-    a = def-      { _cpReceiverList = rl-      , _cpSenderEmail  = "user@mail.com"-      }-    rl = ReceiverList-      { _rlAmount = USD 100-      , _rlEmail  = "payments@mail.com"+    a :: SerializeDeposit+    a = SerializeDeposit b "payments@mail.com"++    b :: Deposit+    b = def+      { _dpAmount = USD 100+      , _dpSenderEmail  = "user@mail.com"       } -parseSendResp :: Assertion-parseSendResp = expected `eqParsed` "tests/Local/json/parseSendResp.json"+parseWithdrawalResp :: Assertion+parseWithdrawalResp = expected `eqParsed` "tests/Local/json/parseWithdrawalResp.json"   where     expected = PayResp       { _prPayError      = Nothing@@ -81,8 +82,8 @@       , _reAccountId = "69D9D7KVA6WAN"       } -parseCreateResp :: Assertion-parseCreateResp = expected `eqParsed` "tests/Local/json/parseCreateResp.json"+parseDepositResp :: Assertion+parseDepositResp = expected `eqParsed` "tests/Local/json/parseDepositResp.json"   where     expected = PayResp       { _prPayError      = Nothing

@@ -1,10 +0,0 @@-{-    "responseEnvelope": {-        "correlationId": "caf7d2d1a85aa",-        "build": "13414382",-        "ack": "Success",-        "timestamp": "2015-01-12T13:47:48.819-08:00"-    },-    "paymentExecStatus": "CREATED",-    "payKey": "AP-3NL080742J1818731"-}

@@ -0,0 +1,10 @@+{+    "responseEnvelope": {+        "correlationId": "caf7d2d1a85aa",+        "build": "13414382",+        "ack": "Success",+        "timestamp": "2015-01-12T13:47:48.819-08:00"+    },+    "paymentExecStatus": "CREATED",+    "payKey": "AP-3NL080742J1818731"+}

@@ -1,30 +0,0 @@-{-    "responseEnvelope": {-        "correlationId": "8d141f13b157e",-        "build": "13414382",-        "ack": "Success",-        "timestamp": "2014-11-10T16:27:18.328-08:00"-    },-    "paymentExecStatus": "COMPLETED",-    "sender": {-        "accountId": "SQ6CLCESENNDL"-    },-    "payKey": "AP-21C62741YR509274N",-    "paymentInfoList": {-        "paymentInfo": [-            {-                "senderTransactionStatus": "COMPLETED",-                "transactionId": "1DG71997KF688883E",-                "receiver": {-                    "email": "user@mail.com",-                    "amount": "1.00",-                    "primary": "false",-                    "accountId": "69D9D7KVA6WAN"-                },-                "senderTransactionId": "7TU31598YN877045D",-                "transactionStatus": "COMPLETED",-                "pendingRefund": "false"-            }-        ]-    }-}

@@ -0,0 +1,30 @@+{+    "responseEnvelope": {+        "correlationId": "8d141f13b157e",+        "build": "13414382",+        "ack": "Success",+        "timestamp": "2014-11-10T16:27:18.328-08:00"+    },+    "paymentExecStatus": "COMPLETED",+    "sender": {+        "accountId": "SQ6CLCESENNDL"+    },+    "payKey": "AP-21C62741YR509274N",+    "paymentInfoList": {+        "paymentInfo": [+            {+                "senderTransactionStatus": "COMPLETED",+                "transactionId": "1DG71997KF688883E",+                "receiver": {+                    "email": "user@mail.com",+                    "amount": "1.00",+                    "primary": "false",+                    "accountId": "69D9D7KVA6WAN"+                },+                "senderTransactionId": "7TU31598YN877045D",+                "transactionStatus": "COMPLETED",+                "pendingRefund": "false"+            }+        ]+    }+}

@@ -1,18 +0,0 @@-{-    "currencyCode": "USD",-    "cancelUrl": "https://example.com/cancel",-    "receiverList": {-        "receiver": [-            {-                "email": "payments@mail.com",-                "amount": "1.00"-            }-        ]-    },-    "returnUrl": "https://example.com/",-    "senderEmail": "user@mail.com",-    "requestEnvelope": {-        "errorLanguage": "en_US"-    },-    "actionType": "PAY"-}

@@ -0,0 +1,18 @@+{+    "currencyCode": "USD",+    "cancelUrl": "https://example.com/cancel",+    "receiverList": {+        "receiver": [+            {+                "email": "payments@mail.com",+                "amount": "1.00"+            }+        ]+    },+    "returnUrl": "https://example.com/",+    "senderEmail": "user@mail.com",+    "requestEnvelope": {+        "errorLanguage": "en_US"+    },+    "actionType": "PAY"+}

@@ -1,18 +0,0 @@-{-    "currencyCode": "USD",-    "cancelUrl": "https://example.com/cancel",-    "receiverList": {-        "receiver": [-            {-                "email": "user@mail.com",-                "amount": "1.00"-            }-        ]-    },-    "returnUrl": "https://example.com/",-    "senderEmail": "payments@mail.com",-    "requestEnvelope": {-        "errorLanguage": "en_US"-    },-    "actionType": "PAY"-}

@@ -0,0 +1,18 @@+{+    "currencyCode": "USD",+    "cancelUrl": "https://example.com/cancel",+    "receiverList": {+        "receiver": [+            {+                "email": "user@mail.com",+                "amount": "1.00"+            }+        ]+    },+    "returnUrl": "https://example.com/",+    "senderEmail": "payments@mail.com",+    "requestEnvelope": {+        "errorLanguage": "en_US"+    },+    "actionType": "PAY"+}

@@ -14,64 +14,175 @@ import Test.HUnit hiding (Test) import Utils import Web.PayPal.Adaptive+import Web.PayPal.Adaptive.Internal  main :: IO () main = defaultMain [integrationRemote]  integrationRemote :: Test integrationRemote = testGroup "remote"-  [ testCase "successfully sends a payment" sendPayment-  , testCase "successfully creates a deposit" createPayment+  [ testCase+      "withdrawal succeeds with good arguments"+      correctWithdrawal+  , testCase+      "withdrawal with a bad account address gives the correct error"+      withdrawalAccountAddressDNE+  , testCase+      "withdrawal with a bad user address gives the correct error"+      withdrawalUserAddressDNE+  , testCase+      "withdrawal without a large enough balance gives the correct error"+      withdrawalNotEnoughFunds+  , testCase+      "deposit succeeds with good arguments"+      correctDeposit+  , testCase+      "deposit with a bad account address does NOT produce an error"+      depositAccountAddressDNE+  , testCase+      "deposit with a bad user address gives the correct error"+      depositUserAddressDNE   ]  -- | Currently the ID for all sandbox apps. appId :: Text appId = "APP-80W284485P519543T" -instance FromJSON PpClient where+instance FromJSON Client where   parseJSON = withObject "client credentials" $ \o ->-    PpClient appId PpSandbox     <$>+    Client appId                 <$>+    o .: "sandboxClientUid"      <*>+    pure Sandbox                 <*>     o .: "sandboxClientPassword" <*>     o .: "sandboxClientSig"      <*>-    o .: "sandboxClientUid"+    o .: "sandboxAccountEmail" -config :: IO (PpClient, Text, Text)+config :: IO (Client, Text, Text) config = do   b <- B.readFile "sandbox.json"   client <- assertRight (eitherDecode b)   Object o <- assertRight (eitherDecode b)-  String accountEmail <- assertJust "sandboxAccountEmail not found"-    $ H.lookup "sandboxAccountEmail" o   String userEmail <- assertJust "sandboxUserEmail not found"     $ H.lookup "sandboxUserEmail" o-  return (client, accountEmail, userEmail)+  String notSandboxEmail <- assertJust "randomNonSandboxUserEmail not found"+    $ H.lookup "randomNonSandboxUserEmail" o+  return (client, userEmail, notSandboxEmail) -sendPayment :: Assertion-sendPayment = do-  (client, accountEmail, userEmail) <- config-  payResp <- assertRight =<< toPayPal client (send accountEmail userEmail)-  void . assertRight =<< toPayPal client (LookupPayKey . _prPayKey $ payResp)+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+  }++deposit :: Text -> Deposit+deposit userAddr = def+  { _dpAmount = USD 1+  , _dpSenderEmail = userAddr+  }++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-    send :: Text -> Text -> SendPayment-    send accountAddr userAddr = def-      { _spReceiverList = ReceiverList-        { _rlAmount = USD 1-        , _rlEmail = userAddr-        }-      , _spSenderEmail = accountAddr-      }+    checkLookup :: PayResp -> Either AdaptiveErr ()+    checkLookup a = do+      payExecStatusCompleted a+      info <- getPayInfo a+      transactionStatusCompleted a info+      errorFieldNothing a+      checkPayKey a+      Right () -createPayment :: Assertion-createPayment = do-  (client, accountEmail, userEmail) <- config-  payResp <- assertRight =<< toPayPal client (create accountEmail userEmail)-  void . assertRight =<< toPayPal client (LookupPayKey . _prPayKey $ payResp)+withdrawalAccountAddressDNE :: Assertion+withdrawalAccountAddressDNE = do+  (client, userEmail, notSandboxEmail) <- config+  let c = incorrectEmailClient notSandboxEmail client+  adaptiveErr <- assertLeft =<< toPayPal 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)   where-    create :: Text -> Text -> CreatePayment-    create accountAddr userAddr = def-      { _cpReceiverList = ReceiverList-        { _rlAmount = USD 1-        , _rlEmail = accountAddr-        }-      , _cpSenderEmail = userAddr+    checkResp :: AdaptiveErr -> IO PayResp+    checkResp (AePending payResp) = do+      assertEqual+        "withdraw to nonexistent user addresses return no PayResps"+        0 (length $ _prPayInfo payResp)+      return payResp+    checkResp _ =+      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 ()++withdrawalNotEnoughFunds :: Assertion+withdrawalNotEnoughFunds = do+  (client, userEmail, _) <- config+  adaptiveErr <- assertLeft =<< toPayPal 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       }++correctDeposit :: Assertion+correctDeposit = do+  (client, userEmail, _) <- config+  payResp <- assertRight =<< toPayPal client (deposit userEmail)+  (assrt . checkLookup) =<< assertRight =<< toPayPal client (LookupPayKey . _prPayKey $ payResp)+  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 ()++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)+  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 ()++depositUserAddressDNE :: Assertion+depositUserAddressDNE = do+  (client, _, notSandboxEmail) <- config+  adaptiveErr <- assertLeft =<< toPayPal client (deposit notSandboxEmail)+  assertEqual "create error due to a nonexistent user address" AeNoSuchEmail adaptiveErr

@@ -2,6 +2,9 @@  import Test.HUnit +assertFalse :: String -> IO ()+assertFalse s = assertFailure s >> fail "assertFalse"+ assertJust :: String -> Maybe a -> IO a assertJust s a =   case a of@@ -13,3 +16,9 @@   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"