packages feed

paypal-rest-client (empty) → 0.1.0

raw patch · 14 files changed

+1292/−0 lines, 14 filesdep +Decimaldep +aesondep +basesetup-changed

Dependencies added: Decimal, aeson, base, bytestring, containers, country-codes, http-client, http-types, lens, safe, text, time, wreq

Files

+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2016 Braden Walters++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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ paypal-rest-client.cabal view
@@ -0,0 +1,55 @@+name: paypal-rest-client+version: 0.1.0+synopsis: A client to connect to PayPal's REST API (v1)+license: MIT+license-file: LICENSE+homepage: https://github.com/meoblast001/paypal-rest-client+author: Braden Walters+maintainer: vc@braden-walters.info+category: Network+stability: experimental+build-type: Simple+cabal-version: >= 1.10+Tested-With: GHC == 7.8.4, GHC == 7.10.2, GHC == 8.0.1++description:+  Library to connect with and use PayPal's+  <https://developer.paypal.com/docs/api/ REST API v1>. For documentation, see+  the <https://github.com/meoblast001/paypal-rest-client/blob/master/README.md README>.+  During releases under 1.0.0, please use exact version numbers as bug fixes may+  require breaking changes while this library is unstable.++library+  exposed-modules:+      Network.Payments.PayPal+    , Network.Payments.PayPal.Environment+    , Network.Payments.PayPal.Auth+    , Network.Payments.PayPal.Payments+    , Network.Payments.PayPal.Types.Address+    , Network.Payments.PayPal.Types.Currency+    , Network.Payments.PayPal.Types.FundingInstrument+    , Network.Payments.PayPal.Types.Hateoas+    , Network.Payments.PayPal.Types.Paging+    , Network.Payments.PayPal.Types.Payer+    , Network.Payments.PayPal.Types.Transaction+  build-depends:+      base >= 4 && < 5+    , bytestring >= 0.10.0+    , containers >= 0.1.0+    , safe >= 0.2+    , wreq >= 0.4.0 && < 0.5.0+    , http-client >= 0.4.6 && < 0.5.0+    , http-types >= 0.8+    , lens >= 4.5+    , text >= 1.2+    , aeson >= 0.10+    , Decimal >= 0.3.1 && < 0.5+    , country-codes >= 0.1.3+    , time >= 1.5 && < 1.7+  hs-source-dirs: src+  default-language: Haskell2010+  ghc-options: -Wall++source-repository head+  type: git+  location: https://github.com/meoblast001/paypal-rest-client.git
+ src/Network/Payments/PayPal.hs view
@@ -0,0 +1,151 @@+-- |+-- Module: Network.Payments.PayPal+-- Copyright: (C) 2016 Braden Walters+-- License: MIT (see LICENSE file)+-- Maintainer: Braden Walters <vc@braden-walters.info>+-- Stability: experimental+-- Portability: ghc++{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE OverloadedStrings #-}++module Network.Payments.PayPal+( UseHttpMethod(..)+, PayPalOperations(..)+, JSONText+, ErrorMessage+, PayPalError(..)+, execPayPal+, execPayPalOpers+) where++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative+#endif+import Control.Exception+import Control.Lens+import Data.Aeson+import qualified Data.ByteString.Char8 as BS8+import qualified Data.ByteString.Lazy as LBS+import Data.Time.Clock+import qualified Network.HTTP.Client as HTTPClient+import Network.Payments.PayPal.Auth+import Network.Payments.PayPal.Environment+import Network.Wreq++-- |HTTP method to use in the request (GET/POST).+data UseHttpMethod = UseHttpGet | UseHttpPost Payload | UseHttpPatch Payload++-- Instance of show that ignores the payload.+instance Show UseHttpMethod where+  show UseHttpGet = "HttpGet"+  show (UseHttpPost _) = "HttpPost"+  show (UseHttpPatch _) = "HttpPatch"++-- |A monad composing multiple PayPal operations which are to be performed.+-- The result can be executed using the execPayPal function.+data PayPalOperations :: * -> * where+  PPOPure :: a -> PayPalOperations a+  PPOBind :: PayPalOperations a -> (a -> PayPalOperations b) ->+             PayPalOperations b+  PayPalOperation :: FromJSON a =>+                     { ppoMethod :: UseHttpMethod+                     , ppoUrl :: String+                     , ppoOptions :: Options+                     } -> PayPalOperations a++instance Functor PayPalOperations where+  fmap f m = PPOBind m (PPOPure . f)++instance Applicative PayPalOperations where+  pure x = PPOPure x+  mf <*> mx = PPOBind mf (\f -> PPOBind mx (\x -> PPOPure (f x)))++instance Monad PayPalOperations where+  m >>= f = PPOBind m f++type JSONText = LBS.ByteString+type ErrorMessage = String++data PayPalError = HttpStatusError Int |+                   ResponseParseError ErrorMessage JSONText |+                   HttpError HTTPClient.HttpException | OtherError String+                   deriving (Show)++-- |Authenticate with PayPal and then interact with the service.+execPayPal :: FromJSON a => EnvironmentUrl -> ClientID -> Secret ->+              PayPalOperations a -> IO (Either PayPalError a)+execPayPal envUrl username password operations = do+  accessTokenOrErr <- fetchAccessTokenWithExpiration envUrl username password+  case accessTokenOrErr of+    -- Failure to fetch access token.+    Left (AccessTokenHttpError httpErr) -> return $ Left $ HttpError httpErr+    Left (AccessTokenStatusError statusCode') ->+      return $ Left $ HttpStatusError statusCode'+    Left (AccessTokenParseError errMsg text) ->+      return $ Left $ ResponseParseError errMsg text+    -- Successfully acquired, execute operations.+    Right accTokenWithEx -> do+      result <- execPayPalOpers envUrl username password accTokenWithEx+                                operations+      case result of+        Left err -> return $ Left err+        Right (result', _) -> return $ Right result'++-- |Executes a PayPalOperations monad as IO. Because the access token can+-- expire and needs to be renewed, this function returns the desired value and+-- the most current access token when successful.+execPayPalOpers :: EnvironmentUrl -> ClientID -> Secret ->+                   AccessTokenWithExpiration -> PayPalOperations a ->+                   IO (Either PayPalError (a, AccessTokenWithExpiration))+execPayPalOpers _ _ _ accTokenWithEx (PPOPure a) =+  return $ Right (a, accTokenWithEx)+execPayPalOpers envUrl' username password accTokenWithEx (PPOBind m f) = do+  treeLeftResult <- execPayPalOpers envUrl' username password accTokenWithEx m+  either (return . Left)+         (\(res, newAccTk) -> execPayPalOpers envUrl' username password+                                              newAccTk $ f res)+         treeLeftResult+execPayPalOpers env@(EnvironmentUrl baseUrl) username password+          accTokenWithEx@(accessToken, expiration)+          (PayPalOperation method url preOptions) = do+  -- Check the validity of the access token and renew it if it expired.+  curTime <- getCurrentTime+  latestAccTkOrErr <- if diffUTCTime expiration curTime <= 0+                      then fetchAccessTokenWithExpiration env username password+                      else return $ Right accTokenWithEx+  case latestAccTkOrErr of+    -- Failure to refresh access token.+    Left (AccessTokenHttpError httpErr) -> return $ Left $ HttpError httpErr+    Left (AccessTokenStatusError statusCode') ->+      return $ Left $ HttpStatusError statusCode'+    Left (AccessTokenParseError errMsg text) ->+      return $ Left $ ResponseParseError errMsg text+    -- Either existing access token is still valid or new access token was+    -- retrieved.+    Right latestAccTk -> do+      -- Perform the request.+      let accToken = aToken accessToken+          opts = preOptions &+                 header "Authorization" .~ [BS8.pack ("Bearer " ++ accToken)]+      responseOrErr <- try $ case method of+        UseHttpGet -> getWith opts (baseUrl ++ url)+        UseHttpPost payload -> postWith opts (baseUrl ++ url) payload+        UseHttpPatch payload ->+          customPayloadMethodWith "PATCH" opts (baseUrl ++ url) payload+      case responseOrErr of+        -- HTTP request failed.+        Left err -> return $ Left $ HttpError err+        -- HTTP request successful.+        Right response -> do+          let statusCode' = response ^. responseStatus . statusCode+          if statusCode' == 200 then+            let responseText = response ^. responseBody+            in case eitherDecode responseText of+              Left errMsg ->+                return $ Left $ ResponseParseError errMsg responseText+              Right result -> return $ Right (result, latestAccTk)+          else+            return $ Left $ HttpStatusError statusCode'
+ src/Network/Payments/PayPal/Auth.hs view
@@ -0,0 +1,128 @@+-- |+-- Module: Network.Payments.PayPal.Auth+-- Copyright: (C) 2016 Braden Walters+-- License: MIT (see LICENSE file)+-- Maintainer: Braden Walters <vc@braden-walters.info>+-- Stability: experimental+-- Portability: ghc++{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++module Network.Payments.PayPal.Auth+( ClientID+, Secret+, Seconds+, AccessToken(..)+, AccessTokenWithExpiration+, AccessTokenError(..)+, AccessTokenResult+, fetchAccessToken+, fetchAccessTokenWithExpiration+, safeExpirationTime+) where++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative+#endif+import Control.Exception+import Control.Lens+import Control.Monad+import Data.Aeson+import qualified Data.ByteString.Char8 as BS8+import qualified Data.ByteString.Lazy as LBS+import qualified Data.Text as T+import Data.Time.Clock+import qualified Network.HTTP.Client as HTTP+import Network.Wreq+import qualified Network.Wreq.Types as WTypes+import Network.Payments.PayPal.Environment++-- |PayPal client ID with which to execute actions.+type ClientID = String++-- |PayPal secret of user with which to execute actions.+type Secret = String++-- |Number representing seconds of time.+type Seconds = Integer++-- |Access token returned from OAuth.+data AccessToken = AccessToken+  { aTokenScope :: [String]+  , aToken :: String+  , aTokenType  :: String+  , aTokenAppId :: String+  , aTokenExpires :: Seconds+  } deriving (Eq, Show)++-- |An access token from OAuth together with its UTC expiration time.+type AccessTokenWithExpiration = (AccessToken, UTCTime)++-- |Error while fetching access token.+data AccessTokenError = AccessTokenHttpError HTTP.HttpException |+                        AccessTokenStatusError Int |+                        -- Contains error message and JSON text.+                        AccessTokenParseError String LBS.ByteString++-- |Either an access token or the error encountered while fetching it.+type AccessTokenResult = Either AccessTokenError AccessToken++-- |Either an access token with an expiration or the error encountered while+-- fetching it+type AccessTokenWithExpirationResult =+  Either AccessTokenError AccessTokenWithExpiration++instance FromJSON AccessToken where+  parseJSON (Object obj) =+    AccessToken <$>+    (map T.unpack <$> T.split (== ' ') <$> (obj .: "scope")) <*>+    obj .: "access_token" <*>+    obj .: "token_type" <*>+    obj .: "app_id" <*>+    obj .: "expires_in"+  parseJSON _ = mzero++-- |Use a PayPal environment and login credentials to get an OAuth access token.+fetchAccessToken :: EnvironmentUrl -> ClientID -> Secret -> IO AccessTokenResult+fetchAccessToken (EnvironmentUrl url) username password = do+  let usernameBS = BS8.pack username+      passwordBS = BS8.pack password+      fullUrl = url ++ "/v1/oauth2/token"+      options' = defaults & header "Accept" .~ ["application/json"] &+                            auth ?~ basicAuth usernameBS passwordBS+      contentType = "application/x-www-form-urlencoded"+      content = "grant_type=client_credentials"+      payload = WTypes.Raw contentType $ HTTP.RequestBodyBS content+  responseOrErr <- (try $ postWith options' fullUrl payload) ::+                   IO (Either HTTP.HttpException (Response LBS.ByteString))+  case responseOrErr of+    Left err -> return $ Left $ AccessTokenHttpError err+    Right response ->+      let statusCode' = response ^. responseStatus . statusCode+      in if statusCode' == 200 then+        let responseText = response ^. responseBody+        in return $ case eitherDecode responseText of+             Left errMsg -> Left $ AccessTokenParseError errMsg responseText+             Right result -> Right result+      else+        return $ Left $ AccessTokenStatusError statusCode'++-- |Use a PayPal environment and login credentials to get an OAuth access token+-- with an expiration time.+fetchAccessTokenWithExpiration :: EnvironmentUrl -> ClientID -> Secret ->+                                  IO AccessTokenWithExpirationResult+fetchAccessTokenWithExpiration environment username password= do+  currentTime <- getCurrentTime+  accessTokenOrErr <- fetchAccessToken environment username password+  let getExpire accToken = (accToken, safeExpirationTime currentTime accToken)+  return $ either Left (Right . getExpire) accessTokenOrErr++-- |Time at which the token should be considered expired. This is a few seconds+-- before the time that PayPal gives us. Parameters are the time at which the+-- access token was retrieved and the access token.+safeExpirationTime :: UTCTime -> AccessToken -> UTCTime+safeExpirationTime currentTime token =+  let safetyBuffer = 10 -- Seconds.+      seconds = aTokenExpires token - safetyBuffer+  in addUTCTime (fromIntegral seconds) currentTime
+ src/Network/Payments/PayPal/Environment.hs view
@@ -0,0 +1,24 @@+-- |+-- Module: Network.Payments.PayPal.Auth+-- Copyright: (C) 2016 Braden Walters+-- License: MIT (see LICENSE file)+-- Maintainer: Braden Walters <vc@braden-walters.info>+-- Stability: experimental+-- Portability: ghc++module Network.Payments.PayPal.Environment+( EnvironmentUrl(..)+, sandboxUrl+, liveUrl+) where++-- |URL of a PayPal environment.+newtype EnvironmentUrl = EnvironmentUrl String deriving (Eq, Show)++-- |URL to sandbox environment.+sandboxUrl :: EnvironmentUrl+sandboxUrl = EnvironmentUrl "https://api.sandbox.paypal.com"++-- |URL to live environment.+liveUrl :: EnvironmentUrl+liveUrl = EnvironmentUrl "https://api.paypal.com"
+ src/Network/Payments/PayPal/Payments.hs view
@@ -0,0 +1,294 @@+-- |+-- Module: Network.Payments.PayPal.Payments+-- Copyright: (C) 2016 Braden Walters+-- License: MIT (see LICENSE file)+-- Maintainer: Braden Walters <vc@braden-walters.info>+-- Stability: experimental+-- Portability: ghc++{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++module Network.Payments.PayPal.Payments+( URL+, PaymentID+, Intent(..)+, RedirectUrls(..)+, ReturnLinkParams(..)+, CreateRequest(..)+, CreateResponse(..)+, ExecuteRequest(..)+, ExecuteResponse(..)+, FindResponse(..)+, ListResponse(..)+, createPayment+, approvalUrlFromCreate+, executePayment+, findPaymentById+, listPayments+, returnLinkParams+) where++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative+#endif+import Control.Monad+import Data.Aeson+import Data.Aeson.Types+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS8+import qualified Data.Map as M+import Data.Maybe+#if __GLASGOW_HASKELL__ < 710+import Data.Monoid+#endif+import Data.Time.Clock+import Data.Time.Format+import qualified Network.HTTP.Client as HTTP+import Network.Payments.PayPal+import Network.Payments.PayPal.Types.Hateoas+import Network.Payments.PayPal.Types.Paging+import Network.Payments.PayPal.Types.Payer+import Network.Payments.PayPal.Types.Transaction+import Network.Wreq+import qualified Network.Wreq.Types as WTypes++-- A string representing a URL.+type URL = String++-- The ID of a payment provided by PayPal.+type PaymentID = String++-- |Payment intent.+data Intent = SaleIntent | AuthoriseIntent | OrderIntent+  deriving (Eq, Read, Show)++instance ToJSON Intent where+  toJSON SaleIntent = "sale"+  toJSON AuthoriseIntent = "authorize"+  toJSON OrderIntent = "order"++instance FromJSON Intent where+  parseJSON (String "sale") = return SaleIntent+  parseJSON (String "authorize") = return AuthoriseIntent+  parseJSON (String "order") = return OrderIntent+  parseJSON _ = mzero++data RedirectUrls = RedirectUrls+  { redirUrlReturn :: URL+  , redirUrlCancel :: URL+  } deriving (Eq, Show)++instance ToJSON RedirectUrls where+  toJSON urls =+    object ["return_url" .= redirUrlReturn urls,+            "cancel_url" .= redirUrlCancel urls]++instance FromJSON RedirectUrls where+  parseJSON (Object obj) =+    RedirectUrls <$>+    obj .: "return_url" <*>+    obj .: "cancel_url"+  parseJSON _ = mzero++data ReturnLinkParams = ReturnLinkParams+  { retLinkParamPayId :: PaymentID+  , retLinkParamToken :: String+  , retLinkParamPayerId :: String+  } deriving (Eq, Show)++-- |Current status of the PayPal payment.+data PaymentState = PayStateCreated | PayStateApproved | PayStateFailed |+                    PayStateCancelled | PayStateExpired | PayStatePending+                    deriving (Eq, Read, Show)++instance FromJSON PaymentState where+  parseJSON (String "created") = return PayStateCreated+  parseJSON (String "approved") = return PayStateApproved+  parseJSON (String "failed") = return PayStateFailed+  parseJSON (String "canceled") = return PayStateCancelled+  parseJSON (String "expired") = return PayStateExpired+  parseJSON (String "pending") = return PayStatePending+  parseJSON _ = mzero++-- |Contains data sent to PayPal to create a payment.+data CreateRequest = CreateRequest+  { createReqIntent :: Intent+  , createReqPayer :: Payer+  , createReqTransactions :: [Transaction]+  , createReqRedirectUrls :: Maybe RedirectUrls+  } deriving (Eq, Show)++instance ToJSON CreateRequest where+  toJSON req =+    object (["intent" .= createReqIntent req,+             "payer" .= createReqPayer req,+             "transactions" .= createReqTransactions req] +++            maybeToList (("redirect_urls" .=) <$> createReqRedirectUrls req))++-- |Contains a parsed response from PayPal after making a create payment+-- request.+data CreateResponse = CreateResponse+  { createResIntent :: Intent+  , createResPayer :: Payer+  , createResTransactions :: [Transaction]+  , createResRedirectUrls :: Maybe RedirectUrls+  , createResPayId :: PaymentID+  , createResCreateTime :: UTCTime+  , createResPayState :: PaymentState+  , createResUpdateTime :: Maybe UTCTime+  , createResHateoasLinks :: [HateoasLink]+  } deriving (Eq, Show)++instance FromJSON CreateResponse where+  parseJSON (Object obj) =+    CreateResponse <$>+    obj .: "intent" <*>+    obj .: "payer" <*>+    obj .: "transactions" <*>+    obj .:? "redirect_urls" <*>+    obj .: "id" <*>+    (obj .: "create_time" >>= parseTimeIso8106) <*>+    obj .: "state" <*>+    (obj .:? "update_time" >>=+     maybe (return Nothing) (\str -> Just <$> parseTimeIso8106 str)) <*>+    obj .: "links"+  parseJSON _ = mzero++-- |Executing a payment has a special transaction object which only contains the+-- amount.+data ExecuteTransaction = ExecuteTransaction+  { executeTransactionAmount :: Amount+  } deriving (Eq, Show)++instance ToJSON ExecuteTransaction where+  toJSON trans = object ["amount" .= executeTransactionAmount trans]++-- |Request to execute a payment.+data ExecuteRequest = ExecuteRequest+  { executeReqPayerId :: String+  , executeReqTransactions :: [ExecuteTransaction]+  } deriving (Eq, Show)++instance ToJSON ExecuteRequest where+  toJSON req =+    let transactions = if length (executeReqTransactions req) > 0+          then ["transactions" .= executeReqTransactions req]+          else []+    in object (["payer_id" .= executeReqPayerId req] ++ transactions)++-- |Response from an execute payment request.+data ExecuteResponse = ExecuteResponse+  { executeResIntent :: Intent+  , executeResPayer :: Payer+  , executeResTransactions :: [Transaction]+  , executeResHateoasLinks :: [HateoasLink]+  } deriving (Eq, Show)++instance FromJSON ExecuteResponse where+  parseJSON (Object obj) =+    ExecuteResponse <$>+    obj .: "intent" <*>+    obj .: "payer" <*>+    obj .: "transactions" <*>+    obj .: "links"+  parseJSON _ = mzero++-- |Contains a parsed response from a find payment request.+data FindResponse = FindResponse+  { findResIntent :: Intent+  , findResPayer :: Payer+  , findResTransactions :: [Transaction]+  , findResRedirectUrls :: Maybe RedirectUrls+  , findResPayId :: PaymentID+  , findResCreateTime :: UTCTime+  , findResPayState :: PaymentState+  , findResUpdateTime :: Maybe UTCTime+  } deriving (Eq, Show)++instance FromJSON FindResponse where+  parseJSON (Object obj) =+    FindResponse <$>+    obj .: "intent" <*>+    obj .: "payer" <*>+    obj .: "transactions" <*>+    obj .:? "redirect_urls" <*>+    obj .: "id" <*>+    (obj .: "create_time" >>= parseTimeIso8106) <*>+    obj .: "state" <*>+    (obj .:? "update_time" >>= maybe (return Nothing)+                                     (\str -> Just <$> parseTimeIso8106 str))+  parseJSON _ = mzero++-- Response to a payment list request.+data ListResponse = ListResponse+  { listResPayments :: [CreateResponse]+  , listResCount :: Integer+  , listResNextId :: Maybe PaymentID+  } deriving (Eq, Show)++instance FromJSON ListResponse where+  parseJSON (Object obj) =+    ListResponse <$>+    (fromMaybe [] <$> obj .:? "payments") <*>+    obj .: "count" <*>+    obj .:? "next_id"+  parseJSON _ = mzero++-- |Creates a new payment using payment data.+createPayment :: CreateRequest -> PayPalOperations CreateResponse+createPayment request =+  let url = "/v1/payments/payment"+      contentType = "application/json"+      content = encode request+      payload = WTypes.Raw contentType $ HTTP.RequestBodyLBS content+  in PayPalOperation (UseHttpPost payload) url defaults++-- |Extracts an approval URL, if there is one, from a create response+approvalUrlFromCreate :: CreateResponse -> Maybe URL+approvalUrlFromCreate response =+  let criteriaFunction hateoas =+        hateoasRel hateoas == "approval_url" &&+        hateoasMethod hateoas == HateoasRedirect+      maybeHateoas =+        listToMaybe $ filter criteriaFunction $ createResHateoasLinks response+  in hateoasHref <$> maybeHateoas++-- |Execute (or complete) a payment that has been approved by the payer.+executePayment :: PaymentID -> ExecuteRequest ->+                  PayPalOperations ExecuteResponse+executePayment id' request =+  let url = "/v1/payments/payment/" ++ id' ++ "/execute"+      contentType = "application/json"+      content = encode request+      payload = WTypes.Raw contentType $ HTTP.RequestBodyLBS content+  in PayPalOperation (UseHttpPost payload) url defaults++-- |Looks up a payment by ID.+findPaymentById :: PaymentID -> PayPalOperations FindResponse+findPaymentById id' =+  let url = "/v1/payments/payment/" ++ id'+  in PayPalOperation UseHttpGet url defaults++-- |Lists payments, possibly with paging.+listPayments :: Maybe PagingRequest -> PayPalOperations ListResponse+listPayments pagingRequest =+  let url = "/v1/payments/payment/" +++            (maybe mempty (\req -> "?" ++ pagingReqToQuery req) pagingRequest)+  in PayPalOperation UseHttpGet url defaults++-- |Use this function to parse GET parameters passed from PayPal to the return+-- URL. Takes a map of query parameters (name to value) and returns a structure+-- containing these parameters if possible. Otherwise PayPal didn't give you+-- required data.+returnLinkParams :: M.Map BS.ByteString BS.ByteString -> Maybe ReturnLinkParams+returnLinkParams query = do+  paymentId <- BS8.unpack <$> M.lookup "paymentId" query+  token <- BS8.unpack <$> M.lookup "token" query+  payerId <- BS8.unpack <$> M.lookup "PayerID" query+  return $ ReturnLinkParams paymentId token payerId++-- Parses a time in ISO 8106 format to a UTCTime.+parseTimeIso8106 :: String -> Parser UTCTime+parseTimeIso8106 str =+  parseTimeM True defaultTimeLocale (iso8601DateFormat $ Just "%H:%M:%SZ") str
+ src/Network/Payments/PayPal/Types/Address.hs view
@@ -0,0 +1,113 @@+-- |+-- Module: Network.Payments.PayPal.Types.Address+-- Copyright: (C) 2016 Braden Walters+-- License: MIT (see LICENSE file)+-- Maintainer: Braden Walters <vc@braden-walters.info>+-- Stability: experimental+-- Portability: ghc++{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++module Network.Payments.PayPal.Types.Address+( Address(..)+, ShippingAddressType(..)+, ShippingAddress(..)+) where++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative+#endif+import Control.Monad+import Data.Aeson+import Data.CountryCodes+import Data.Maybe++-- |Billing address of the payer.+data Address = Address+  { addressLine1 :: String+  , addressLine2 :: Maybe String+  , addressCity :: String+  , addressCountryCode :: CountryCode+  , addressPostalCode :: Maybe String+  , addressState :: Maybe String+  , addressPhone :: String+  } deriving (Eq, Show)++instance ToJSON Address where+  toJSON addr =+    object (["line1" .= addressLine1 addr,+             "city" .= addressCity addr,+             "country_code" .= toText (addressCountryCode addr),+             "phone" .= addressPhone addr] +++            maybeToList (("line2" .=) <$> addressLine2 addr) +++            maybeToList (("postal_code" .=) <$> addressPostalCode addr) +++            maybeToList (("state" .=) <$> addressState addr))++instance FromJSON Address where+  parseJSON (Object obj) =+    Address <$>+    obj .: "line1" <*>+    obj .:? "line2" <*>+    obj .: "city" <*>+    (fmap fromMText (obj .: "country_code") >>= maybe mzero return) <*>+    obj .:? "postal_code" <*>+    obj .:? "state" <*>+    obj .: "phone"+  parseJSON _ = mzero++-- |The type of the address.+data ShippingAddressType =+  ShipAddrResidential | ShipAddrBusiness | ShipAddrMailbox+  deriving (Eq, Read, Show)++instance ToJSON ShippingAddressType where+  toJSON ShipAddrResidential = "residential"+  toJSON ShipAddrBusiness = "business"+  toJSON ShipAddrMailbox = "mailbox"++instance FromJSON ShippingAddressType where+  parseJSON (String "residential") = return ShipAddrResidential+  parseJSON (String "business") = return ShipAddrBusiness+  parseJSON (String "mailbox") = return ShipAddrMailbox+  parseJSON _ = mzero++-- |The payer's shipping address.+data ShippingAddress = ShippingAddress+  { shipAddrRecipientName :: Maybe String+  , shipAddrType :: Maybe ShippingAddressType+  , shipAddrLine1 :: String+  , shipAddrLine2 :: Maybe String+  , shipAddrCity :: String+  , shipAddrCountryCode :: CountryCode+  , shipAddrPostalCode :: Maybe String+  , shipAddrState :: Maybe String+  , shipAddrPhone :: Maybe String+  } deriving (Eq, Show)++instance ToJSON ShippingAddress where+  toJSON addr =+    object (maybeToList (("recipient_name" .=) <$>+                         shipAddrRecipientName addr) +++            ["line1" .= shipAddrLine1 addr,+             "city" .= shipAddrCity addr,+             "country_code" .= toText (shipAddrCountryCode addr)] +++            maybeToList (("type" .=) <$> shipAddrType addr) +++            maybeToList (("line2" .=) <$> shipAddrLine2 addr) +++            maybeToList (("postal_code" .=) <$> shipAddrPostalCode addr) +++            maybeToList (("state" .=) <$> shipAddrState addr) +++            maybeToList (("phone" .=) <$> shipAddrPhone addr))++instance FromJSON ShippingAddress where+  parseJSON (Object obj) =+    ShippingAddress <$>+    obj .:? "recipient_name" <*>+    obj .:? "type" <*>+    obj .: "line1" <*>+    obj .:? "line2" <*>+    obj .: "city" <*>+    obj .: "country_code" <*>+    obj .:? "postal_code" <*>+    obj .:? "state" <*>+    obj .:? "phone"+  parseJSON _ = mzero
+ src/Network/Payments/PayPal/Types/Currency.hs view
@@ -0,0 +1,49 @@+-- |+-- Module: Network.Payments.PayPal.Types.Currency+-- Copyright: (C) 2016 Braden Walters+-- License: MIT (see LICENSE file)+-- Maintainer: Braden Walters <vc@braden-walters.info>+-- Stability: experimental+-- Portability: ghc++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Network.Payments.PayPal.Types.Currency+( Currency(..)+, MonetaryAmount(..)+) where++import Control.Monad+import Data.Decimal+import qualified Data.Text as T+import Data.Aeson+import Safe++-- |Currencies supported by PayPal.+data Currency =+  AUD | BRL | CAD | CZK | DKK | EUR | HKD | HUF | ILS | JPY | MYR | MXN | TWD |+  NZD | NOK | PHP | PLN | GBP | RUB | SGD | SEK | CHF | THB | TRY | USD+  deriving (Eq, Read, Show)++instance ToJSON Currency where+  toJSON currency = String $ T.pack $ show currency++instance FromJSON Currency where+  parseJSON (String txt) = maybe mzero return $ readMay $ T.unpack txt+  parseJSON _ = mzero++-- |Type based on Decimal which is used for holding monetary amounts and can be+-- encoded to and decoded from JSON. Encodes to a string, decodes from string or+-- number.+newtype MonetaryAmount = MonetaryAmount Decimal+  deriving (Eq, Fractional, Num, Ord, Read, Real, RealFrac, Show)++instance ToJSON MonetaryAmount where+  toJSON (MonetaryAmount value) = String $ T.pack $ show $ roundTo 2 value++instance FromJSON MonetaryAmount where+  parseJSON (String value) =+    return $ MonetaryAmount $ roundTo 2 $ read $ T.unpack value+  parseJSON (Number value) = return $ MonetaryAmount $ realFracToDecimal 2 value+  parseJSON _ = mzero
+ src/Network/Payments/PayPal/Types/FundingInstrument.hs view
@@ -0,0 +1,97 @@+-- |+-- Module: Network.Payments.PayPal.Types.FundingInstrument+-- Copyright: (C) 2016 Braden Walters+-- License: MIT (see LICENSE file)+-- Maintainer: Braden Walters <vc@braden-walters.info>+-- Stability: experimental+-- Portability: ghc++{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++module Network.Payments.PayPal.Types.FundingInstrument+( CreditCardType(..)+, CreditCard(..)+, FundingInstrument(..)+) where++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative+#endif+import Control.Monad+import Data.Aeson+import Data.Maybe+import qualified Data.Text as T+import Network.Payments.PayPal.Types.Address++-- |Type of credit card being used.+data CreditCardType = VisaCC | MasterCardCC | DiscoverCC | AMEXCC+  deriving (Eq, Read, Show)++instance ToJSON CreditCardType where+  toJSON VisaCC = "visa"+  toJSON MasterCardCC = "mastercard"+  toJSON DiscoverCC = "discover"+  toJSON AMEXCC = "amex"++instance FromJSON CreditCardType where+  parseJSON (String text) =+    -- Lower case is documented but sometimes PayPal likes to return upper+    -- case...+    case T.toLower text of+      "visa" -> return VisaCC+      "mastercard" -> return MasterCardCC+      "discover" -> return DiscoverCC+      "amex" -> return AMEXCC+      _ -> mzero+  parseJSON _ = mzero++-- |Information about a credit card.+data CreditCard = CreditCard+  { creditCardNumber :: String+  , creditCardType :: CreditCardType+  , creditCardExpireMonth :: Int+  , creditCardExpireYear :: Int+  , creditCardCVV2 :: Maybe String+  , creditCardFirstName :: Maybe String+  , creditCardLastName :: Maybe String+  , creditCardBillingAddress :: Maybe Address+  } deriving (Eq, Show)++instance ToJSON CreditCard where+  toJSON cc =+    object (["number" .= creditCardNumber cc,+             "type" .= creditCardType cc,+             "expire_month" .= show (creditCardExpireMonth cc),+             "expire_year" .= show (creditCardExpireYear cc)] +++            maybeToList (("cvv2" .=) <$> creditCardCVV2 cc) +++            maybeToList (("first_name" .=) <$> creditCardFirstName cc) +++            maybeToList (("last_name" .=) <$> creditCardLastName cc) +++            maybeToList (("billing_address" .=) <$>+                         creditCardBillingAddress cc))++instance FromJSON CreditCard where+  parseJSON (Object obj) =+    CreditCard <$>+    obj .: "number" <*>+    obj .: "type" <*>+    fmap read (obj .: "expire_month") <*>+    fmap read (obj .: "expire_year") <*>+    obj .:? "ccv2" <*>+    obj .:? "first_name" <*>+    obj .:? "last_name" <*>+    obj .:? "billing_address"+  parseJSON _ = mzero++-- |Representation of either a new credit card or existing credit card data.+data FundingInstrument = FundingInstrument+  { fundInstCreditCard :: Maybe CreditCard+  } deriving (Eq, Show)++instance ToJSON FundingInstrument where+  toJSON fundInstr =+    object (maybeToList (("credit_card" .=) <$> fundInstCreditCard fundInstr))++instance FromJSON FundingInstrument where+  parseJSON (Object obj) = FundingInstrument <$> obj .:? "credit_card"+  parseJSON _ = mzero
+ src/Network/Payments/PayPal/Types/Hateoas.hs view
@@ -0,0 +1,50 @@+-- |+-- Module: Network.Payments.PayPal.Types.Hateoas+-- Copyright: (C) 2016 Braden Walters+-- License: MIT (see LICENSE file)+-- Maintainer: Braden Walters <vc@braden-walters.info>+-- Stability: experimental+-- Portability: ghc++{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++module Network.Payments.PayPal.Types.Hateoas+( HateoasMethod(..)+, HateoasLink(..)+) where++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative+#endif+import Control.Monad+import qualified Data.Text as T+import Data.Aeson++type URL = String++-- |HATEOAS method.+data HateoasMethod = HateoasGet | HateoasPost | HateoasPatch | HateoasRedirect |+                     HateoasOther String deriving (Eq, Read, Show)++-- |HATEOAS link.+data HateoasLink = HateoasLink+  { hateoasHref :: URL+  , hateoasRel :: String+  , hateoasMethod :: HateoasMethod+  } deriving (Eq, Show)++instance FromJSON HateoasLink where+  parseJSON (Object obj) =+    HateoasLink <$>+    obj .: "href" <*>+    obj .: "rel" <*>+    ((obj .: "method") >>= parseHttpMethod)+    where+      parseHttpMethod (String "GET") = return HateoasGet+      parseHttpMethod (String "POST") = return HateoasPost+      parseHttpMethod (String "PATCH") = return HateoasPatch+      parseHttpMethod (String "REDIRECT") = return HateoasRedirect+      parseHttpMethod (String other) = return $ HateoasOther $ T.unpack other+      parseHttpMethod _ = mzero+  parseJSON _ = mzero
+ src/Network/Payments/PayPal/Types/Paging.hs view
@@ -0,0 +1,69 @@+-- |+-- Module: Network.Payments.PayPal.Types.Paging+-- Copyright: (C) 2016 Braden Walters+-- License: MIT (see LICENSE file)+-- Maintainer: Braden Walters <vc@braden-walters.info>+-- Stability: experimental+-- Portability: ghc++{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++module Network.Payments.PayPal.Types.Paging+( PagingSortBy(..)+, PagingSortOrder(..)+, PagingRequest(..)+, pagingReqToQuery+) where++import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS8+#if __GLASGOW_HASKELL__ < 710+import Data.Functor+#endif+import Data.Time.Clock+import Data.Time.Format+import Network.HTTP.Types.URI++-- |Sort by create or update time.+data PagingSortBy = PagingSortCreated | PagingSortUpdated deriving (Eq, Read)++instance Show PagingSortBy where+  show PagingSortCreated = "create_time"+  show PagingSortUpdated = "update_time"++-- |Sort order.+data PagingSortOrder = PagingSortAsc | PagingSortDesc deriving (Eq, Read)++instance Show PagingSortOrder where+  show PagingSortAsc = "asc"+  show PagingSortDesc = "desc"++-- |Request query parameters to page lists of data in a response.+data PagingRequest = PagingRequest+  { pagingCount :: Maybe Integer+  , pagingStartId :: Maybe String+  , pagingStartTime :: UTCTime+  , pagingEndTime :: UTCTime+  , pagingSortBy :: Maybe PagingSortBy+  , pagingSortOrder :: Maybe PagingSortOrder+  } deriving (Eq, Show)++-- |Create a query string from a paging request.+pagingReqToQuery :: PagingRequest -> String+pagingReqToQuery req =+  let queryItems = [("count", showToBS <$> pagingCount req),+                    ("start_id", stringToBS <$> pagingStartId req),+                    ("start_time", Just $ timeToBS $ pagingStartTime req),+                    ("end_time", Just $ timeToBS $ pagingEndTime req),+                    ("sort_by", showToBS <$> pagingSortBy req),+                    ("sort_order", showToBS <$> pagingSortOrder req)]+  in BS8.unpack $ renderQuery False queryItems+  where+    stringToBS :: String -> BS.ByteString+    stringToBS x = BS8.pack x+    timeToBS :: UTCTime -> BS.ByteString+    timeToBS x = BS8.pack $ formatTime defaultTimeLocale+                                       (iso8601DateFormat $ Just "%H:%M:%SZ") x+    showToBS :: Show a => a -> BS.ByteString+    showToBS x = BS8.pack $ show x
+ src/Network/Payments/PayPal/Types/Payer.hs view
@@ -0,0 +1,90 @@+-- |+-- Module: Network.Payments.PayPal.Types.Payer+-- Copyright: (C) 2016 Braden Walters+-- License: MIT (see LICENSE file)+-- Maintainer: Braden Walters <vc@braden-walters.info>+-- Stability: experimental+-- Portability: ghc++{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++module Network.Payments.PayPal.Types.Payer+( PayerInfo(..)+, PaymentMethod(..)+, PayerStatus(..)+, Payer(..)+) where++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative+#endif+import Control.Monad+import Data.Aeson+import qualified Data.Foldable as F+import Data.Maybe+import Network.Payments.PayPal.Types.FundingInstrument++-- |Optional additional information about the payer.+data PayerInfo = PayerInfo+  { payerInfoEmail :: String+  } deriving (Eq, Show)++instance ToJSON PayerInfo where+  toJSON info = object ["email" .= payerInfoEmail info]++instance FromJSON PayerInfo where+  parseJSON (Object obj) = PayerInfo <$> obj .: "email"+  parseJSON _ = mzero++-- |Method of payment.+data PaymentMethod = PayMethodPayPal | PayMethodCreditCard+  deriving (Eq, Read, Show)++instance ToJSON PaymentMethod where+  toJSON PayMethodPayPal = "paypal"+  toJSON PayMethodCreditCard = "credit_card"++instance FromJSON PaymentMethod where+  parseJSON (String "paypal") = return PayMethodPayPal+  parseJSON (String "credit_card") = return PayMethodCreditCard+  parseJSON _ = mzero++-- |Account verification status of the payer.+data PayerStatus = PayerStatusVerified | PayerStatusUnverified+  deriving (Eq, Read, Show)++instance FromJSON PayerStatus where+  parseJSON (String "VERIFIED") = return PayerStatusVerified+  parseJSON (String "UNVERIFIED") = return PayerStatusUnverified+  parseJSON _ = mzero++instance ToJSON PayerStatus where+  toJSON PayerStatusVerified = "VERIFIED"+  toJSON PayerStatusUnverified = "UNVERIFIED"++-- |Information about the payer in a transaction.+data Payer = Payer+  { payerPaymentMethod :: PaymentMethod+  , payerFundingInstruments :: [FundingInstrument]+  , payerInfo :: Maybe PayerInfo+  , payerStatus :: Maybe PayerStatus+  } deriving (Eq, Show)++instance ToJSON Payer where+  toJSON payer =+    let fundingInstr = if null $ payerFundingInstruments payer then Nothing+                       else Just $ payerFundingInstruments payer+    in object (["payment_method" .= payerPaymentMethod payer] +++               maybeToList (("funding_instruments" .=) <$> fundingInstr) +++               maybeToList (("payer_info" .=) <$> payerInfo payer) +++               maybeToList (("status" .=) <$> payerStatus payer))++instance FromJSON Payer where+  parseJSON (Object obj) =+    Payer <$>+    obj .: "payment_method" <*>+    (obj .:? "funding_instruments" >>= return . F.concat) <*>+    obj .:? "payer_info" <*>+    obj .:? "status"+  parseJSON _ = mzero
+ src/Network/Payments/PayPal/Types/Transaction.hs view
@@ -0,0 +1,150 @@+-- |+-- Module: Network.Payments.PayPal.Types.Transaction+-- Copyright: (C) 2016 Braden Walters+-- License: MIT (see LICENSE file)+-- Maintainer: Braden Walters <vc@braden-walters.info>+-- Stability: experimental+-- Portability: ghc++{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++module Network.Payments.PayPal.Types.Transaction+( Details(..)+, Amount(..)+, Item(..)+, ItemList(..)+, Transaction(..)+) where++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative+#endif+import Control.Monad+import Data.Aeson+import Data.Aeson.Types+import Data.Maybe+import qualified Data.Text as T+import Network.Payments.PayPal.Types.Address+import Network.Payments.PayPal.Types.Currency++-- |Details about the amount of a transaction.+data Details = Details+  { detailsShipping :: MonetaryAmount+  , detailsSubtotal :: MonetaryAmount+  , detailsTax :: MonetaryAmount+  } deriving (Eq, Show)++instance ToJSON Details where+  toJSON details =+    object ["shipping" .= detailsShipping details,+            "subtotal" .= detailsSubtotal details,+            "tax" .= detailsTax details]++instance FromJSON Details where+  parseJSON (Object obj) =+    Details <$>+    obj .: "shipping" <*>+    obj .: "subtotal" <*>+    obj .: "tax"+  parseJSON _ = mzero++-- |Amount of a transaction and its currency. The details must sum up to the+-- total or the request is rejected.+data Amount = Amount+  { amountCurrency :: Currency+  , amountTotal :: MonetaryAmount+  , amountDetails :: Details+  } deriving (Eq, Show)++instance ToJSON Amount where+  toJSON amt =+    object ["currency" .= amountCurrency amt,+            "total" .= amountTotal amt,+            "details" .= amountDetails amt]++instance FromJSON Amount where+  parseJSON (Object obj) =+    Amount <$>+    obj .: "currency" <*>+    obj .: "total" <*>+    obj .: "details"+  parseJSON _ = mzero++-- |An individual item being purchased.+data Item = Item+  { itemQuantity :: Integer+  , itemName :: String+  , itemPrice :: MonetaryAmount+  , itemCurrency :: Currency+  , itemSku :: String+  , itemDescription :: Maybe String+  } deriving (Eq, Show)++instance ToJSON Item where+  toJSON item =+    object (["quantity" .= itemQuantity item,+             "name" .= itemName item,+             "price" .= itemPrice item,+             "currency" .= itemCurrency item,+             "sku" .= itemSku item] +++            maybeToList (("description" .=) <$> itemDescription item))++instance FromJSON Item where+  parseJSON (Object obj) =+    Item <$>+    (obj .: "quantity" >>= parseFuzzyJSONInt) <*>+    obj .: "name" <*>+    obj .: "price" <*>+    obj .: "currency" <*>+    obj .: "sku" <*>+    obj .:? "description"+  parseJSON _ = mzero++-- |A list of items being purchased and the shipping address if one exists.+data ItemList = ItemList+  { itemListItems :: [Item]+  , itemListShippingAddress :: Maybe ShippingAddress+  } deriving (Eq, Show)++instance ToJSON ItemList where+  toJSON list =+    object (["items" .= itemListItems list] +++            maybeToList (("shipping_address" .=) <$>+                         itemListShippingAddress list))++instance FromJSON ItemList where+  parseJSON (Object obj) =+    ItemList <$>+    obj .: "items" <*>+    obj .:? "shipping_address"+  parseJSON _ = mzero++-- |Details about a financial transaction over PayPal.+data Transaction = Transaction+  { transactAmount :: Amount+  , transactDescription :: Maybe String+  , transactItemList :: ItemList+  } deriving (Eq, Show)++instance ToJSON Transaction where+  toJSON trans =+    object (["amount" .= transactAmount trans,+             "item_list" .= transactItemList trans] +++            maybeToList (("description" .=) <$> transactDescription trans))++instance FromJSON Transaction where+  parseJSON (Object obj) =+    Transaction <$>+    obj .: "amount" <*>+    obj .:? "description" <*>+    obj .: "item_list"+  parseJSON _ = mzero++-- |This takes either a string or a number and tries to produce an integer out+-- of it. This is necessary because PayPal apparently returns different types+-- for the same data depending on the usage...+parseFuzzyJSONInt :: (Integral a, Read a) => Value -> Parser a+parseFuzzyJSONInt (String txt) = return $ read $ T.unpack txt+parseFuzzyJSONInt (Number num) = return $ round num+parseFuzzyJSONInt _ = mzero