paypal-adaptive-hoops 0.10.0.2 → 0.11.0.0

raw patch · 15 files changed

+734/−745 lines, 15 filesdep −data-defaultPVP ok

version bump matches the API change (PVP)

Dependencies removed: data-default

API changes (from Hackage documentation)

Files

• Example.hs +38/−48
• paypal-adaptive-hoops.cabal +7/−8
• src/PayPal/Adaptive.hs +44/−0
• src/PayPal/Adaptive/Core.hs +367/−0
• src/PayPal/Adaptive/Deposit.hs +75/−0
• src/PayPal/Adaptive/Internal.hs +16/−0
• src/PayPal/Adaptive/Lookup.hs +28/−0
• src/PayPal/Adaptive/Withdrawal.hs +55/−0
• src/Web/PayPal/Adaptive.hs +0/−22
• src/Web/PayPal/Adaptive/Core.hs +0/−537
• src/Web/PayPal/Adaptive/Internal.hs +0/−17
• tests/Local/Money.hs +2/−2
• tests/Local/Parser.hs +28/−26
• tests/Local/json/serializeWithdrawal.json +1/−1
• tests/Remote.hs +73/−84

@@ -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/"   }

@@ -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 

@@ -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)

@@ -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.+--+-- <https://developer.paypal.com/docs/classic/api/adaptive-payments/Pay_API_Operation/>+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)

@@ -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:+-- <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 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)

@@ -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

@@ -0,0 +1,28 @@+{-# LANGUAGE GADTs #-}++-- | Look up information about a payment.+--+-- <https://developer.paypal.com/docs/classic/api/adaptive-payments/PaymentDetails_API_Operation/>++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

@@ -0,0 +1,55 @@+{-# LANGUAGE TemplateHaskell #-}++-- | 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 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)

@@ -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

@@ -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:--- <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 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:--- <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 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.------ <https://developer.paypal.com/docs/classic/api/adaptive-payments/PaymentDetails_API_Operation/>-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.------ <https://developer.paypal.com/docs/classic/api/adaptive-payments/Pay_API_Operation/>-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)

@@ -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

@@ -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"

@@ -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

@@ -1,6 +1,6 @@ {     "currencyCode": "USD",-    "cancelUrl": "https://example.com/cancel",+    "cancelUrl": "https://example.com/",     "receiverList": {         "receiver": [             {

@@ -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