paypal-adaptive-hoops 0.11.0.2 → 0.13.1.0

raw patch · 28 files changed

+709/−767 lines, 28 filesdep +directorydep +filepathdep −unordered-containersdep ~HUnitdep ~test-frameworkdep ~test-framework-hunitPVP ok

version bump matches the API change (PVP)

Dependencies added: directory, filepath

Dependencies removed: unordered-containers

Dependency ranges changed: HUnit, test-framework, test-framework-hunit

API changes (from Hackage documentation)

Files

• Example.hs +39/−21
• README.md +1/−1
• paypal-adaptive-hoops.cabal +22/−14
• src/Import.hs +9/−0
• src/PayPal/Adaptive.hs +14/−35
• src/PayPal/Adaptive/Core.hs +0/−367
• src/PayPal/Adaptive/Core/Client.hs +27/−0
• src/PayPal/Adaptive/Core/Error.hs +60/−0
• src/PayPal/Adaptive/Core/Internal.hs +51/−0
• src/PayPal/Adaptive/Core/Money.hs +31/−0
• src/PayPal/Adaptive/Core/PayResponse.hs +46/−0
• src/PayPal/Adaptive/Core/PayResponse/PayKey.hs +18/−0
• src/PayPal/Adaptive/Core/PayResponse/PayStatus.hs +42/−0
• src/PayPal/Adaptive/Core/PayResponse/PaymentInfo.hs +46/−0
• src/PayPal/Adaptive/Core/PayResponse/PaymentInfo/Receiver.hs +19/−0
• src/PayPal/Adaptive/Core/PayResponse/PaymentInfo/TransactionId.hs +15/−0
• src/PayPal/Adaptive/Core/PayResponse/PaymentInfo/TransactionStatus.hs +38/−0
• src/PayPal/Adaptive/Core/Processing.hs +92/−0
• src/PayPal/Adaptive/Deposit.hs +25/−30
• src/PayPal/Adaptive/Internal.hs +0/−16
• src/PayPal/Adaptive/Lookup.hs +16/−12
• src/PayPal/Adaptive/Withdrawal.hs +14/−9
• tests/Import.hs +29/−0
• tests/Local.hs +3/−1
• tests/Local/Money.hs +0/−46
• tests/Local/Parser.hs +0/−121
• tests/Remote.hs +52/−70
• tests/Utils.hs +0/−24

@@ -3,9 +3,9 @@ module Main where  import           Prelude                    hiding (getLine, lookup, putStr, putStrLn)-import           Control.Applicative import           Data.Text                  (Text) import           Data.Text.IO+ import qualified PayPal.Adaptive            as PP import qualified PayPal.Adaptive.Deposit    as DP import qualified PayPal.Adaptive.Lookup     as LP@@ -29,39 +29,57 @@  main :: IO () main = do++  exampleWithdrawal++  payKey <- startExampleDeposit++  putStrLn "-- Go here and use the other account's password to approve the payment:"+  putStrLn (DP.approvalUrl client payKey)+  putStrLn ""+  putStrLn "-- Once that's done press enter ..."+  _ <- getLine++  finishExampleDeposit payKey+++exampleWithdrawal :: IO ()+exampleWithdrawal = do   putStrLn "-- Sending money to another PayPal account."-  resp <- WD.req client withdrawal+  resp <- WD.request client withdrawal   case resp of-    Left e               -> print e+    Left e               -> error (show e)     Right withdrawalResp -> do       print withdrawalResp       putStrLn "" -      putStrLn "-- Creating a payment from another account to us."-      resp2 <- DP.req client deposit-      putStrLn ""-      case resp2 of-        Left e2      -> print e2-        Right payKey -> do-          putStrLn "-- Go here and use the other account's password to approve the payment:"-          putStrLn (DP.approvalUrl client payKey)-          putStrLn ""-          putStrLn "-- Once that's done press enter ..."-          _ <- getLine+startExampleDeposit :: IO PP.PayKey+startExampleDeposit = do+  putStrLn "-- Creating a payment from another account to us."+  resp <- DP.request client deposit+  putStrLn ""+  case resp of+    Left e            -> error (show e)+    Right (_,payResp) -> return (PP._prPayKey payResp) -          putStrLn "-- Now looking up the payment on PayPal to make sure it succeeded."-          resp3 <- (PP.checkComplete =<<) <$> LP.req client (LP.LookupPayKey payKey)-          case resp3 of-            Left e3               -> print e3-            Right completePayment -> print completePayment+finishExampleDeposit :: PP.PayKey -> IO ()+finishExampleDeposit payKey = do+  putStrLn "-- Now looking up the payment on PayPal to make sure it succeeded."+  resp <- LP.request client (LP.LookupPayKey payKey)+  case resp of+    Left e            -> error (show e)+    Right (_,payResp) ->+      case PP.checkComplete payResp of+        Left e2               -> error (show e2)+        Right completePayment -> print completePayment  client :: PP.Client client = PP.Client   { PP._clAppId        = "APP-80W284485P519543T" -- Currently the ID for all sandbox apps.   , PP._clUserId       = userId-  , PP._clEnv          = PP.Sandbox+  , PP._clEnvironment  = PP.Sandbox   , PP._clPassword     = password-  , PP._clSig          = sig+  , PP._clSignature    = sig   , PP._clAccountEmail = accountEmail   } 

@@ -1,6 +1,6 @@ # Intro -A high-level Haskell client for a limited part of PayPal's [Adaptive Payments API](https://developer.paypal.com/docs/classic/products/adaptive-payments/).+A Haskell client for a limited part of PayPal's [Adaptive Payments API](https://developer.paypal.com/docs/classic/products/adaptive-payments/).  Covers only sending, receiving, and looking up payments. Only supports handling a single payment per request, and doesn't cover sending payments that involve more than two parties. 

@@ -1,5 +1,5 @@ name:                 paypal-adaptive-hoops-version:              0.11.0.2+version:              0.13.1.0 author:               Ian Grant Jeffries maintainer:           ian@housejeffries.com category:             Web@@ -15,16 +15,26 @@ library   hs-source-dirs:     src   exposed-modules:    PayPal.Adaptive+                      PayPal.Adaptive.Core.Internal                       PayPal.Adaptive.Deposit                       PayPal.Adaptive.Lookup                       PayPal.Adaptive.Withdrawal-                      PayPal.Adaptive.Internal-  other-modules:      PayPal.Adaptive.Core+  other-modules:      Import+                      PayPal.Adaptive.Core.Client+                      PayPal.Adaptive.Core.Error+                      PayPal.Adaptive.Core.Money+                      PayPal.Adaptive.Core.PayResponse+                      PayPal.Adaptive.Core.PayResponse.PaymentInfo+                      PayPal.Adaptive.Core.PayResponse.PaymentInfo.Receiver+                      PayPal.Adaptive.Core.PayResponse.PaymentInfo.TransactionId+                      PayPal.Adaptive.Core.PayResponse.PaymentInfo.TransactionStatus+                      PayPal.Adaptive.Core.PayResponse.PayKey+                      PayPal.Adaptive.Core.PayResponse.PayStatus+                      PayPal.Adaptive.Core.Processing   default-language:   Haskell2010   ghc-options:        -Wall   default-extensions: OverloadedStrings-  other-extensions:   GADTs-                    , MultiWayIf+  other-extensions:   MultiWayIf                     , TemplateHaskell    build-depends:      aeson        >= 0.8   && < 0.10@@ -44,9 +54,7 @@   type:               exitcode-stdio-1.0   hs-source-dirs:     tests   main-is:            Local.hs-  other-modules:      Local.Money-                      Local.Parser-                      Utils+  other-modules:      Import   default-language:   Haskell2010   ghc-options:        -Wall   default-extensions: OverloadedStrings@@ -56,16 +64,17 @@                     , bytestring                     , paypal-adaptive-hoops                     , text+                    , directory            >= 1.2 && < 1.3+                    , filepath             >= 1.4 && < 1.5                     , HUnit                >= 1.2 && < 1.3                     , test-framework       >= 0.8 && < 0.9                     , test-framework-hunit >= 0.3 && < 0.4-                    , unordered-containers >= 0.2 && < 0.3  test-suite remote   type:               exitcode-stdio-1.0   hs-source-dirs:     tests   main-is:            Remote.hs-  other-modules:      Utils+  other-modules:      Import   default-language:   Haskell2010   ghc-options:        -Wall   default-extensions: OverloadedStrings@@ -75,10 +84,9 @@                     , bytestring                     , paypal-adaptive-hoops                     , text-                    , HUnit                >= 1.2 && < 1.3-                    , test-framework       >= 0.8 && < 0.9-                    , test-framework-hunit >= 0.3 && < 0.4-                    , unordered-containers >= 0.2 && < 0.3+                    , HUnit+                    , test-framework+                    , test-framework-hunit  executable example   main-is:            Example.hs

@@ -0,0 +1,9 @@++module Import (module Import) where++import           Control.Lens     as Import hiding ((.=))+import           Data.Aeson       as Import+import           Data.Monoid      as Import+import           Data.Text        as Import (Text)+import           Data.Traversable as Import+import           Data.Vector      as Import (Vector)

@@ -1,44 +1,23 @@-{-# LANGUAGE TemplateHaskell #-}  module PayPal.Adaptive (-   -- * Client-    Client           (..)-  , Env              (..)+    module PayPal.Adaptive.Core.Client -  -- * Errors-  , AdaptiveErr      (..)+  -- * Error+  , module PayPal.Adaptive.Core.Error -  -- * Payment Responses-  , PayResp          (..)-  , CompletePayResp  (..)-  , checkComplete-  , PayExecStatus    (..)-  , PayKey           (..)-  , PayInfo          (..)-  , Receiver         (..)-  , TransactionId    (..)-  , TransactionStatus(..)+  -- * PayResponse+  , module PayPal.Adaptive.Core.PayResponse -  -- * Money-  , Money            (..)-  , m2Currency-  , m2PayPal+  -- * Processing+  , module PayPal.Adaptive.Core.Processing -  , module PayPal.Adaptive+  -- * Money+  , module PayPal.Adaptive.Core.Money   ) where -import Control.Lens-import PayPal.Adaptive.Core---- * Lenses-$(makeLenses ''Client)-$(makeLenses ''CompletePayResp)-$(makePrisms ''AdaptiveErr)-$(makePrisms ''Env)-$(makePrisms ''PayExecStatus)-$(makeLenses ''PayInfo)-$(makeLenses ''PayResp)-$(makeLenses ''Receiver)-$(makePrisms ''TransactionId)-$(makePrisms ''TransactionStatus)+import           PayPal.Adaptive.Core.Client+import           PayPal.Adaptive.Core.Error+import           PayPal.Adaptive.Core.Money+import           PayPal.Adaptive.Core.PayResponse+import           PayPal.Adaptive.Core.Processing

@@ -1,367 +0,0 @@-{-# LANGUAGE MultiWayIf      #-}-{-# LANGUAGE TemplateHaskell #-}--module PayPal.Adaptive.Core where--import           Prelude              hiding (mapM)-import           Control.Applicative-import           Control.Exception-import           Control.Lens         hiding ((.=))-import           Data.Aeson-import           Data.Aeson.TH        hiding (Options)-import           Data.Aeson.Types     hiding (Options)-import           Data.ByteString.Lazy (ByteString)-import           Data.Char-import           Data.Maybe-import           Data.Monoid-import           Data.Text            (Text)-import qualified Data.Text            as T-import           Data.Text.Encoding-import           Data.Text.Read-import           Data.Traversable-import qualified Data.Vector          as V-import           Network.Wreq------------------------------------------------------- Client-----------------------------------------------------data Client = Client-  { _clAppId        :: Text-  , _clUserId       :: Text-  , _clEnv          :: Env-  , _clPassword     :: Text-  , _clSig          :: Text-  -- | Not needed for authentication, but deposits are sent-  -- to here and withdrawals are sent from here. Must be the-  -- email associated with your PayPal app.-  , _clAccountEmail :: Text-  } deriving (Eq, Show)--data Env = Sandbox | Production deriving (Eq, Show, Read)------------------------------------------------------- Errors------------------------------------------------------- | Text is an error message in all the below types.------ AeShouldNotHappen is meant to cover PayPal responses to API requests--- that this library doesn't support sending in the first place.--- TODO: is this actually how we're using it?-data AdaptiveErr-  = AeConnectionErr   Text-  | AeDecodeFailed    ByteString Text-  | AeInvalidCredentials-  -- ^ Just a wrapper around an AeErrCodes Int.-  | AeNoSuchEmail-  -- ^ Just a wrapper around an AeErrCodes Int. Raised when the Deposit-  -- sender email or the Withdrawal account email doesn't exist.-  | AeErrCodes        [Int]-  | AePending         PayResp-  | AeRefused         PayResp-  | AeShouldNotHappen PayResp Text-  deriving (Eq, Show)---- Error responses are what's returned if, e.g., your password is incorrect.------ Here's an example error response. Only the parts we parse are included.------     {---         "error": [---             {---                 "errorId": "111111",---             }---         ]---     }-instance FromJSON AdaptiveErr where-  parseJSON = withObject "error response" $ \o ->-    AeErrCodes . V.toList <$> (mapM parseErrId =<< o .: "error")---- | Exported by PayPal.Adaptive.Internal-parseErrId :: Value -> Parser Int-parseErrId = withObject "error array item" $ \o -> do-  a <- o .: "errorId"-  case decimal a of-    Left  _     -> fail "Could not parse error response code to Int"-    Right (b,_) -> return b------------------------------------------------------- * Payment Responses------------------------------------------------------- | Used for forgiving attempts to parse PayPal responses. For instance,--- this library never expects more than one PayInfo. We still try to--- parse them as a list here so we can still sucessfully parse a PayResp--- to use in an 'AdaptiveError' if for some reason more than one 'PayInfo'--- is returned -data PayResp = PayResp-  { _prPayError      :: Maybe Text-  , _prPayExecStatus :: PayExecStatus-  , _prPayKey        :: PayKey-  , _prPayInfos      :: [PayInfo]-  } deriving (Eq, Show)---- | A version of 'PayResp' for completed transactions.------ Status fields are omitted since they should be complete.------ Has no separate field for a 'PayInfo' list since successful transactions--- will always have exactly one. Instead the pay info fields have been--- flattened into the top level of this structure.-data CompletePayResp = CompletePayResp-  { _crPayKey              :: PayKey-  , _crReceiver            :: Receiver-  , _crSenderTransactionId :: TransactionId-  , _crTransactionId       :: TransactionId-  } deriving (Eq, Show)--checkComplete :: PayResp -> Either AdaptiveErr CompletePayResp-checkComplete pr = do-  errorFieldNothing pr-  payExecStatusCompleted pr-  checkPayKey pr-  info <- getPayInfo pr-  sid <- transactionIdJust pr (_piSenderTransactionId info)-  transactionStatusCompleted pr info-  tid <- transactionIdJust pr (_piTransactionId info)-  return $ CompletePayResp (_prPayKey pr) (_piReceiver info) sid tid--instance FromJSON PayResp where-  parseJSON = withObject "PayResp" $ \o -> do-    e <- o .:? "payErrorList"-    k <- o .:  "payKey"--    s  <- o .:? "paymentExecStatus"-    s' <- o .:? "status"-    status <- maybe (fail "no paymentExecStatus or status") return (if isJust s then s else s')--    a <- o .:? "paymentInfoList"-    case a of-      Nothing -> return $ PayResp e status k mempty-      Just v  -> do-        infos <- v .:? "paymentInfo" .!= mempty-        return $ PayResp e status k infos---- | This refers to the processing of this request. To make sure a payment--- has actually gone through, check 'TransactionStatus' instead.------ PayPal returns this using the JSON object key "paymentExecStatus"--- in responses to Withdrawal and Deposit and "status" in responses to--- LookupPayment.-data PayExecStatus-  = PeCreated-  | PeCompleted-  | PeIncomplete-  | PeError-  | PeReversalError-  | PeProcessing-  | PePending-  deriving (Eq, Show, Read)---- | Expires after three hours.------ <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,27 @@+{-# LANGUAGE TemplateHaskell #-}++module PayPal.Adaptive.Core.Client where++import           Data.Aeson.TH+import           Data.Aeson.Types (camelTo)++import           Import++data Client = Client+  { _clAppId        :: Text+  , _clUserId       :: Text+  , _clEnvironment  :: Environment+  , _clPassword     :: Text+  , _clSignature    :: Text+  , _clAccountEmail :: Text+  -- ^ Not needed for authentication, but deposits are sent+  -- to here and withdrawals are sent from here. Must be the+  -- email associated with your PayPal app.+  } deriving (Eq, Show)++data Environment = Sandbox | Production deriving (Eq, Show, Read)++$(deriveJSON defaultOptions { fieldLabelModifier = camelTo '_' . drop 3 } ''Client)+$(deriveJSON defaultOptions { constructorTagModifier = id } ''Environment)+$(makeLenses ''Client)+$(makePrisms ''Environment)

@@ -0,0 +1,60 @@+{-# LANGUAGE TemplateHaskell #-}++module PayPal.Adaptive.Core.Error where++import           Control.Exception+import           Data.ByteString.Lazy (ByteString)+import           Data.Text.Read+import qualified Data.Vector          as V++import           Import++-- | Text is an error message in all the below types.+--+-- AeShouldNotHappen is meant to cover PayPal responses to API requests+-- that this library doesn't support sending in the first place.+-- TODO: is this actually how we're using it?+data AdaptiveError+  = AeConnectionError SomeException+  | AeDecodeFailed    ByteString Text+  | AeErrorResponse   ByteString ErrorResponse+  deriving Show -- Eq can't be automatically derived because there's no Eq instance for SomeException.++data ErrorResponse = ErrorResponse { _unErrorResponse :: [PayError] } deriving (Eq, Show)++-- Error responses are what's returned if, e.g., your password is incorrect.+instance FromJSON ErrorResponse where+  parseJSON = withObject "ErrorResponse" $ \o ->+    ErrorResponse . V.toList <$> (traverse parseJSON =<< o .: "error")++data PayError = PayError { _errorCode    :: ErrorCode+                         , _errorMessage :: Text+                         } deriving (Eq, Show)++instance FromJSON PayError where+  parseJSON = withObject "PayError" $ \o -> PayError <$> o .: "errorId" <*> o .: "message"++newtype ErrorCode = ErrorCode { _unErrorCode :: Int } deriving Eq++instance Show ErrorCode where+  show n | n == invalidCredentials = "Error code " <> show (_unErrorCode n) <> " - invalid credentials"+         | n == noSuchEmail        = "Error code " <> show (_unErrorCode n) <> " - no such email"+         | otherwise               = "Error code " <> show (_unErrorCode n)++instance FromJSON ErrorCode where+  parseJSON = withText "ErrorCode" $ \t ->+    case decimal t of+      Left  _     -> fail "Could not parse error response code to Int"+      Right (b,_) -> return (ErrorCode b)++invalidCredentials :: ErrorCode+invalidCredentials = ErrorCode 520003++-- | Raised when the Deposit sender email or the Withdrawal account email doesn't exist.+noSuchEmail :: ErrorCode+noSuchEmail = ErrorCode 589039++$(makeLenses ''ErrorCode)+$(makeLenses ''ErrorResponse)+$(makeLenses ''PayError)+$(makePrisms ''AdaptiveError)

@@ -0,0 +1,51 @@+{-# LANGUAGE MultiWayIf #-}++module PayPal.Adaptive.Core.Internal where++import           Control.Exception+import           Data.ByteString.Lazy             (ByteString)+import qualified Data.Text                        as T+import           Data.Text.Encoding+import           Network.Wreq++import           Import+import           PayPal.Adaptive.Core.Client+import           PayPal.Adaptive.Core.Error+import           PayPal.Adaptive.Core.PayResponse++ppPost :: (ToJSON a) => Client -> Text -> a -> IO (Either AdaptiveError ByteString)+ppPost c endpoint p = catch (return . Right . (^.responseBody) =<< runPost) handler+  where+    runPost :: IO (Response ByteString)+    runPost = postWith opts (clBaseUrl <> T.unpack endpoint) (toJSON p)++    clBaseUrl :: String+    clBaseUrl =+      case _clEnvironment c of+        Sandbox    -> "https://svcs.sandbox.paypal.com/AdaptivePayments/"+        Production -> "https://svcs.paypal.com/AdaptivePayments/"++    handler :: SomeException -> IO (Either AdaptiveError ByteString)+    handler e = return . Left . AeConnectionError $ e++    opts :: Options+    opts = defaults+      & header "X-PAYPAL-SECURITY-USERID"      .~ [ encodeUtf8 (_clUserId    c) ]+      & header "X-PAYPAL-SECURITY-PASSWORD"    .~ [ encodeUtf8 (_clPassword  c) ]+      & header "X-PAYPAL-SECURITY-SIGNATURE"   .~ [ encodeUtf8 (_clSignature c) ]+      & header "X-PAYPAL-APPLICATION-ID"       .~ [ encodeUtf8 (_clAppId     c) ]+      & header "X-PAYPAL-REQUEST-DATA-FORMAT"  .~ [ "JSON" ]+      & header "X-PAYPAL-RESPONSE-DATA-FORMAT" .~ [ "JSON" ]++ppDecode :: ByteString -> Either AdaptiveError PayResponse+ppDecode b =+  case eitherDecode b of+    Right d -> Right d+    Left  e ->+      case decode b of -- If the response isn't a PayResponse, it might be a PayPal error message.+        Just res@(ErrorResponse _) -> Left $ AeErrorResponse b res+        _                          -> Left $ AeDecodeFailed b (T.pack e)++-- | "en_US" is hardcoded because it's the only supported error language.+requestEnvelope :: Value+requestEnvelope = object ["errorLanguage" .= ("en_US" :: Text)]

@@ -0,0 +1,31 @@++module PayPal.Adaptive.Core.Money where++import           Import++data Money = USD { _usdCents :: Int } deriving (Eq, Show)++-- NOTE: Once we add more currencies this instance will violate the+-- Monoid laws.+instance Monoid Money where+  mempty = USD 0+  mappend (USD c1) (USD c2) = USD $ c1 + c2++m2Currency :: Money -> Text+m2Currency (USD _) = "USD"++m2PayPal :: Money -> String+m2PayPal (USD c) =+  let s = show (abs c)+      a = case length s of+            0 -> "0.00"+            1 -> "0.0" <> s+            2 -> "0." <> s+            _ -> tailInsert 2 '.' s+  in if c < 0 then '-':a else a++  where+    tailInsert :: Int -> a -> [a] -> [a]+    tailInsert i x xs =+      let (ys, zs) = splitAt i (reverse xs)+      in reverse (ys <> pure x <> zs)

@@ -0,0 +1,46 @@+{-# LANGUAGE TemplateHaskell #-}++module PayPal.Adaptive.Core.PayResponse+  ( module Export+  , module PayPal.Adaptive.Core.PayResponse+  ) where++import           Data.Maybe                                   (isJust)++import           Import+import           PayPal.Adaptive.Core.PayResponse.PayKey      as Export+import           PayPal.Adaptive.Core.PayResponse.PaymentInfo as Export+import           PayPal.Adaptive.Core.PayResponse.PayStatus   as Export++-- | Used for forgiving attempts to parse PayPal responses. For instance,+-- this library never expects more than one PaymentInfo. We still try to+-- parse them as a list here so we can still sucessfully parse a PayResp+-- to use in an 'AdaptiveError' if for some reason more than one 'PaymentInfo'+-- is returned.+--+-- <https://developer.paypal.com/docs/classic/api/adaptive-payments/Pay_API_Operation/>+data PayResponse = PayResponse+  { _prPayError      :: Maybe Text+  -- ^ payErrorList (string) -- Information about why a payment failed.+  , _prPayStatus     :: PayStatus+  , _prPayKey        :: PayKey+  , _prPaymentInfos  :: [PaymentInfo]+  } deriving (Eq, Show)++instance FromJSON PayResponse where+  parseJSON = withObject "PayResp" $ \o -> do+    e <- o .:? "payErrorList"+    k <- o .:  "payKey"++    s  <- o .:? "paymentExecStatus"+    s' <- o .:? "status"+    status <- maybe (fail "no paymentExecStatus or status") return (if isJust s then s else s')++    a <- o .:? "paymentInfoList"+    case a of+      Nothing -> return $ PayResponse e status k mempty+      Just v  -> do+        infos <- v .:? "paymentInfo" .!= mempty+        return $ PayResponse e status k infos++$(makeLenses ''PayResponse)

@@ -0,0 +1,18 @@+{-# LANGUAGE TemplateHaskell #-}++module PayPal.Adaptive.Core.PayResponse.PayKey where++import           Import++-- | 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++$(makeLenses ''PayKey)

@@ -0,0 +1,42 @@+{-# LANGUAGE TemplateHaskell #-}++module PayPal.Adaptive.Core.PayResponse.PayStatus where++import           Data.Aeson.TH+import           Data.Char (toUpper)++import           Import++-- | This refers to the processing of this request. To make sure a payment+-- has actually gone through, check 'TransactionStatus' as well.+--+-- PayPal returns this using the JSON object key "paymentExecStatus"+-- in responses to Withdrawal and Deposit and "status" in responses to+-- LookupPayment.+--+-- https://developer.paypal.com/docs/classic/api/adaptive-payments/PaymentDetails_API_Operation/+data PayStatus+  = PeCreated+  -- ^ CREATED – The payment request was received; funds will be transferred once the payment is approved+  | PeCompleted+  -- ^ COMPLETED – The payment was successful+  | PePending+  -- ^ PENDING – The payment is awaiting processing+  | PeProcessing+  -- ^ PROCESSING – The payment is in progress+  | PeIncomplete+  -- ^ INCOMPLETE – Some transfers succeeded and some failed for a parallel payment or,+  -- for a delayed chained payment, secondary receivers have not been paid+  | PeExpired+  -- ^ EXPIRED+  --+  -- NOTE: This occurs in practice, but isn't in the documentation.+  | PeError+  -- ^ ERROR – The payment failed and all attempted transfers failed or all completed transfers+  -- were successfully reversed+  | PeReversalError+  -- ^ REVERSALERROR – One or more transfers failed when attempting to reverse a payment+  deriving (Eq, Show, Read)++$(deriveFromJSON defaultOptions { constructorTagModifier = map toUpper . drop 2 } ''PayStatus)+$(makePrisms ''PayStatus)

@@ -0,0 +1,46 @@+{-# LANGUAGE TemplateHaskell #-}++module PayPal.Adaptive.Core.PayResponse.PaymentInfo+  ( module Export+  , module PayPal.Adaptive.Core.PayResponse.PaymentInfo+  ) where++import           Data.Aeson.TH+import           Data.Char                                                      (toLower)++import           Import+import           PayPal.Adaptive.Core.PayResponse.PaymentInfo.Receiver          as Export+import           PayPal.Adaptive.Core.PayResponse.PaymentInfo.TransactionId     as Export+import           PayPal.Adaptive.Core.PayResponse.PaymentInfo.TransactionStatus as Export++-- | Right toPayPal responses return a PayInfo along with a+-- _piTransactionStatus Just, with some exceptions.+--+--     1. Withdrawals to nonexistent accounts return no PayInfos.+--+--     2. Lookups on such transactions return one PayInfo with a+--     _piTransactionStatus of Nothing.+--+--     3. Deposits don't return PayInfos.+--+--     4. Lookups on such transactions return one PayInfo with a+--     _piTransactionStatus of Nothing.+--+-- NOTE: We use the same newtype for both _piSenderTransactionId and+-- _piTransactionStatus. They will have different values, but either+-- can be used to look up a payment.+--+--+-- https://developer.paypal.com/docs/classic/api/adaptive-payments/PaymentDetails_API_Operation/+--+-- Represents the payment attempt made to a receiver of a PayRequest. If the execution of the payment has not yet completed, there are no transaction details returned.+data PaymentInfo = PaymentInfo+  { _piReceiver                :: Receiver+  , _piTransactionId           :: Maybe TransactionId+  , _piTransactionStatus       :: Maybe TransactionStatus+  , _piSenderTransactionId     :: Maybe TransactionId+  , _piSenderTransactionStatus :: Maybe TransactionStatus+  } deriving (Eq, Show)++$(deriveFromJSON defaultOptions { fieldLabelModifier = (\(x:xs) -> toLower x:xs) . drop 3 } ''PaymentInfo)+$(makeLenses ''PaymentInfo)

@@ -0,0 +1,19 @@+{-# LANGUAGE TemplateHaskell #-}++module PayPal.Adaptive.Core.PayResponse.PaymentInfo.Receiver where++import           Data.Aeson.TH+import           Data.Char (toLower)++import           Import++data Receiver = Receiver+  { _reAmount    :: Text+  -- ^ Haven't converted this to Money yet because I'm not sure how+  -- to determine its currency.+  , _reEmail     :: Text+  , _reAccountId :: Text+  } deriving (Eq, Show)++$(deriveFromJSON defaultOptions { fieldLabelModifier = (\(x:xs) -> toLower x:xs) . drop 3 } ''Receiver)+$(makeLenses ''Receiver)

@@ -0,0 +1,15 @@+{-# LANGUAGE TemplateHaskell #-}++module PayPal.Adaptive.Core.PayResponse.PaymentInfo.TransactionId where++import           Import++newtype TransactionId = TransactionId { _unTransactionId :: Text } deriving (Eq, Show)++instance FromJSON TransactionId where+  parseJSON = withText "TransactionId" $ return . TransactionId++instance ToJSON TransactionId where+  toJSON (TransactionId a) = toJSON a++$(makeLenses ''TransactionId)

@@ -0,0 +1,38 @@+{-# LANGUAGE TemplateHaskell #-}++module PayPal.Adaptive.Core.PayResponse.PaymentInfo.TransactionStatus where++import           Data.Aeson.TH+import           Data.Aeson.Types (camelTo)+import           Data.Char (toUpper)++import           Import++-- | PaymentInfos have both a transactionStatus and senderTransactionStatus field.+-- As far as I can tell the same data type can represent both of them.+-- The comments for the data constructors come from senderTransactionStatus.+--+-- https://developer.paypal.com/docs/classic/api/adaptive-payments/Pay_API_Operation/+data TransactionStatus+  = TsCreated+  -- ^ CREATED – The payment request was received; funds will be transferred once approval is received+  | TsPending+  -- ^ PENDING – The transaction is awaiting further processing+  | TsProcessing+  -- ^ PROCESSING – The transaction is in progress+  | TsCompleted+  -- ^ COMPLETED – The sender's transaction has completed+  | TsDenied+  -- ^ DENIED – The transaction was rejected by the receiver+  | TsFailed+  -- ^ FAILED – The payment failed+  | TsRefunded+  -- ^ REFUNDED – The payment was refunded+  | TsPartiallyRefunded+  -- ^ PARTIALLY_REFUNDED – Transaction was partially refunded+  | TsReversed+  -- ^ REVERSED – The payment was returned to the sender+  deriving (Eq, Show, Read)++$(deriveFromJSON defaultOptions { constructorTagModifier = map toUpper . camelTo '_' . drop 2 } ''TransactionStatus)+$(makePrisms ''TransactionStatus)

@@ -0,0 +1,92 @@+{-# LANGUAGE TemplateHaskell #-}++module PayPal.Adaptive.Core.Processing where++import qualified Data.Text as T++import           Import+import           PayPal.Adaptive.Core.PayResponse++-- | A version of 'PayResponse' for completed transactions.+--+-- Status fields are omitted since they should be complete.+--+-- Has no separate field for a 'PaymentInfo' list since successful transactions+-- will always have exactly one. Instead the pay info fields have been+-- flattened into the top level of this structure.+data CompletePayResponse = CompletePayResponse+  { _cpPayKey              :: PayKey+  , _cpReceiver            :: Receiver+  , _cpTransactionId       :: TransactionId+  , _cpSenderTransactionId :: TransactionId+  } deriving (Eq, Show)++-- | A high level data type that tries to summarize the status+-- of a payment in simple terms (meant to be used in an 'Either',+-- e.g. 'Either' 'NotComplete' 'CompletePayResponse').+data NotComplete+  = NcIncomplete      Text+  | NcFailed          Text+  | NcShouldNotHappen Text+  deriving (Eq, Show)++checkComplete :: PayResponse -> Either NotComplete CompletePayResponse+checkComplete pr = do+  payStatusCompleted pr+  info <- getPaymentInfo pr+  sid <- transactionIdJust (_piSenderTransactionId info)+  transactionStatusCompleted (_piTransactionStatus info)+  transactionStatusCompleted (_piSenderTransactionStatus info)+  tid <- transactionIdJust (_piTransactionId info)+  errorFieldNothing pr+  return $ CompletePayResponse (_prPayKey pr) (_piReceiver info) sid tid+  where+    transactionIdJust :: Maybe TransactionId -> Either NotComplete TransactionId+    transactionIdJust Nothing = Left $ NcShouldNotHappen "expected a Just for Maybe TransactionId"+    transactionIdJust (Just tid) = Right tid++    errorFieldNothing :: PayResponse -> Either NotComplete ()+    errorFieldNothing a+      | _prPayError a == Nothing = Right ()+      | otherwise                =+        Left $ NcShouldNotHappen "PayResponse error field is Just in otherwise correct payment"++    transactionStatusCompleted :: Maybe TransactionStatus -> Either NotComplete ()+    transactionStatusCompleted Nothing       = Left (NcShouldNotHappen "TransactionStatus is Nothing")+    transactionStatusCompleted (Just status) =+      let msg = "TransactionStatus " <> T.pack (show status)+      in case status of+        TsCreated           -> Left (NcIncomplete msg)+        TsPending           -> Left (NcIncomplete msg)+        TsProcessing        -> Left (NcIncomplete msg)+        TsCompleted         -> Right ()+        TsDenied            -> Left (NcFailed msg)+        TsFailed            -> Left (NcFailed msg)+        TsRefunded          -> Left (NcShouldNotHappen msg)+        TsPartiallyRefunded -> Left (NcShouldNotHappen msg)+        TsReversed          -> Left (NcShouldNotHappen msg)++    payStatusCompleted :: PayResponse -> Either NotComplete ()+    payStatusCompleted a =+      let status = _prPayStatus a+          msg = "_prPayStatus: " <> T.pack (show status)+      in case status of+        PeCreated       -> Left (NcIncomplete msg)+        PeCompleted     -> Right ()+        PePending       -> Left (NcIncomplete msg)+        PeProcessing    -> Left (NcIncomplete msg)+        PeIncomplete    -> Left (NcShouldNotHappen msg) -- PeIncomplete has to do with delayed or chained+                                                        -- payments, which we don't support.+        PeExpired       -> Left (NcFailed msg)+        PeError         -> Left (NcFailed msg)+        PeReversalError -> Left (NcShouldNotHappen msg)++getPaymentInfo :: PayResponse -> Either NotComplete PaymentInfo+getPaymentInfo a =+  case _prPaymentInfos a of+    []     -> Left $ NcIncomplete "no PaymentInfo"+    [info] -> Right info+    _      -> Left $ NcShouldNotHappen "more than one PaymentInfo"++$(makeLenses ''CompletePayResponse)+$(makePrisms ''NotComplete)

@@ -17,12 +17,15 @@  module PayPal.Adaptive.Deposit where -import Control.Lens         hiding ((.=))-import Data.Aeson-import Data.Monoid-import Data.Text            (Text)-import PayPal.Adaptive.Core+import           Data.ByteString.Lazy             (ByteString) +import           Import+import           PayPal.Adaptive.Core.Client+import           PayPal.Adaptive.Core.Error+import           PayPal.Adaptive.Core.Internal+import           PayPal.Adaptive.Core.Money+import           PayPal.Adaptive.Core.PayResponse+ data Deposit = Deposit   { _amount      :: Money   , _senderEmail :: Text@@ -36,40 +39,32 @@ instance ToJSON SerializeDeposit where   toJSON (SerializeDeposit p accountEmail) = object     [ "actionType"      .= ("PAY" :: Text)-    , "currencyCode"    .= (m2Currency . _amount) p-    , "receiverList"    .=-      object-        [ "receiver" .= [ object-          ["amount" .= m2PayPal (_amount p)-          , "email" .= accountEmail-          ]-        ]]+    , "currencyCode"    .= m2Currency (_amount p)+    , "receiverList"    .= object+                             [ "receiver" .=+                               [ object+                                   [ "amount" .= m2PayPal (_amount p)+                                   , "email"  .= accountEmail+                                   ]+                               ]+                             ]     , "returnUrl"       .= _returnUrl p     , "cancelUrl"       .= _cancelUrl p     , "requestEnvelope" .= requestEnvelope     , "senderEmail"     .= _senderEmail p     ] -req :: Client -> Deposit -> IO (Either AdaptiveErr PayKey)-req c d = do+request :: Client -> Deposit -> IO (Either AdaptiveError (ByteString,PayResponse) )+request c d = do   resp <- ppPost c "Pay" $ SerializeDeposit d (_clAccountEmail c)-  return $ do-    pr <- ppDecode =<< resp-    payExecStatusCreated pr-    noPayInfo            pr-    errorFieldNothing    pr-    checkPayKey          pr-    Right (_prPayKey pr)+  case resp of+    Left e    -> return $ Left e+    Right bts -> return $ (,) bts <$> ppDecode bts  approvalUrl :: Client -> PayKey -> Text approvalUrl c k =-  case _clEnv c of-    Sandbox ->-      "https://www.sandbox.paypal.com/cgi-bin/webscr?cmd=_ap-payment&paykey="-      <> _unPayKey k-    Production ->-      "https://www.paypal.com/cgi-bin/webscr?cmd=_ap-payment&paykey="-      <> _unPayKey k+  case _clEnvironment c of+    Sandbox    -> "https://www.sandbox.paypal.com/cgi-bin/webscr?cmd=_ap-payment&paykey=" <> _unPayKey k+    Production -> "https://www.paypal.com/cgi-bin/webscr?cmd=_ap-payment&paykey=" <> _unPayKey k --- * Lenses $(makeLenses ''Deposit)

@@ -1,16 +0,0 @@-module PayPal.Adaptive.Internal-  ( ppPost-  , ppDecode-  , parseErrId-  , requestEnvelope-  , payExecStatusCompleted-  , getPayInfo-  , transactionStatusCompleted-  , errorFieldNothing-  , checkPayKey-  , payExecStatusCreated-  , noPayInfo-  , transactionIdJust-  ) where--import PayPal.Adaptive.Core

@@ -1,21 +1,21 @@-{-# 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+import           Data.ByteString.Lazy             (ByteString) -data LookupPayment a where-  LookupTrID   :: TransactionId -> LookupPayment TransactionId-  LookupPayKey :: PayKey        -> LookupPayment PayKey+import           Import+import           PayPal.Adaptive.Core.Client+import           PayPal.Adaptive.Core.Error+import           PayPal.Adaptive.Core.Internal+import           PayPal.Adaptive.Core.PayResponse -instance ToJSON (LookupPayment a) where-  toJSON (LookupTrID (TransactionId p)) =+data LookupPayment = LookupTransactionID TransactionId | LookupPayKey PayKey deriving (Eq, Show)++instance ToJSON LookupPayment where+  toJSON (LookupTransactionID (TransactionId p)) =     object [ "transactionId"   .= p            , "requestEnvelope" .= requestEnvelope            ]@@ -24,5 +24,9 @@            , "requestEnvelope" .= requestEnvelope            ] -req :: Client -> LookupPayment a -> IO (Either AdaptiveErr PayResp)-req c l = (>>= ppDecode) <$> ppPost c "PaymentDetails" l+request :: Client -> LookupPayment -> IO (Either AdaptiveError (ByteString,PayResponse) )+request c l = do+  resp <- ppPost c "PaymentDetails" l+  case resp of+    Left e    -> return $ Left e+    Right bts -> return $ (,) bts <$> ppDecode bts

@@ -13,11 +13,15 @@  module PayPal.Adaptive.Withdrawal where -import Control.Lens         hiding ((.=))-import Data.Aeson-import Data.Text            (Text)-import PayPal.Adaptive.Core+import           Data.ByteString.Lazy             (ByteString) +import           Import+import           PayPal.Adaptive.Core.Client+import           PayPal.Adaptive.Core.Error+import           PayPal.Adaptive.Core.Internal+import           PayPal.Adaptive.Core.Money+import           PayPal.Adaptive.Core.PayResponse+ data Withdrawal = Withdrawal   { _amount        :: Money   , _receiverEmail :: Text@@ -29,7 +33,7 @@ instance ToJSON SerializeWithdrawal where   toJSON (SerializeWithdrawal p accountEmail) = object     [ "actionType"      .= ("PAY" :: Text)-    , "currencyCode"    .= (m2Currency . _amount) p+    , "currencyCode"    .= m2Currency (_amount p)     , "receiverList"    .= object                              [ "receiver" .=                                [ object@@ -46,10 +50,11 @@  -- | If a PayPal account doesn't exist yet PayPal responds with an empty -- list of PayInfos. We return this as Left 'AePending'.-req :: Client -> Withdrawal -> IO (Either AdaptiveErr CompletePayResp)-req c w = do+request :: Client -> Withdrawal -> IO (Either AdaptiveError (ByteString,PayResponse) )+request c w = do   resp <- ppPost c "Pay" $ SerializeWithdrawal w (_clAccountEmail c)-  return $ checkComplete =<< ppDecode =<< resp+  case resp of+    Left e    -> return $ Left e+    Right bts -> return $ (,) bts <$> ppDecode bts --- * Lenses $(makeLenses ''Withdrawal)

@@ -0,0 +1,29 @@++module Import (module Import) where++import           Control.Applicative as Import+import           Data.Aeson          as Import+import           Data.Foldable       as Import+import           Data.Monoid         as Import+import           Data.Text           as Import (Text)+import           Data.Traversable    as Import++import           Test.HUnit++assertJust :: String -> Maybe a -> IO a+assertJust s a =+  case a of+    Nothing -> assertFailure s >> fail "assertJust failed"+    Just b  -> return b++assertRight :: (Show a) => Either a b -> IO b+assertRight a =+  case a of+    Left e  -> assertFailure (show e) >> fail "assertRight failed"+    Right b -> return b++assertLeft :: (Show b) => Either a b -> IO a+assertLeft a =+  case a of+    Left e  -> return e+    Right b -> assertFailure (show b) >> fail "assertLeft failed"

@@ -1,11 +1,13 @@+ module Main where +import Local.BulkParser import Local.Money import Local.Parser import Test.Framework (Test, defaultMain)  tests :: [Test]-tests = [unitMoney, unitParser]+tests = [unitMoney, unitParser, bulkParser]  main :: IO () main = defaultMain tests

@@ -1,46 +0,0 @@-module Local.Money (unitMoney) where--import PayPal.Adaptive-import Test.Framework-import Test.Framework.Providers.HUnit (testCase)-import Test.HUnit                     (Assertion, (@=?))--unitMoney :: Test-unitMoney = testGroup "money"-  [ testCase "handle large negative amount correctly"        largeNegative-  , testCase "handle negative amount correctly"              negative-  , testCase "handle 0 correctly"                            zero-  , testCase "handle 1 correctly"                            oneDigit-  , testCase "handle 10 correctly"                           twoDigitsTrailingZero-  , testCase "show both decimals even if both are zero"      threeDigitsTrailingZeros-  , testCase "show both decimals even if the second is zero" threeDigitsTrailingZero-  , testCase "handles large amount correctly"                largeAmount-  ]--testM2P :: Int -> String -> Assertion-testM2P input correct =-  correct @=? m2PayPal USD { _usdCents = input }--largeNegative            :: Assertion-largeNegative            = testM2P (-98783) "-987.83"--negative                 :: Assertion-negative                 = testM2P (-1) "-0.01"--zero                     :: Assertion-zero                     = testM2P 0 "0.00"--oneDigit                 :: Assertion-oneDigit                 = testM2P 1 "0.01"--twoDigitsTrailingZero    :: Assertion-twoDigitsTrailingZero    = testM2P 10 "0.10"--threeDigitsTrailingZeros :: Assertion-threeDigitsTrailingZeros = testM2P 100 "1.00"--threeDigitsTrailingZero  :: Assertion-threeDigitsTrailingZero  = testM2P 110 "1.10"--largeAmount              :: Assertion-largeAmount              = testM2P 792874 "7928.74"

@@ -1,121 +0,0 @@-module Local.Parser (unitParser) where--import           Data.Aeson-import qualified Data.ByteString.Lazy           as B-import qualified Data.ByteString.Lazy.Char8     as BSC-import           Data.Char                      (isSpace)-import           PayPal.Adaptive-import qualified PayPal.Adaptive.Deposit        as DP-import qualified PayPal.Adaptive.Withdrawal     as WD-import           Test.Framework                 (Test, testGroup)-import           Test.Framework.Providers.HUnit (testCase)-import           Test.HUnit                     (Assertion, (@=?))-import           Utils--unitParser :: Test-unitParser = testGroup "parsers"-  [ testCase "correctly encodes a Withdrawal"             serializeWithdrawal-  , testCase "correctly encodes a Deposit"                serializeDeposit-  , testCase "correctly decodes a Withdrawal response"    parseWithdrawalResp-  , testCase "correctly decodes a Deposit response"       parseDepositResp-  , testCase "correctly decodes a LookupPayment response" parseLookupResp-  , testCase "correctly decodes an error code response"   parseErrResp-  ]--eqSerialized :: (ToJSON a) => FilePath -> a -> Assertion-eqSerialized x y = do-  expected <- B.readFile x-  let actual = encode y-  filterBS expected @=? filterBS actual-  where-    filterBS :: BSC.ByteString -> BSC.ByteString-    filterBS = BSC.filter (not . isSpace)--eqParsed :: (Show a, Eq a, FromJSON a) => a -> FilePath -> Assertion-eqParsed expected x = do-  b <- B.readFile x-  actual <- assertRight (eitherDecode b)-  expected @=? actual--serializeWithdrawal :: Assertion-serializeWithdrawal = "tests/Local/json/serializeWithdrawal.json" `eqSerialized` a-  where-    a :: WD.SerializeWithdrawal-    a = WD.SerializeWithdrawal b "payments@mail.com"--    b :: WD.Withdrawal-    b = WD.Withdrawal-      { WD._amount        = USD 100-      , WD._receiverEmail = "user@mail.com"-      }--serializeDeposit :: Assertion-serializeDeposit = "tests/Local/json/serializeDeposit.json" `eqSerialized` a-  where-    a :: DP.SerializeDeposit-    a = DP.SerializeDeposit b "payments@mail.com"--    b :: DP.Deposit-    b = DP.Deposit-      { DP._amount = USD 100-      , DP._senderEmail  = "user@mail.com"-      , DP._returnUrl   = "https://example.com/"-      , DP._cancelUrl   = "https://example.com/cancel"-      }--parseWithdrawalResp :: Assertion-parseWithdrawalResp = expected `eqParsed` "tests/Local/json/parseWithdrawalResp.json"-  where-    expected = PayResp-      { _prPayError      = Nothing-      , _prPayExecStatus = PeCompleted-      , _prPayKey        = PayKey "AP-21C62741YR509274N"-      , _prPayInfos      = [p]-      }-    p = PayInfo-      { _piReceiver            = r-      , _piSenderTransactionId = Just (TransactionId "7TU31598YN877045D")-      , _piTransactionStatus   = Just TsCompleted-      , _piTransactionId       = Just (TransactionId "1DG71997KF688883E")-      }-    r = Receiver-      { _reAmount    = "1.00"-      , _reEmail     = "user@mail.com"-      , _reAccountId = "69D9D7KVA6WAN"-      }--parseDepositResp :: Assertion-parseDepositResp = expected `eqParsed` "tests/Local/json/parseDepositResp.json"-  where-    expected = PayResp-      { _prPayError      = Nothing-      , _prPayExecStatus = PeCreated-      , _prPayKey        = PayKey "AP-3NL080742J1818731"-      , _prPayInfos      = []-      }--parseLookupResp :: Assertion-parseLookupResp = expected `eqParsed` "tests/Local/json/parseLookupResp.json"-  where-    expected = PayResp-      { _prPayError      = Nothing-      , _prPayExecStatus = PeCompleted-      , _prPayKey        = PayKey "AP-5XY65045XE4097324"-      , _prPayInfos      = [p]-      }-    p = PayInfo-      { _piReceiver            = r-      , _piSenderTransactionId = Just (TransactionId "9U084775U2533540T")-      , _piTransactionStatus   = Just TsCompleted-      , _piTransactionId       = Just (TransactionId "0CL88103PF900230J")-      }-    r = Receiver-      { _reAmount    = "1.00"-      , _reEmail     = "user@mail.com"-      , _reAccountId = "69D9D7KVA6WAN"-      }--parseErrResp :: Assertion-parseErrResp = expected `eqParsed` "tests/Local/json/parseErrResp.json"-  where-    expected = AeErrCodes [560022]

@@ -2,21 +2,17 @@  module Main where -import           Control.Applicative import           Control.Monad-import           Data.Aeson import qualified Data.ByteString.Lazy           as B-import           Data.HashMap.Strict            as H-import           Data.Text                      (Text)+import           Test.Framework                 (Test, defaultMain, testGroup)+import           Test.Framework.Providers.HUnit (testCase)+import           Test.HUnit                     hiding (Test)++import           Import import           PayPal.Adaptive import qualified PayPal.Adaptive.Deposit        as DP-import           PayPal.Adaptive.Internal import qualified PayPal.Adaptive.Lookup         as LP import qualified PayPal.Adaptive.Withdrawal     as WD-import           Test.Framework                 (Test, defaultMain, testGroup)-import           Test.Framework.Providers.HUnit (testCase)-import           Test.HUnit                     hiding (Test)-import           Utils  main :: IO () main = defaultMain [integrationRemote]@@ -46,29 +42,17 @@       depositUserAddressDNE   ] --- | Currently the ID for all sandbox apps.-appId :: Text-appId = "APP-80W284485P519543T"+newtype TestSettings = TestSettings { _unTestSettings :: (Client, Text, Text) } -instance FromJSON Client where-  parseJSON = withObject "client credentials" $ \o ->-    Client appId                 <$>-    o .: "sandboxClientUid"      <*>-    pure Sandbox                 <*>-    o .: "sandboxClientPassword" <*>-    o .: "sandboxClientSig"      <*>-    o .: "sandboxAccountEmail"+instance FromJSON TestSettings where+  parseJSON = withObject "TestSettings" $ \o -> do+    client          <- o .: "client"+    userEmail       <- (.: "email_with_paypal_account") =<< o .: "other"+    nonSandboxEmail <- (.: "email_without_paypal_account") =<< o .: "other"+    return $ TestSettings (client,userEmail,nonSandboxEmail)  config :: IO (Client, Text, Text)-config = do-  b <- B.readFile "sandbox.json"-  client <- assertRight (eitherDecode b)-  Object o <- assertRight (eitherDecode b)-  String userEmail <- assertJust "sandboxUserEmail not found"-    $ H.lookup "sandboxUserEmail" o-  String notSandboxEmail <- assertJust "randomNonSandboxUserEmail not found"-    $ H.lookup "randomNonSandboxUserEmail" o-  return (client, userEmail, notSandboxEmail)+config = fmap _unTestSettings . assertRight . eitherDecode =<< B.readFile "sandbox.json"  incorrectEmailClient :: Text -> Client -> Client incorrectEmailClient badAccountEmail (Client a b c d e _) = Client a b c d e badAccountEmail@@ -91,47 +75,48 @@ correctWithdrawal :: Assertion correctWithdrawal = do   (client, userEmail, _) <- config-  wdResp <- assertRight =<< WD.req client (withdrawal userEmail)-  lpResp <- assertRight =<< LP.req client (LP.LookupPayKey $ _crPayKey wdResp)+  wdResp <- assertRight . checkComplete =<< fmap snd . assertRight =<< WD.request client (withdrawal userEmail)+  lpResp <- fmap snd . assertRight =<< LP.request client (LP.LookupPayKey $ _cpPayKey wdResp)   void $ assertRight (checkComplete lpResp)  withdrawalAccountAddressDNE :: Assertion withdrawalAccountAddressDNE = do   (client, userEmail, notSandboxEmail) <- config   let c = incorrectEmailClient notSandboxEmail client-  adaptiveErr <- assertLeft =<< WD.req c (withdrawal userEmail)-  assertEqual "send error due to a nonexistent account address" AeNoSuchEmail adaptiveErr+  adaptiveErr <- assertLeft =<< WD.request c (withdrawal userEmail)+  case adaptiveErr of+    AeErrorResponse _ (ErrorResponse [PayError code _]) ->+      assertEqual "send error due to a nonexistent account address" noSuchEmail code+    e -> assertFailure $ "withdrawalAccountAddressDNE got unexpected error " <> show e  withdrawalUserAddressDNE :: Assertion withdrawalUserAddressDNE = do   (client, _, notSandboxEmail) <- config-  payResp <- assertExpected =<< assertLeft =<< WD.req client (withdrawal notSandboxEmail)-  assertLookup =<< assertRight =<< LP.req client (LP.LookupPayKey $ _prPayKey payResp)+  payResp <- fmap snd . assertRight =<< WD.request client (withdrawal notSandboxEmail)+  assertExpected payResp+  assertLookup =<< fmap snd . assertRight =<< LP.request client (LP.LookupPayKey $ _prPayKey payResp)   where-    assertExpected :: AdaptiveErr -> IO PayResp-    assertExpected (AePending payResp) = do-      assertEqual-        "withdraw to nonexistent user addresses return no PayInfos"-        0 (length $ _prPayInfos payResp)-      return payResp-    assertExpected _ =-      assertFalse "send error due to a nonexistent user address didn't return AePending"-      >> fail "checkResp failed"+    assertExpected :: PayResponse -> IO ()+    assertExpected payResp = do+      void . assertLeft $ checkComplete payResp+      assertEqual "withdraw to nonexistent user addresses return no PayInfos"+                  0+                  (length $ _prPaymentInfos payResp) -    assertLookup :: PayResp -> Assertion+    assertLookup :: PayResponse -> Assertion     assertLookup a = do-      info <- assertRight $ do-        payExecStatusCompleted a-        errorFieldNothing a-        checkPayKey a-        getPayInfo a+      assertEqual "withdrawalAccountAddressDNE _prPayStatus" PeCompleted (_prPayStatus a)+      info <- assertRight (getPaymentInfo a)       assertEqual "pending withdrawal transaction status" Nothing (_piTransactionStatus info)  withdrawalNotEnoughFunds :: Assertion withdrawalNotEnoughFunds = do   (client, userEmail, _) <- config-  adaptiveErr <- assertLeft =<< WD.req client (largeWithdrawal userEmail)-  assertEqual "send error due to not enough funds" (AeErrCodes [520009]) adaptiveErr+  adaptiveErr <- assertLeft =<< WD.request client (largeWithdrawal userEmail)+  case adaptiveErr of+    AeErrorResponse _ (ErrorResponse [PayError code _]) ->+      assertEqual "send error due to not enough funds" (ErrorCode 520009) code+    e -> assertFailure $ "withdrawalAccountAddressDNE got unexpected error " <> show e   where     largeWithdrawal :: Text -> WD.Withdrawal     largeWithdrawal userAddr = WD.Withdrawal@@ -142,36 +127,33 @@ correctDepositBeginning :: Assertion correctDepositBeginning = do   (client, userEmail, _) <- config-  payKey <- assertRight =<< DP.req client (deposit userEmail)-  assertExpected =<< assertRight =<< LP.req client (LP.LookupPayKey payKey)+  payKey <- fmap (_prPayKey . snd) . assertRight =<< DP.request client (deposit userEmail)+  assertExpected =<< fmap snd . assertRight =<< LP.request client (LP.LookupPayKey payKey)   where-    assertExpected :: PayResp -> Assertion+    assertExpected :: PayResponse -> Assertion     assertExpected a = do-      info <- assertRight $ do-        payExecStatusCreated a-        errorFieldNothing a-        checkPayKey a-        getPayInfo a+      assertEqual "correctDepositBeginning _prPayStatus" PeCreated (_prPayStatus a)+      info <- assertRight (getPaymentInfo a)       assertEqual "pending deposit transaction status" Nothing (_piTransactionStatus info)  depositAccountAddressDNE :: Assertion depositAccountAddressDNE = do   (client, userEmail, notSandboxEmail) <- config   let c = incorrectEmailClient notSandboxEmail client-  payKey <- assertRight =<< DP.req c (deposit userEmail)-  assertExpected =<< assertRight =<< LP.req client (LP.LookupPayKey payKey)+  payKey <- fmap (_prPayKey . snd) . assertRight =<< DP.request c (deposit userEmail)+  assertExpected . snd =<< assertRight =<< LP.request client (LP.LookupPayKey payKey)   where-    assertExpected :: PayResp -> Assertion+    assertExpected :: PayResponse -> Assertion     assertExpected a = do-      info <- assertRight $ do-        payExecStatusCreated a-        errorFieldNothing a-        checkPayKey a-        getPayInfo a+      assertEqual "depositUserAddressDNE _prPayStatus" PeCreated (_prPayStatus a)+      info <- assertRight (getPaymentInfo a)       assertEqual "status for deposit where to address isn't an account" Nothing (_piTransactionStatus info)  depositUserAddressDNE :: Assertion depositUserAddressDNE = do   (client, _, notSandboxEmail) <- config-  adaptiveErr <- assertLeft =<< DP.req client (deposit notSandboxEmail)-  assertEqual "create error due to a nonexistent user address" AeNoSuchEmail adaptiveErr+  adaptiveErr <- assertLeft =<< DP.request client (deposit notSandboxEmail)+  case adaptiveErr of+    AeErrorResponse _ (ErrorResponse [PayError code _]) ->+      assertEqual "create error due to a nonexistent user address" noSuchEmail code+    e -> assertFailure $ "withdrawalAccountAddressDNE got unexpected error " <> show e

@@ -1,24 +0,0 @@-module Utils where--import Test.HUnit--assertFalse :: String -> IO ()-assertFalse s = assertFailure s >> fail "assertFalse"--assertJust :: String -> Maybe a -> IO a-assertJust s a =-  case a of-    Nothing -> assertFailure s >> fail "assertJust failed"-    Just b  -> return b--assertRight :: (Show a) => Either a b -> IO b-assertRight a =-  case a of-    Left e  -> assertFailure (show e) >> fail "assertRight failed"-    Right b -> return b--assertLeft :: (Show b) => Either a b -> IO a-assertLeft a =-  case a of-    Left e  -> return e-    Right b -> assertFailure (show b) >> fail "assertLeft failed"