paypal-adaptive-hoops (empty) → 0.5.0.0
raw patch · 9 files changed
+611/−0 lines, 9 filesdep +HUnitdep +QuickCheckdep +aesonsetup-changed
Dependencies added: HUnit, QuickCheck, aeson, base, bytestring, data-default, errors, http-client, http-types, lens, lens-aeson, paypal-adaptive-hoops, test-framework, test-framework-hunit, test-framework-quickcheck2, text, time, transformers, vector, wreq
Files
- Example.hs +29/−0
- MIT-LICENSE.txt +20/−0
- README.md +15/−0
- Setup.hs +2/−0
- paypal-adaptive-hoops.cabal +71/−0
- src/Web/PayPal/Adaptive.hs +22/−0
- src/Web/PayPal/Adaptive/Core.hs +435/−0
- src/Web/PayPal/Adaptive/Internal.hs +8/−0
- tests/Test.hs +9/−0
+ Example.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Data.Default (def)+import Web.PayPal.Adaptive++-- NOTE: This won't actually run without a real sandbox password, sig, and userId.+main :: IO ()+main = toPayPal client send >>= print++ where+ client :: PpClient+ client = PpClient+ { _clAppId = "APP-80W284485P519543T" -- Currently the ID for all sandbox apps.+ , _clEnv = PpSandbox+ , _clPassword = "some-gibberish"+ , _clSig = "long-string-of-gibberish"+ , _clUserId = "foo_api1.mail.com"+ }++ send :: SendPayment+ send = def+ { _spReceiverList = ReceiverList+ { _rlAmount = USD 100+ , _rlEmail = "user@mail.com"+ }+ , _spSenderEmail = "foo@mail.com"+ }
+ MIT-LICENSE.txt view
@@ -0,0 +1,20 @@+The MIT License (MIT)+Copyright (c) 2014 FanJam, Inc.++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,+DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR+OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE+OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,15 @@+# Intro++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.++PayPal has other APIs like the [PayPal REST API](https://developer.paypal.com/docs/api/), but the PayPal REST API doesn't support sending payments.++# PayPal Credentials++Getting production approval for the Adaptive Payments API takes some time. You should start the process well before you actually need to go into production. Detailed instructions for doing so are out of the scope of this project, but you can get started [here](https://developer.paypal.com/docs/classic/lifecycle/goingLive/).++# Status++Working.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ paypal-adaptive-hoops.cabal view
@@ -0,0 +1,71 @@+name: paypal-adaptive-hoops+version: 0.5.0.0+author: Ian Grant Jeffries+maintainer: ian@housejeffries.com+category: Web+synopsis: Client for a limited part of PayPal's Adaptive Payments API+homepage: https://github.com/fanjam/paypal-adaptive-hoops+build-type: Simple+extra-source-files: README.md+license: MIT+license-file: MIT-LICENSE.txt+cabal-version: >=1.10++library+ hs-source-dirs: src+ exposed-modules: Web.PayPal.Adaptive+ Web.PayPal.Adaptive.Internal+ other-modules: Web.PayPal.Adaptive.Core+ default-language: Haskell2010+ ghc-options: -Wall+ other-extensions: GADTs+ , OverloadedStrings+ , TemplateHaskell++ build-depends: aeson >= 0.8 && < 0.9+ , base >= 4.6 && < 5.0+ , bytestring >= 0.10 && < 0.11+ , data-default >= 0.5 && < 0.6+ , errors >= 1.4 && < 1.5+ , http-client >= 0.4.2 && < 0.5+ , http-types >= 0.8 && < 0.9+ , lens >= 4.6 && < 4.7+ , lens-aeson >= 1.0 && < 1.1+ , text >= 1.1 && < 1.3+ , time >= 1.4 && < 1.6+ , transformers >= 0.4 && < 0.5+ , vector >= 0.10.12 && < 0.11+ , wreq >= 0.3 && < 0.4++test-suite unit+ type: exitcode-stdio-1.0+ hs-source-dirs: tests+ main-is: Test.hs+ default-language: Haskell2010+ ghc-options: -Wall+ other-extensions: OverloadedStrings++ build-depends: aeson+ , base >=4.7 && <= 5.0+ , bytestring+ , data-default+ , HUnit+ , paypal-adaptive-hoops+ , QuickCheck+ , test-framework+ , test-framework-hunit+ , test-framework-quickcheck2++executable example+ main-is: Example.hs+ default-language: Haskell2010+ ghc-options: -Wall+ other-extensions: OverloadedStrings++ build-depends: base+ , data-default+ , paypal-adaptive-hoops++source-repository head+ type: git+ location: git://github.com/fanjam/paypal-adaptive-hoops.git
+ src/Web/PayPal/Adaptive.hs view
@@ -0,0 +1,22 @@+module Web.PayPal.Adaptive+ ( PpClient (..)+ , PpEnv (..)+ , AdaptiveAPI (..)+ , AdaptiveErr (..)+ , ReceiverList (..)+ , SendPayment (..)+ , CreatePayment (..)+ , LookupPayment (..)+ , PayResp (..)+ , PayExecStatus (..)+ , PayKey (..)+ , PayInfo (..)+ , Receiver (..)+ , TransactionId (..)+ , TransactionStatus(..)+ , Money (..)+ , m2Currency+ , m2PayPal+ ) where++import Web.PayPal.Adaptive.Core
+ src/Web/PayPal/Adaptive/Core.hs view
@@ -0,0 +1,435 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# 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.Read+import Data.Text.Encoding+import Data.Traversable+import qualified Data.Vector as V+import Network.HTTP.Client (HttpException (NoResponseDataReceived))+import Network.Wreq++--------------------------------------------------+-- Client+--------------------------------------------------++data PpClient = PpClient+ { _clAppId :: Text+ , _clEnv :: PpEnv+ , _clPassword :: Text+ , _clSig :: Text+ , _clUserId :: Text+ } deriving (Eq, Show)++data PpEnv = PpSandbox | PpProduction deriving (Eq, Show, Read)++--------------------------------------------------+-- API class+--------------------------------------------------++class AdaptiveAPI a where+ toPayPal :: PpClient -> a -> IO (Either AdaptiveErr PayResp)++-- | Exported by Web.PayPal.Adaptive.Internal+ppPost :: (ToJSON a) => PpClient -> 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+ PpSandbox -> "https://svcs.sandbox.paypal.com/AdaptivePayments/"+ PpProduction -> "https://svcs.paypal.com/AdaptivePayments/"++ handler :: HttpException -> IO (Either AdaptiveErr (Response ByteString))+ handler NoResponseDataReceived = return (Left AeNoResponse)+ 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 eitherDecode b of+ Right (AeErrCodes cs) -> Left $ AeErrCodes cs+ _ -> Left $ AeDecodeFailed b (T.pack e)++--------------------------------------------------+-- 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+ = AeNoResponse+ | AeConnectionErr Text+ | AeDecodeFailed ByteString Text+ | 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++--------------------------------------------------+-- Common payload things+--------------------------------------------------++data ReceiverList = ReceiverList+ { _rlAmount :: Money+ , _rlEmail :: Text+ } deriving (Eq, Show)++instance ToJSON ReceiverList where+ toJSON (ReceiverList a e) =+ object [ "receiver" .= [ object ["amount" .= m2PayPal a, "email" .= e] ] ]++-- | Exported by Web.PayPal.Adaptive.Internal+--+-- "en_US" is hardcoded because it's the only supported error language.+requestEnvelope :: Value+requestEnvelope = object ["errorLanguage" .= ("en_US" :: Text)]++--------------------------------------------------+-- Send Payment+--------------------------------------------------++-- | Send a single payment from your account.+--+--+-- "Pay" operation docs:+-- <https://developer.paypal.com/docs/classic/api/adaptive-payments/Pay_API_Operation/>+--+-- This is a "Simple Payment" which means there's a single sender+-- and receiver (same as CreatePayment).+--+-- It uses the "Implicit" payment approval type, meaning the application+-- making the API call must also be the sender of the payment.+data SendPayment = SendPayment+ { _spReceiverList :: ReceiverList+ , _spReturnUrl :: Text+ , _spCancelUrl :: Text+ , _spSenderEmail :: Text+ } deriving (Eq, Show)++instance Default SendPayment where+ def = SendPayment+ { _spReceiverList = ReceiverList mempty mempty+ , _spReturnUrl = "https://example.com/"+ , _spCancelUrl = "https://example.com/cancel"+ , _spSenderEmail = mempty+ }++instance ToJSON SendPayment where+ toJSON p = object+ [ "actionType" .= ("PAY" :: Text)+ , "currencyCode" .= (m2Currency . _rlAmount . _spReceiverList) p+ , "receiverList" .= _spReceiverList p+ , "returnUrl" .= _spReturnUrl p+ , "cancelUrl" .= _spCancelUrl p+ , "requestEnvelope" .= requestEnvelope+ , "senderEmail" .= _spSenderEmail p+ ]++instance AdaptiveAPI SendPayment where+ toPayPal c p = (>>= ppDecode >=> ensureSucceeded) <$> ppPost c "Pay" p+ where+ ensureSucceeded :: PayResp -> Either AdaptiveErr PayResp+ ensureSucceeded a =+ case _prPayExecStatus a of+ PeProcessing -> Left $ AePending a+ PePending -> Left $ AePending a+ PeError -> Left $ AeRefused a+ PeCompleted ->+ let infos = _prPayInfo a+ in if length infos /= 1+ then Left $ AeShouldNotHappen a "sendPayment expects one PayInfo in reponse"+ else case _piTransactionStatus (head infos) of+ Just TsCompleted -> Right a+ Just TsPending -> Left $ AePending a+ Just TsProcessing -> Left $ AePending a+ Just TsDenied -> Left $ AeRefused a+ Just TsFailed -> Left $ AeRefused a+ _ -> Left $ AeShouldNotHappen a "got unsupported TransactionStatus"+ _ -> Left $ AeShouldNotHappen a "got unsupported PayExecStatus"++--------------------------------------------------+-- Create Payment+--------------------------------------------------++-- | Start the process of someone paying you. You have to redirect the payer's+-- browser to PayPal to finish it.+--+--+-- "Pay" operation docs:+-- <https://developer.paypal.com/docs/classic/api/adaptive-payments/Pay_API_Operation/>+--+-- This is a "Simple Payment" which means there's a single sender+-- and receiver (same as SendPayment).+--+-- It uses the "Explicit" payment approval type, meaning the payer must go to+-- PayPal in their browser to approve the payment. Here's an example payment+-- approval URL with a PayKey of "foo":+--+-- https://www.paypal.com/cgi-bin/webscr?cmd=_ap-payment&paykey=foo+data CreatePayment = CreatePayment+ { _cpReceiverList :: ReceiverList+ , _cpReturnUrl :: Text+ , _cpCancelUrl :: Text+ , _cpSenderEmail :: Text+ } deriving (Eq, Show)++instance Default CreatePayment where+ def = CreatePayment+ { _cpReceiverList = ReceiverList mempty mempty+ , _cpReturnUrl = "https://example.com/"+ , _cpCancelUrl = "https://example.com/cancel"+ , _cpSenderEmail = mempty+ }++instance ToJSON CreatePayment where+ toJSON p = object+ [ "actionType" .= ("PAY" :: Text)+ , "currencyCode" .= (m2Currency . _rlAmount . _cpReceiverList) p+ , "receiverList" .= _cpReceiverList p+ , "returnUrl" .= _cpReturnUrl p+ , "cancelUrl" .= _cpCancelUrl p+ , "requestEnvelope" .= requestEnvelope+ , "senderEmail" .= _cpSenderEmail p+ ]++instance AdaptiveAPI CreatePayment where+ toPayPal c p = (>>= ppDecode >=> ensureSucceeded) <$> ppPost c "Pay" p+ where+ ensureSucceeded :: PayResp -> Either AdaptiveErr PayResp+ ensureSucceeded a =+ case _prPayExecStatus a of+ PeCreated -> Right a+ PeProcessing -> Left $ AePending a+ PePending -> Left $ AePending a+ PeError -> Left $ AeRefused a+ _ -> Left $ AeShouldNotHappen a "got unsupported PayExecStatus"++--------------------------------------------------+-- Lookup Payment+--------------------------------------------------++-- | Lookup 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 -- Nothing for all Right responses+ , _prPayExecStatus :: PayExecStatus+ , _prPayKey :: PayKey+ , _prPayInfo :: [PayInfo] -- Empty in CreatePayment responses+ } 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 is "paymentExecStatus" in responses to sendPayment and createPayment.+-- It's called "status" in responses to lookupPayment.+data PayExecStatus+ = PeCreated+ | PeCompleted+ | PeIncomplete+ | PeError+ | PeReversalError+ | PeProcessing+ | PePending+ deriving (Eq, Show, Read)++-- | Defaults to expiring 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++-- | All the API calls we support return a PayInfo along with three Justs, with two+-- exceptions.+--+-- 1. toPayPal CreatePayment returns no PayInfo at all.+--+-- 2. toPayPal LookupPayment on such a payment does return a PayInfo, but with+-- three Nothings.+--+-- NOTE: _piSenderTransactionId and _piTransactionStatus will be different, but+-- both 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+-- Monad 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 ''PpClient)+$(makeLenses ''CreatePayment)+$(makePrisms ''PpEnv)+$(makePrisms ''PayExecStatus)+$(makeLenses ''PayInfo)+$(makeLenses ''PayResp)+$(makeLenses ''Receiver)+$(makeLenses ''ReceiverList)+$(makeLenses ''SendPayment)+$(makePrisms ''TransactionId)+$(makePrisms ''TransactionStatus)
+ src/Web/PayPal/Adaptive/Internal.hs view
@@ -0,0 +1,8 @@+module Web.PayPal.Adaptive.Internal+ ( parseErrId+ , ppDecode+ , ppPost+ , requestEnvelope+ ) where++import Web.PayPal.Adaptive.Core
+ tests/Test.hs view
@@ -0,0 +1,9 @@+import Test.Framework (Test, defaultMain)+import Unit.Money+import Unit.Parser++tests :: [Test]+tests = [unitMoney, unitParser]++main :: IO ()+main = defaultMain tests