paypal-api (empty) → 0.1
raw patch · 7 files changed
+1542/−0 lines, 7 filesdep +basedep +bytestringdep +containerssetup-changed
Dependencies added: base, bytestring, containers, enumerator, failure, http-enumerator, http-types, monads-fd, old-locale, text, time, wai, web-encodings
Files
- LICENSE +30/−0
- Network/PayPal/ButtonManager.hs +1132/−0
- Network/PayPal/NVP.hs +95/−0
- Network/PayPal/Types.hs +131/−0
- Setup.hs +2/−0
- example.hs +92/−0
- paypal-api.cabal +60/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2011, Stephen Blackheath++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Stephen Blackheath nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Network/PayPal/ButtonManager.hs view
@@ -0,0 +1,1132 @@+{-# LANGUAGE TupleSections, OverloadedStrings, FlexibleInstances, TypeFamilies,+ StandaloneDeriving, ScopedTypeVariables, FlexibleContexts,+ UndecidableInstances, RankNTypes, EmptyDataDecls #-}+module Network.PayPal.ButtonManager (+ -- * Requests+ CreateButton(..),+ ButtonSearch(..),+ GetButtonDetails(..),+ -- * Responses+ PayPalResponse(..),+ -- * Button codes+ HOSTED,+ NONHOSTED,+ ENCRYPTED,+ CLEARTEXT,+ TOKEN,+ -- * Button types+ BUYNOW,+ CART,+ GIFTCERTIFICATE,+ SUBSCRIBE,+ DONATE,+ UNSUBSCRIBE,+ VIEWCART,+ -- * Variables profiles+ Item(..),+ Subscription(..),+ Payment(..),+ ShoppingCart(..),+ -- * Supporting types+ Duration(..),+ WeightUnit(..),+ ButtonType, Variables(..), Amount, Shipping, UndefinedQuantity,+ ButtonSubtype(..),+ CartAction(..),+ PaymentAction(..),+ PeriodicPrice(..),+ HostedButtonID(..),+ ButtonInfo(..),+ TypeOfButton(..),+ ButtonImageType(..),+ BuyNowText(..),+ SubscribeText(..),+ HostedButton(..),+ UpdateButton(..),+ -- * Options+ Options(..),+ Option(..),+ Select(..),+ Rank(..),+ FIRST,+ NONFIRST,+ -- * Re-exports+ module Network.PayPal.Types,+ module Network.PayPal.NVP+ ) where++import Network.PayPal.Types+import Network.PayPal.NVP++import Control.Applicative+import Control.Arrow+import Control.Monad+import Control.Monad.Error.Class+import qualified Data.ByteString.Char8 as C+import Data.Ratio+import Data.Map (Map)+import qualified Data.Map as M+import Data.Maybe+import Data.Monoid+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Time.Format+import Debug.Trace+import Network.HTTP.Enumerator+import Web.Encodings (decodeUrlPairs)+import Numeric+++-- | Button code value+data HOSTED+instance ToText HOSTED where { toText _ = "HOSTED" }++data NONHOSTED a++-- | Button code value+data ENCRYPTED+instance ToText (NONHOSTED ENCRYPTED) where { toText _ = "ENCRYPTED" }++-- | Button code value+data CLEARTEXT+instance ToText (NONHOSTED CLEARTEXT) where { toText _ = "CLEARTEXT" }++-- | Button code value+data TOKEN+instance ToText (NONHOSTED TOKEN) where { toText _ = "TOKEN" }++data Duration = D | W | M | Y+ deriving Show++instance ToText Duration where+ toText D = "D"+ toText W = "W"+ toText M = "M"+ toText Y = "Y"++data WeightUnit = Lb | Kg+ deriving Show++instance ToText WeightUnit where+ toText Lb = "lbs"+ toText Kg = "kgs"++instance FromText WeightUnit where+ fromText "lbs" = Just Lb+ fromText "kgs" = Just Kg+ fromText _ = Nothing++data Payment = Payment {+ -- | True: The address specified in prepopulation variables overrides the+ -- PayPal member's stored address. The payer is shown the passed-in+ -- address but cannot edit it. No address is shown if the address is not+ -- valid, such as missing required fields like country, or is not+ -- included at all.+ payAddressOverride :: Maybe Bool,+ -- | The currency of the payment. The default is USD. (3 chars)+ payCurrencyCode :: Maybe C.ByteString,+ -- | Passthrough variable never presented to the payer.+ -- Default - No variable is passed back to you.+ payCustom :: Maybe C.ByteString,+ -- | Handling charges. This is not quantity-specific. The same handling+ -- cost applies, regardless of the number of items on the order.+ -- Default - No handling charges are included. (256 chars)+ payHandling :: Maybe Rational,+ -- | Passthrough variable you can use to identify your invoice number+ -- for this purchase. (127 chars)+ -- Default - No variable is passed back to you.+ payInvoice :: Maybe C.ByteString,+ {-+ -- | The cost of shipping the entire order contained in third-party shopping carts.+ -- This use of the shipping variable is valid only for the Cart Upload command.+ -- Default - If profile-based shipping rates are configured, buyers are+ -- charged an amount according to the shipping methods they choose.+ payShipping :: Maybe Rational,+ -}+ -- | Cart-wide tax, overriding any individual item tax_x value+ payTaxCart :: Maybe Rational,+ -- | If profile-based shipping rates are configured with a basis of+ -- weight, PayPal uses this value to calculate the shipping charges for+ -- the transaction. This value overrides the weight values of+ -- individual items.+ payWeight :: Maybe (Double, WeightUnit)+ }+ deriving Show++{-+emptyPayment :: Payment+emptyPayment = Payment Nothing Nothing Nothing+ Nothing Nothing Nothing Nothing+-}++instance ToVariables Payment where+ toVariables p =+ maybeToList (("address_override",) . (\x -> if x then "1" else "0") <$> payAddressOverride p) +++ maybeToList (("currency_code",) <$> payCurrencyCode p) +++ maybeToList (("custom",) <$> payCustom p) +++ maybeToList (("handling",) . toText <$> payHandling p) +++ maybeToList (("invoice",) <$> payInvoice p) +++ --maybeToList (("shipping",) . toText <$> payShipping p) +++ maybeToList (("tax_cart",) . toText <$> payTaxCart p) +++ maybe [] (\(wt, unit) -> [("weight_cart", toText wt),+ ("weight_unit", toText unit)]) (payWeight p)++instance FromVariables Payment where+ fromVariables m = do+ return $ Payment {+ payAddressOverride = case "address_override" `M.lookup` m of+ Just "0" -> Just False+ Just "1" -> Just True+ _ -> Nothing,+ payCurrencyCode = "currency_code" `M.lookup` m,+ payCustom = "custom" `M.lookup` m,+ payHandling = join $ fromText <$> M.lookup "handling" m,+ payInvoice = "invoice" `M.lookup` m,+ payTaxCart = join $ fromText <$> M.lookup "tax_cart" m,+ payWeight =+ let mWeight = join $ fromText <$> M.lookup "weight_cart" m+ mWeightUnit = join $ fromText <$> M.lookup "weight_unit" m+ in case (mWeight, mWeightUnit) of+ (Just w, Just u) -> Just (w, u)+ _ -> Nothing+ }++data CartAction = Add | Display | Upload deriving Show+data PaymentAction = Sale | Authorization | Order deriving Show++data ShoppingCart = ShoppingCart {+ -- | Add an item to the PayPal Shopping Cart, OR, Display the contents of+ -- the PayPal Shopping Cart to the buyer, OR, Upload the contents of a+ -- third party shopping cart or a custom shopping cart.+ caAction :: CartAction,+ {-+ For Add to cart buttons, these variables already exist in the Item data type.+ For Cart uploads, we'll need them, but this isn't implemented yet.+ -- | Price of the item or the total price of all items in the shopping cart.+ caAmount :: Rational,+ -- | Your PayPal ID or an email address associated with your PayPal account.+ -- Email addresses must be confirmed.+ caBusiness :: C.ByteString,+ -- | Name of the item or a name for the entire Shopping Cart+ caItemName :: Text,+ -}+ -- | Single handling fee to be charged cart-wide. If handling_cart is used+ -- in multiple Add to Cart buttons, the handling_cart value of the first item+ -- is used.+ caHandlingCart :: Maybe Rational,+ -- | Indicates whether the transaction is payment on a final sale or an+ -- authorization for a final sale, to be captured later.+ -- The default value is sale.+ --+ -- Set the value to authorization to place a hold on the PayPal account for the+ -- authorized amount. Set the value to order to authorize the transaction without+ -- placing a hold on the PayPal account.+ --+ --Important:+ -- If you set paymentaction to order, you must use the Authorization & Capture+ -- API to authorize and capture the transaction payments. The merchant tools on+ -- the PayPal websitel let you capture payments only for authorizations, not for+ -- orders.+ caPaymentAction :: PaymentAction,+ -- | The URL of the page on the merchant website that buyers return to when they+ -- click the Continue Shopping button on the PayPal Shopping Cart page.+ --+ -- NOTE:+ -- If you use this, and the URL contains characters like '%' then PayPal will+ -- mangle them. Also, shopping_url doesn't work for the "View Cart" button.+ -- However, if you don't use this, PayPal seems to use the referrer URL, so it+ -- shouldn't be necessary to use this broken feature.+ caShoppingURL :: Maybe C.ByteString+ -- upload+ }+ deriving Show++instance ToVariables ShoppingCart where+ toVariables ca =+ [(action, "1")] +++ maybeToList (("handling_cart",) . toText <$> caHandlingCart ca) +++ [("paymentaction", case caPaymentAction ca of+ Sale -> "sale"+ Authorization -> "authorization"+ Order -> "order")] +++ maybeToList (("shopping_url",) <$> caShoppingURL ca)+ where+ action = case caAction ca of+ Add -> "add"+ Display -> "display"+ Upload -> "upload"++instance FromVariables ShoppingCart where+ fromVariables m = do+ action <- case (`M.lookup` m) <$> ["add", "display", "upload"] of+ [Just "1", Nothing, Nothing] -> return Add+ [Nothing, Just "1", Nothing] -> return Display+ [Nothing, Nothing, Just "1"] -> return Upload+ _ -> throwError "one of 'add', 'display' or 'upload' required"+ paymentAction <- do+ let mPa = "paymentaction" `M.lookup` m+ case mPa of+ Just "sale" -> return Sale+ Just "authorization" -> return Authorization+ Just "order" -> return Order+ Nothing -> return Sale+ _ -> throwError $ "unexpected 'paymentaction': "++(show mPa)+ return $ ShoppingCart {+ caAction = action,+ caHandlingCart = join $ fromText <$> M.lookup "handling_cart" m,+ caPaymentAction = paymentAction,+ caShoppingURL = "shopping_url" `M.lookup` m+ }++data PeriodicPrice = PeriodicPrice {+ -- | a3 Price of subscription. Must be specified for Subscribe buttons. Value must be+ -- a positive number. No currency symbol. Must have two decimal places,+ -- decimal separator must be a period (.), and the optional thousands separator+ -- must be a comma (,).+ ppPrice :: Rational,+ -- | p3 Regular billing cycle. Must be specified for Subscribe buttons. Limitations:+ -- Must be a positive integer greater than 0 and less than or equal to 30+ ppCycle :: Int,+ -- | t3 Regular billing cycle units. Must be specified for Subscribe buttons.+ ppCycleUnits :: Duration+ }+ deriving Show++data Subscription = Subscription {+ -- | Your PayPal ID or an email address associated with your PayPal account. Email+ -- addresses must be confirmed.+ suBusiness :: C.ByteString,+ -- | Description of item being sold (maximum 127 characters). If you are collecting+ -- aggregate payments, this can include a summary of all items purchased, tracking+ -- numbers, or generic terms such as "subscription." If omitted, customer will see+ -- a field in which they have the option of entering an Item Name+ suItemName :: Maybe C.ByteString,+ -- | The currency of prices for trial periods and the subscription. The default is USD.+ suCurrencyCode :: Maybe C.ByteString,+ -- | Trial period 1 price. For a free trial period, specify 0.+ -- Trial period 2 price. Can be specified only if you also specify a1.+ suTrialPeriod :: Maybe (PeriodicPrice, Maybe PeriodicPrice),+ suRegularPrice :: PeriodicPrice,+ -- | Nothing = Subscription payments do not recur.+ -- Just (times, reattempt) = Subscription payments recur. times = Number of times that subscription+ -- payments recur. Specify an integer above 1.+ -- reattempt: false = do not reattempt failed recurring payments+ -- true = reattempt failed recurring payments before canceling+ suRecurring :: Maybe (Int, Bool),+ -- | User-defined field which will be passed through the system and returned+ -- in your merchant payment notification email. This field will not be shown to your subscribers.+ -- Default - No variable is passed back to you.+ suCustom :: Maybe C.ByteString,+ -- | User-defined field which must be unique with each subscription. The invoice+ -- number will be shown to subscribers with the other details of their transactions+ suInvoice :: Maybe C.ByteString,+ -- | Modification behavior. Allowable values:+ --+ -- * 0 - allows subscribers to only create new subscriptions+ --+ -- * 1 - allows subscribers to modify their current subscriptions or sign up for new ones+ --+ -- * 2 - allows subscribers to only modify their current subscriptions+ --+ -- The default value is 0.+ suModification :: Int,+ -- | Set to 1 to have PayPal generate usernames and initial passwords for subscribers.+ suUserManage :: Bool+ }+ deriving Show++instance ToVariables Subscription where+ toVariables su =+ [("business", suBusiness su)] +++ maybeToList (("item_name",) <$> suItemName su) +++ maybeToList (("currency_code",) <$> suCurrencyCode su) +++ (case suTrialPeriod su of+ Nothing -> []+ Just (pp1, Nothing) -> formatPP "1" pp1+ Just (pp1, Just pp2) -> formatPP "1" pp1 ++ formatPP "2" pp2) +++ formatPP "3" (suRegularPrice su) +++ (case suRecurring su of+ Nothing -> []+ Just (t, False) -> [("src", "1"), ("srt", toText t)]+ Just (t, True) -> [("src", "1"), ("srt", toText t), ("sra", "1")]) +++ maybeToList (("customer",) <$> suCustom su) +++ maybeToList (("invoice",) <$> suInvoice su) +++ [("modification", toText (suModification su))] +++ (if suUserManage su then [("usr_manage", "1")] else []) +++ [("no_note", "1")]+ where+ formatPP suff (PeriodicPrice a p t) =+ [("a" `mappend` suff, toText a),+ ("p" `mappend` suff, toText p),+ ("t" `mappend` suff, toText t)]++data Item bt = Item {+ -- | The price or amount of the item. Required for Add to Cart buttons. May not+ -- be used when a dropdown with price (L_OPTION0PRICEn) is defined.+ -- Limitations: Value must be a positive number. No currency symbol. Must have+ -- two decimal places, decimal separator must be a period (.), and the optional+ -- thousands separator must be a comma (,).+ itAmount :: Amount bt,+ -- | Description of item. If omitted, payers enter their own name at the time of payment.+ itItemName :: Maybe Text,+ -- | Secure Merchant ID or Email Address. When omitted, defaults to the secure+ -- merchant ID of the merchant. If an email address is specified then it the+ -- following requirements apply:+ -- A merchant or 3rd Party calling the API directly may specify an+ -- unregistered email and create an unencrypted button only.+ -- A 3rd Party calling the API on behalf of a registered merchant must specify+ -- an email address associated with the merchant account.+ -- Character length and limitations: 127 single-byte characters.+ itBusiness :: Maybe C.ByteString,+ -- | Item number or ID. Character length and limitations: 127 single-byte+ -- alphanumeric characters.+ itItemNumber :: Maybe C.ByteString,+ -- | Number of items. If profile-based shipping rates are configured with a basis+ -- of quantity, the sum of quantity values is used to calculate the shipping charges+ -- for the transaction. PayPal appends a sequence number to uniquely identify the+ -- item in the PayPal Shopping Cart (e.g., quantity1, quantity2).+ -- Note: The value for quantity must be a positive integer. Null, zero, or negative+ -- numbers are not allowed.+ itQuantity :: Maybe Int,+ -- | The cost of shipping this item. If you specify shipping and shipping2 is not+ -- defined, this flat amount is charged regardless of the quantity of items purchased.+ -- This use of the shipping variable is valid only for Buy Now and Add to Cart buttons.+ -- Default - If profile-based shipping rates are configured, buyers are charged an+ -- amount according to the shipping methods they choose.+ itShipping :: Shipping bt,+ -- | The cost of shipping each additional unit of this item. If omitted and+ -- profile-based shipping rates are configured, buyers are charged an amount according+ -- to the shipping methods they choose.+ -- Valid only for Buy Now and Add to Cart buttons.+ itShipping2 :: Shipping bt,+ -- | Transaction-based tax override variable. Set this to a flat tax amount to apply+ -- to the transaction regardless of the buyer's location. This value overrides any tax+ -- settings set in your account profile. Valid only for Buy Now and Add to Cart buttons.+ -- Default - Profile tax settings, if any, apply.+ itTax :: Maybe Rational,+ -- | Transaction-based tax override variable. Set this to a percentage that will be+ -- applied to amount multiplied the quantity selected during checkout. This value+ -- overrides any tax settings set in your account profile. Allowable values are numbers+ -- 0.001 through 100. Valid only for Buy Now and Add to Cart buttons. Default - Profile+ -- tax settings, if any, apply.+ itTaxRate :: Maybe Double,+ -- | True = allows buyers to specify the quantity.+ itUndefinedQuantity :: UndefinedQuantity bt,+ -- | Weight of items. If profile-based shipping rates are configured with a basis of+ -- weight, the sum of weight values is used to calculate the shipping charges for the+ -- transaction.+ itWeight :: Maybe (Double, WeightUnit)+ }++deriving instance (Show (UndefinedQuantity bt),+ Show (Shipping bt),+ Show (Amount bt)) => Show (Item bt)++instance ButtonType bt => ToVariables (Item bt) where+ toVariables it =+ maybeToList (("amount",) . toText <$> getAmount (undefined :: bt) (itAmount it)) +++ maybeToList (("item_name",) . T.encodeUtf8 <$> itItemName it) +++ maybeToList (("business",) <$> itBusiness it) +++ maybeToList (("item_number",) <$> itItemNumber it) +++ maybeToList (("quantity",) . toText <$> itQuantity it) +++ maybeToList (("shipping",) . toText <$> getShipping (undefined :: bt) (itShipping it)) +++ maybeToList (("shipping2",) . toText <$> getShipping (undefined :: bt) (itShipping2 it)) +++ maybeToList (("tax",) . toText <$> itTax it) +++ maybeToList (("tax_rate",) . C.pack . (\t -> showFFloat (Just 3) t "") <$> itTaxRate it) +++ maybeToList (("undefined_quantity",) . (\b -> if b then "1" else "0")+ <$> getUndefinedQuantity (undefined :: bt) (itUndefinedQuantity it)) +++ maybe [] (\(wt, unit) -> [("weight", toText wt),+ ("weight_unit", toText unit)]) (itWeight it)++instance ButtonType bt => FromVariables (Item bt) where+ fromVariables m = do+ let mAmountRat = join $ fromText <$> M.lookup "amount" m+ amount <- setAmount (undefined :: bt) mAmountRat+ let mShippingRat = join $ fromText <$> M.lookup "shipping" m+ shipping <- setShipping (undefined :: bt) mShippingRat+ let mShippingRat2 = join $ fromText <$> M.lookup "shipping2" m+ shipping2 <- setShipping (undefined :: bt) mShippingRat2+ let mUndefinedQ = case M.lookup "undefined_quantity" m of+ Just "0" -> Just False+ Just "1" -> Just True+ _ -> Nothing+ undefinedQ <- setUndefinedQuantity (undefined :: bt) mUndefinedQ+ return $ Item {+ itAmount = amount,+ itItemName = T.decodeUtf8 <$> M.lookup "item_name" m,+ itBusiness = M.lookup "business" m,+ itItemNumber = M.lookup "item_number" m,+ itQuantity = join $ fromText <$> M.lookup "quantity" m,+ itShipping = shipping,+ itShipping2 = shipping2,+ itTax = join $ fromText <$> M.lookup "tax" m,+ itTaxRate = join $ fromText <$> M.lookup "tax_rate" m,+ itUndefinedQuantity = undefinedQ,+ itWeight =+ let mWeight = join $ fromText <$> M.lookup "weight" m+ mWeightUnit = join $ fromText <$> M.lookup "weight_unit" m+ in case (mWeight, mWeightUnit) of+ (Just w, Just u) -> Just (w, u)+ _ -> Nothing+ }++toLButtonVars :: [(C.ByteString, C.ByteString)] -> [(C.ByteString, C.ByteString)]+toLButtonVars vars =+ flip map (zip [0..] vars) $ \(ix, (name, value)) ->+ ("L_BUTTONVAR" `mappend` (C.pack $ show ix),+ name `mappend` "=" `mappend` value)++fromLButtonVars :: Map C.ByteString C.ByteString -> Map C.ByteString C.ByteString+fromLButtonVars m = flb 0 M.empty+ where+ flb :: Int -> Map C.ByteString C.ByteString -> Map C.ByteString C.ByteString+ flb ix acc = case ("L_BUTTONVAR" `mappend` C.pack (show ix)) `M.lookup` m of+ Just pair0 ->+ let pair = unquote pair0+ in case C.findIndex (== '=') pair of+ Just eqIx ->+ let (name, value) = second (C.drop 1) $ C.splitAt eqIx pair+ in flb (ix+1) (M.insert name value acc)+ Nothing ->+ acc+ Nothing -> acc++-- | Remove a single set of surrounding quotes if present.+unquote :: C.ByteString -> C.ByteString+unquote str | "\"" `C.isPrefixOf` str && "\"" `C.isSuffixOf` str =+ C.take (C.length str - 2) . C.drop 1 $ str+unquote str = str++class ToText bt => ButtonType bt where+ data Variables bt :: *+ type Amount bt :: *+ type Shipping bt :: *+ type UndefinedQuantity bt :: *+ type ButtonText bt :: *+ formatButtonVariables :: Variables bt -> [(C.ByteString, C.ByteString)]+ parseButtonVariables :: Map C.ByteString C.ByteString -> Either String (Variables bt)+ getAmount :: bt -> Amount bt -> Maybe Rational+ -- | A return value of Nothing signifies a parse failure. If Amount bt is a Maybe+ -- type, then Just Nothing signifies a valid but omitted amount.+ setAmount :: bt -> Maybe Rational -> Either String (Amount bt)+ getShipping :: bt -> Shipping bt -> Maybe Rational+ setShipping :: bt -> Maybe Rational -> Either String (Shipping bt)+ getUndefinedQuantity :: bt -> UndefinedQuantity bt -> Maybe Bool+ setUndefinedQuantity :: bt -> Maybe Bool -> Either String (UndefinedQuantity bt)+ getButtonText :: bt -> ButtonText bt -> Maybe (C.ByteString, C.ByteString)+ setButtonText :: bt -> Map C.ByteString C.ByteString -> ButtonText bt++-- | Button type value+data BUYNOW+instance ToText BUYNOW where { toText _ = "BUYNOW" }+instance ButtonType BUYNOW where+ data Variables BUYNOW = Variables_BUYNOW {+ buyNowItem :: Item BUYNOW+ }+ type Amount BUYNOW = Maybe Rational+ type Shipping BUYNOW = Maybe Rational+ type UndefinedQuantity BUYNOW = Maybe Bool+ type ButtonText BUYNOW = Maybe BuyNowText+ formatButtonVariables = toVariables . buyNowItem+ parseButtonVariables m = Variables_BUYNOW <$> fromVariables m+ getAmount _ = id+ setAmount _ = return+ getShipping _ = id+ setShipping _ = return+ getUndefinedQuantity _ = id+ setUndefinedQuantity _ = return+ getButtonText _ btxt = ("BUYNOWTEXT",) . toText <$> btxt+ setButtonText _ m = join $ fromText <$> M.lookup "BUYNOWTEXT" m+deriving instance Show (Variables BUYNOW)++data TypeOfButton = CART | GIFTCERTIFICATE | SUBSCRIBE | DONATE | UNSUBSCRIBE |+ VIEWCART | PAYMENTPLAN | AUTOBILLING | PAYMENT+ deriving (Eq, Ord, Show, Enum)++instance FromText TypeOfButton where+ fromText "ADDCART" = Just CART+ fromText "GIFTCERTIFICATE" = Just GIFTCERTIFICATE+ fromText "SUBSCRIBE" = Just SUBSCRIBE+ fromText "DONATE" = Just DONATE+ fromText "UNSUBSCRIBE" = Just UNSUBSCRIBE+ fromText "VIEWCART" = Just VIEWCART+ fromText "PAYMENTPLAN" = Just PAYMENTPLAN+ fromText "AUTOBILLING" = Just AUTOBILLING+ fromText "PAYMENT" = Just PAYMENT+ fromText _ = Nothing++-- | Button type value+data CART+instance ToText CART where { toText _ = "CART" }+instance ButtonType CART where+ data Variables CART = Variables_CART {+ cartItem :: Item CART,+ cartPayment :: Payment,+ cartCart :: ShoppingCart+ }+ type Amount CART = Rational+ type Shipping CART = Maybe Rational+ type UndefinedQuantity CART = ()+ type ButtonText CART = ()+ formatButtonVariables va = toVariables (cartItem va) +++ toVariables (cartPayment va) +++ toVariables (cartCart va)+ parseButtonVariables m = do+ item <- fromVariables m+ payment <- fromVariables m+ cart <- fromVariables m+ return $ Variables_CART {+ cartItem = item,+ cartPayment = payment,+ cartCart = cart+ }+ getAmount _ = Just+ setAmount _ ma = case ma of+ Just a -> return a+ Nothing -> throwError "amount missing"+ getShipping _ = id+ setShipping _ = return+ getUndefinedQuantity _ () = Nothing+ setUndefinedQuantity _ _ = return ()+ getButtonText _ () = Nothing+ setButtonText _ _ = ()+deriving instance Show (Variables CART)++-- | Button type value+data GIFTCERTIFICATE+instance ToText GIFTCERTIFICATE where { toText _ = "GIFTCERTIFICATE" }+instance ButtonType GIFTCERTIFICATE where+ data Variables GIFTCERTIFICATE = Variables_GIFTCERTIFICATE+ type Amount GIFTCERTIFICATE = ()+ type Shipping GIFTCERTIFICATE = ()+ type UndefinedQuantity GIFTCERTIFICATE = ()+ type ButtonText GIFTCERTIFICATE = ()+ formatButtonVariables _ = []+ parseButtonVariables _ = return Variables_GIFTCERTIFICATE+ getAmount _ () = Nothing+ setAmount _ _ = return ()+ getShipping _ () = Nothing+ setShipping _ _ = return ()+ getUndefinedQuantity _ () = Nothing+ setUndefinedQuantity _ _ = return ()+ getButtonText _ () = Nothing+ setButtonText _ _ = ()+deriving instance Show (Variables GIFTCERTIFICATE)++-- | Button type value+data SUBSCRIBE+instance ToText SUBSCRIBE where { toText _ = "SUBSCRIBE" }+instance ButtonType SUBSCRIBE where+ data Variables SUBSCRIBE = Variables_SUBSCRIBE {+ subscribeSubscription :: Subscription+ }+ type Amount SUBSCRIBE = ()+ type Shipping SUBSCRIBE = ()+ type UndefinedQuantity SUBSCRIBE = ()+ type ButtonText SUBSCRIBE = Maybe SubscribeText+ formatButtonVariables = toVariables . subscribeSubscription+ parseButtonVariables = error "SUBSCRIBE.parseButtonVariables is not implemented yet"+ getAmount _ () = Nothing+ setAmount _ _ = return ()+ getShipping _ () = Nothing+ setShipping _ _ = return ()+ getUndefinedQuantity _ () = Nothing+ setUndefinedQuantity _ _ = return ()+ getButtonText _ btxt = ("SUBSCRIBETEXT",) . toText <$> btxt+ setButtonText _ m = join $ fromText <$> M.lookup "SUBSCRIBETEXT" m+deriving instance Show (Variables SUBSCRIBE)++-- | Button type value+data DONATE+instance ToText DONATE where { toText _ = "DONATE" }+instance ButtonType DONATE where+ data Variables DONATE = Variables_DONATE {+ donateItem :: Item DONATE+ }+ type Amount DONATE = Maybe Rational+ type Shipping DONATE = ()+ type UndefinedQuantity DONATE = ()+ type ButtonText DONATE = ()+ formatButtonVariables = toVariables . donateItem+ parseButtonVariables m = Variables_DONATE <$> fromVariables m+ getAmount _ = id+ setAmount _ = return+ getShipping _ () = Nothing+ setShipping _ _ = return ()+ getUndefinedQuantity _ () = Nothing+ setUndefinedQuantity _ _ = return ()+ getButtonText _ () = Nothing+ setButtonText _ _ = ()+deriving instance Show (Variables DONATE)++-- | Button type value+data UNSUBSCRIBE+instance ToText UNSUBSCRIBE where { toText _ = "UNSUBSCRIBE" }+instance ButtonType UNSUBSCRIBE where+ data Variables UNSUBSCRIBE = Variables_UNSUBSCRIBE+ type Amount UNSUBSCRIBE = ()+ type Shipping UNSUBSCRIBE = ()+ type UndefinedQuantity UNSUBSCRIBE = ()+ type ButtonText UNSUBSCRIBE = ()+ formatButtonVariables _ = []+ parseButtonVariables _ = return Variables_UNSUBSCRIBE+ getAmount _ () = Nothing+ setAmount _ _ = return ()+ getShipping _ () = Nothing+ setShipping _ _ = return ()+ getUndefinedQuantity _ () = Nothing+ setUndefinedQuantity _ _ = return ()+ getButtonText _ () = Nothing+ setButtonText _ _ = ()+deriving instance Show (Variables UNSUBSCRIBE)++-- | Button type value+data VIEWCART+instance ToText VIEWCART where { toText _ = "VIEWCART" }+instance ButtonType VIEWCART where+ data Variables VIEWCART = Variables_VIEWCART+ type Amount VIEWCART = ()+ type Shipping VIEWCART = ()+ type UndefinedQuantity VIEWCART = ()+ type ButtonText VIEWCART = ()+ formatButtonVariables _ = []+ parseButtonVariables _ = return $ Variables_VIEWCART+ getAmount _ () = Nothing+ setAmount _ _ = return ()+ getShipping _ () = Nothing+ setShipping _ _ = return ()+ getUndefinedQuantity _ () = Nothing+ setUndefinedQuantity _ _ = return ()+ getButtonText _ () = Nothing+ setButtonText _ _ = ()+deriving instance Show (Variables VIEWCART)++{-+-- | Button type value+data PAYMENTPLAN+instance ButtonType PAYMENTPLAN where+ type ItemName PAYMENTPLAN = Maybe Text+ buttonTypeToText _ = "PAYMENTPLAN"+ getItemName = id++-- | Button type value+data AUTOBILLING+instance ButtonType AUTOBILLING where+ type ItemName AUTOBILLING = Maybe Text+ buttonTypeToText _ = "AUTOBILLING"+ getItemName = id++-- | Button type value+data PAYMENT+instance ButtonType PAYMENT where+ type ItemName PAYMENT = Maybe Text+ buttonTypeToText _ = "PAYMENT"+ getItemName = id+ -}++data ButtonSubtype = PRODUCTS | SERVICES+ deriving Show++instance ToText ButtonSubtype where+ toText PRODUCTS = "PRODUCTS"+ toText SERVICES = "SERVICES"++instance FromText ButtonSubtype where+ fromText "PRODUCTS" = Just PRODUCTS+ fromText "SERVICES" = Just SERVICES+ fromText _ = Nothing++data FIRST+data NONFIRST++class Rank r where+ type RankPrice r :: *+ getRankPrice :: r -> RankPrice r -> Maybe Rational+ setRankPrice :: r -> Maybe Rational -> RankPrice r++instance Rank FIRST where+ type RankPrice FIRST = Maybe Rational+ getRankPrice _ = id+ setRankPrice _ = id++instance Rank NONFIRST where+ type RankPrice NONFIRST = ()+ getRankPrice _ () = Nothing+ setRankPrice _ _ = ()++data Select rank = Select {+ seName :: Text,+ sePrice :: RankPrice rank+ }+deriving instance Show (RankPrice rank) => Show (Select rank)++selectToVariables :: forall rank . Rank rank =>+ Int -> Int -> Select rank -> [(C.ByteString, C.ByteString)]+selectToVariables oIx sIx0 se =+ [(prefix `mappend` "SELECT" `mappend` sIx, T.encodeUtf8 $ seName se)] +++ maybeToList ((prefix `mappend` "PRICE" `mappend` sIx,) . toText+ <$> getRankPrice (undefined :: rank) (sePrice se))+ where+ prefix = "L_OPTION" `mappend` (C.pack $ show oIx)+ sIx = C.pack $ show sIx0++selectFromVariables :: forall r . Rank r =>+ Int -> Int -> Map C.ByteString C.ByteString -> Either String (Maybe (Select r))+selectFromVariables oIx sIx0 m = do+ case M.lookup (prefix `mappend` "SELECT" `mappend` sIx) m of+ Just name -> do+ let mPrice = join $ fromText <$> M.lookup (prefix `mappend` "PRICE" `mappend` sIx) m+ return $ Just $ Select (T.decodeUtf8 name) (setRankPrice (undefined :: r) mPrice)+ Nothing -> return Nothing+ where+ prefix = "L_OPTION" `mappend` (C.pack $ show oIx)+ sIx = C.pack $ show sIx0++-- | Note: In PayPal naming, \'option\' and \'select\' are swapped around from the+-- HTML naming.+data Option rank = Option {+ opName :: Text,+ opSelects :: [Select rank]+ }+deriving instance Show (RankPrice rank) => Show (Option rank)++optionToVariables :: Rank rank => Int -> Option rank -> [(C.ByteString, C.ByteString)]+optionToVariables oIx0 (Option name selects) =+ [("OPTION" `mappend` oIx `mappend` "NAME", T.encodeUtf8 name)]+++ concatMap (uncurry $ selectToVariables oIx0) (zip [0..] selects)+ where+ oIx = C.pack . show $ oIx0++optionFromVariables :: Rank rank => Int -> Map C.ByteString C.ByteString -> Either String (Maybe (Option rank))+optionFromVariables oIx0 m = do+ case M.lookup ("OPTION" `mappend` oIx `mappend` "NAME") m of+ Just name -> do+ selects <- parseSelects 0 m []+ return . Just $ Option (T.decodeUtf8 name) selects+ Nothing -> return Nothing+ where+ oIx = C.pack . show $ oIx0+ parseSelects sIx m acc = do+ mSel <- selectFromVariables oIx0 sIx m+ case mSel of+ Just sel -> parseSelects (sIx+1) m (sel:acc)+ Nothing -> return (reverse acc)++-- Either zero options (Nothing), or a FIRST rank option and any number of NONFIRST ones.+newtype Options = Options (Maybe (Option FIRST, [Option NONFIRST]))+ deriving Show++instance ToVariables Options where+ toVariables (Options Nothing) = []+ toVariables (Options (Just (opt, opts))) =+ optionToVariables 0 opt +++ concatMap (uncurry optionToVariables) (zip [1..] opts)++instance FromVariables Options where+ fromVariables m = do+ mFirst <- optionFromVariables 0 m+ case mFirst of+ Just first -> do+ nonFirsts <- parseOptions 1 m []+ return $ Options $ Just (first, nonFirsts)+ Nothing -> return $ Options Nothing+ where+ parseOptions ix m acc = do+ mNonFirst <- optionFromVariables ix m+ case mNonFirst of+ Just nonFirst -> parseOptions (ix+1) m (nonFirst:acc)+ Nothing -> return (reverse acc)++data CreateButton buttonCode buttonType = CreateButton {+ cbVariables :: Variables buttonType,+ cbButtonSubtype :: Maybe ButtonSubtype,+ cbOptions :: Options,+ -- | Either the button image type, or the button image URL.+ cbButtonImage :: Maybe (Either ButtonImageType C.ByteString),+ cbButtonText :: ButtonText buttonType,+ cbCountry :: Maybe C.ByteString,+ cbLanguage :: Maybe C.ByteString,+ cbExtras :: [(C.ByteString, C.ByteString)]+ }+deriving instance (Show (Variables buttonType), Show (ButtonText buttonType)) =>+ Show (CreateButton buttonCode buttonType)++newtype HostedButtonID = HostedButtonID C.ByteString deriving Show++instance ButtonType bt => ToVariables (CreateButton HOSTED bt) where+ toVariables = encodeCreateButtonRequest "BMCreateButton"+instance ButtonType bt => PayPalRequest (CreateButton HOSTED bt) where+ data PayPalResponse (CreateButton HOSTED bt) =+ CreateButton_Hosted_Response HostedButtonID C.ByteString C.ByteString++ decodeResponse m = case (`M.lookup` m) <$> ["HOSTEDBUTTONID", "EMAILLINK", "WEBSITECODE"] of+ [Just id, Just email, Just web] -> Success (CreateButton_Hosted_Response (HostedButtonID id) email web)+ _ -> ParseFailure (M.toList m) "missing HOSTEDBUTTONID, EMAILLINK or WEBSITECODE"++deriving instance Show (PayPalResponse (CreateButton HOSTED bt))++instance (ToText (NONHOSTED buttonCode), ButtonType bt) =>+ ToVariables (CreateButton (NONHOSTED buttonCode) bt) where+ toVariables = encodeCreateButtonRequest "BMCreateButton"+instance (ToText (NONHOSTED buttonCode), ButtonType bt) =>+ PayPalRequest (CreateButton (NONHOSTED buttonCode) bt) where+ data PayPalResponse (CreateButton (NONHOSTED buttonCode) bt) =+ CreateButton_NonHosted_Response C.ByteString C.ByteString++ decodeResponse = decodeCreateButtonResponse CreateButton_NonHosted_Response++deriving instance Show (PayPalResponse (CreateButton (NONHOSTED bc) bt))++encodeCreateButtonRequest :: forall buttonCode buttonType . (ToText buttonCode, ButtonType buttonType) =>+ C.ByteString+ -> CreateButton buttonCode buttonType+ -> [(C.ByteString, C.ByteString)]+encodeCreateButtonRequest method cb =+ [("METHOD", method),+ ("BUTTONCODE", toText (undefined :: buttonCode)),+ ("BUTTONTYPE", toText (undefined :: buttonType))] +++ toLButtonVars (+ formatButtonVariables (cbVariables cb) +++ maybeToList (("BUTTONSUBTYPE",) . toText <$> cbButtonSubtype cb) +++ toVariables (cbOptions cb) +++ (case cbButtonImage cb of+ Just (Left imgType) -> [("BUTTONIMAGE", toText imgType)]+ Just (Right url) -> [("BUTTONIMAGEURL", url)]+ Nothing -> []) +++ maybeToList (getButtonText (undefined :: buttonType) (cbButtonText cb)) +++ maybeToList (("BUTTONCOUNTRY",) <$> cbCountry cb) +++ maybeToList (("BUTTONLANGUAGE",) <$> cbLanguage cb) +++ cbExtras cb+ )++data ButtonImageType+ = REG -- ^ Regular (default)+ | SML -- ^ Small+ | CC -- ^ small button image with credit card logos; not applicable for+ -- Unsubscribe or View Cart buttons+ deriving Show++instance ToText ButtonImageType where+ toText REG = "REG"+ toText SML = "SML"+ toText CC = "CC"++instance FromText ButtonImageType where+ fromText "REG" = Just REG+ fromText "SML" = Just SML+ fromText "CC" = Just CC+ fromText _ = Nothing++data BuyNowText+ = BUYNOW_TEXT -- ^ Button text is "Buy Now" (default)+ | PAYNOW_TEXT -- ^ Button text is "Pay Now"+ deriving Show++instance ToText BuyNowText where+ toText BUYNOW_TEXT = "BUYNOW"+ toText PAYNOW_TEXT = "PAYNOW"++instance FromText BuyNowText where+ fromText "BUYNOW" = Just BUYNOW_TEXT+ fromText "PAYNOW" = Just PAYNOW_TEXT+ fromText _ = Nothing++data SubscribeText+ = BUYNOW_SUBSCRIPTION -- ^ Button text is "Buy Now"+ | SUBSCRIBE_SUBSCRIPTION -- ^ Button text is "Subscribe"+ deriving Show++instance ToText SubscribeText where+ toText BUYNOW_SUBSCRIPTION = "BUYNOW"+ toText SUBSCRIBE_SUBSCRIPTION = "SUBSCRIBE"++instance FromText SubscribeText where+ fromText "BUYNOW" = Just BUYNOW_SUBSCRIPTION+ fromText "SUBSCRIBE" = Just SUBSCRIBE_SUBSCRIPTION+ fromText _ = Nothing++data UpdateButton buttonCode buttonType = UpdateButton {+ ubButtonID :: HostedButtonID,+ ubDetails :: CreateButton buttonCode buttonType+ }+deriving instance (Show (Variables buttonType), Show (ButtonText buttonType)) =>+ Show (UpdateButton buttonCode buttonType)++decodeCreateButtonResponse :: PayPalRequest req =>+ (C.ByteString -> C.ByteString -> PayPalResponse req)+ -> Map C.ByteString C.ByteString+ -> Status (PayPalResponse req)+decodeCreateButtonResponse mkResponse m =+ case (`M.lookup` m) <$> ["EMAILLINK", "WEBSITECODE"] of+ [Just email, Just web] -> Success (mkResponse email web)+ _ -> ParseFailure (M.toList m) "missing EMAILLINK or WEBSITECODE"++data ButtonSearch t = ButtonSearch {+ bsStartDate :: t,+ bsEndDate :: Maybe t+ }++data ButtonInfo t = ButtonInfo {+ biButtonType :: TypeOfButton,+ biButtonID :: HostedButtonID,+ biItemName :: C.ByteString,+ biModifyDate :: t+ }+ deriving Show++instance FormatTime t => ToVariables (ButtonSearch t) where+ toVariables bs =+ [("METHOD", "BMButtonSearch"),+ ("STARTDATE", toTextTime . bsStartDate $ bs)] +++ maybeToList (("ENDDATE",) . toTextTime <$> bsEndDate bs)+instance (FormatTime t, ParseTime t) => PayPalRequest (ButtonSearch t) where+ data PayPalResponse (ButtonSearch t) = ButtonSearch_Response [ButtonInfo t]+ decodeResponse m = case dec 0 of+ Right pairs -> Success (ButtonSearch_Response pairs)+ Left err -> err+ where+ dec :: Int -> Either (Status (PayPalResponse (ButtonSearch t))) [ButtonInfo t]+ dec ix =+ case (join $ fromText <$> (mappend "L_BUTTONTYPE" ixS `M.lookup` m),+ HostedButtonID <$> (mappend "L_HOSTEDBUTTONID" ixS `M.lookup` m),+ mappend "L_ITEMNAME" ixS `M.lookup` m,+ join $ fromTextTime <$> (mappend "L_MODIFYDATE" ixS `M.lookup` m)) of+ (Just bt, Just bid, Just iname, Just tmod) ->+ case dec (ix+1) of+ Left err -> Left err+ Right rem -> Right (ButtonInfo bt bid iname tmod : rem)+ (Nothing, Nothing, Nothing, Nothing) -> Right []+ _ -> Left (ParseFailure (M.toList m) "malformed ButtonSearch results")+ where+ ixS = C.pack . show $ ix+deriving instance Show t => Show (PayPalResponse (ButtonSearch t))++data GetButtonDetails = GetButtonDetails {+ gbdButtonID :: HostedButtonID+ }++data HostedButton+ = HostedButton_CART (CreateButton HOSTED CART)+ | HostedButton_GIFTCERTIFICATE (CreateButton HOSTED GIFTCERTIFICATE)+ | HostedButton_SUBSCRIBE (CreateButton HOSTED SUBSCRIBE)+ | HostedButton_DONATE (CreateButton HOSTED DONATE)+ | HostedButton_UNSUBSCRIBE (CreateButton HOSTED UNSUBSCRIBE)+ | HostedButton_VIEWCART (CreateButton HOSTED VIEWCART)+ deriving Show+ {-+ | HostedButton_PAYMENTPLAN+ | HostedButton_AUTOBILLING+ | HostedButton_PAYMENT+ -}++instance ToVariables GetButtonDetails where+ toVariables (GetButtonDetails (HostedButtonID bid)) =+ [("METHOD", "BMGetButtonDetails"),+ ("HOSTEDBUTTONID", bid)]+instance PayPalRequest GetButtonDetails where+ data PayPalResponse GetButtonDetails = GetButtonDetails_Response HostedButton+ decodeResponse m = case decodeButtonDetails m of+ Right button -> Success (GetButtonDetails_Response button)+ Left err -> ParseFailure (M.toList m) err+deriving instance Show (PayPalResponse GetButtonDetails)++decodeButtonDetails :: Map C.ByteString C.ByteString -> Either String HostedButton+decodeButtonDetails m =+ case bt of+ Just "ADDCART" -> HostedButton_CART <$> decode m+ Just "GIFTCERTIFICATE" -> HostedButton_GIFTCERTIFICATE <$> decode m+ Just "SUBSCRIBE" -> HostedButton_SUBSCRIBE <$> decode m+ Just "DONATE" -> HostedButton_DONATE <$> decode m+ Just "UNSUBSCRIBE" -> HostedButton_UNSUBSCRIBE <$> decode m+ Just "VIEWCART" -> HostedButton_VIEWCART <$> decode m+ _ -> Left $ "unexpected BUTTONTYPE: "++show bt+ where+ bt = "BUTTONTYPE" `M.lookup` m+ decode :: forall bt . ButtonType bt =>+ Map C.ByteString C.ByteString -> Either String (CreateButton HOSTED bt)+ decode m = do+ let lVars = fromLButtonVars m+ variables <- parseButtonVariables lVars+ options <- fromVariables m+ return $ CreateButton {+ cbVariables = variables,+ cbButtonSubtype = join $ fromText <$> M.lookup "BUTTONSUBTYPE" m,+ cbOptions = options,+ cbButtonImage = case (M.lookup "BUTTONIMAGE" m, M.lookup "BUTTONIMAGEURL" m) of+ (Just img, _) -> case fromText img of+ Just imgType -> Just (Left imgType)+ Nothing -> Nothing+ (_, Just url) -> Just (Right url)+ _ -> Nothing,+ cbButtonText = setButtonText (undefined :: bt) m,+ cbCountry = M.lookup "BUTTONCOUNTRY" m,+ cbLanguage = M.lookup "BUTTONLANGUAGE" m,+ cbExtras = mapMaybe (\ name -> (name,) <$> M.lookup name m) ["WEBSITECODE", "EMAILLINK"]+ }++{-+ACK=Success+BUILD=1824201+BUTTONCODE=HOSTED+BUTTONCOUNTRY=AU+BUTTONIMAGE=SML+BUTTONLANGUAGE=en+BUTTONSUBTYPE=PRODUCTS+BUTTONTYPE=ADDCART+CORRELATIONID=aac6b648d0581+EMAILLINK=https://www.sandbox.paypal.com/cgi-bin/webscr?cmd=_s-xclick&hosted_button_id=74ZGDF76PF4X6+HOSTEDBUTTONID=74ZGDF76PF4X6+L_BUTTONVAR0="add=1"+L_BUTTONVAR1="bn==TS4LZ7A79FV8C:PP-ShopCartBF_P"+L_BUTTONVAR10="weight=0.5"+L_BUTTONVAR11="weight_unit=kgs"+L_BUTTONVAR12="OPTION0NAME=Size"+L_BUTTONVAR13="L_OPTION0SELECT0=Small"+L_BUTTONVAR14="L_OPTION0PRICE0=2.00"+L_BUTTONVAR15="L_OPTION0SELECT1=Medium"+L_BUTTONVAR16="L_OPTION0PRICE1=2.50"+L_BUTTONVAR17="L_OPTION0SELECT2=Large"+L_BUTTONVAR18="L_OPTION0PRICE2=3.00"+L_BUTTONVAR19="OPTION1NAME=Colour"+L_BUTTONVAR2="shipping=0.45"+L_BUTTONVAR20="L_OPTION1SELECT0=Red"+L_BUTTONVAR21="L_OPTION1SELECT1=Green"+L_BUTTONVAR22="L_OPTION1SELECT2=Blue"+L_BUTTONVAR23="business=TS4LZ7A79FV8C"+L_BUTTONVAR24="currency_code=NZD"+L_BUTTONVAR25="item_name=small button image"+L_BUTTONVAR26="item_number=SML001"+L_BUTTONVAR27="amount=2.50"+L_BUTTONVAR3="tax_rate=0.150"+L_BUTTONVAR4="invoice=000002"+L_BUTTONVAR5="add=1"+L_BUTTONVAR6="paymentaction=sale"+L_BUTTONVAR7="shopping_url=http://hip-to-be-square.com/"+L_BUTTONVAR8="no_note=0"+L_BUTTONVAR9="lc=AU"+TIMESTAMP=2011-04-28T13:13:32Z+VERSION=56.0+WEBSITECODE=<form target="paypal" action="https://www.sandbox.paypal.com/cgi-bin/webscr" method="post">+<input type="hidden" name="cmd" value="_s-xclick">+<input type="hidden" name="hosted_button_id" value="74ZGDF76PF4X6">+<input type="image" src="https://www.sandbox.paypal.com/en_AU/i/btn/btn_cart_SM.gif" border="0" name="submit" alt="PayPal - The safer, easier way to pay online.">+<img alt="" border="0" src="https://www.sandbox.paypal.com/en_AU/i/scr/pixel.gif" width="1" height="1">+</form>+-}+--variablesOf :: Map C.ByteString C.ByteString++{-+data CreateButton buttonCode buttonType = CreateButton {+ cbVariables :: Variables buttonType,+ cbButtonSubtype :: Maybe ButtonSubtype,+ cbOptions :: Options,+ -- | Either the button image type, or the button image URL.+ cbButtonImage :: Maybe (Either ButtonImageType C.ByteString),+ cbButtonText :: ButtonText buttonType,+ cbCountry :: Maybe C.ByteString,+ cbLanguage :: Maybe C.ByteString,+ cbExtras :: [(C.ByteString, C.ByteString)]+ }+-}+
+ Network/PayPal/NVP.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE OverloadedStrings, FlexibleContexts #-}+module Network.PayPal.NVP (+ -- * High-level interface+ Service,+ sandbox,+ live,+ submit,+ -- * Low-level interface+ prepareRequest,+ processResponse+ ) where++import Network.PayPal.Types as PayPal++import Control.Applicative+import Control.Arrow+import Control.Failure+import Control.Monad+import Control.Monad.Trans+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as C+import qualified Data.ByteString.Lazy as L+import Data.Monoid+import Network.HTTP.Enumerator as HTTP+import Network.HTTP.Types as HTTP+import Web.Encodings (decodeUrlPairs)+import System.IO.Unsafe+import Data.Enumerator (Iteratee (..), run_)+import Data.Enumerator.List (consume)+import qualified Network.Wai as W+++-- | A PayPal service.+data Service = Service (HTTP.Request IO) (HTTP.Request IO)++-- | PayPal sandbox.+sandbox :: Service+sandbox = Service+ -- URL for signature security+ (unsafePerformIO $ parseUrl "https://api-3t.sandbox.paypal.com/nvp")+ -- URL for certificate security+ (unsafePerformIO $ parseUrl "https://api.sandbox.paypal.com/nvp")++-- | PayPal live system.+live :: Service+live = Service+ -- URL for signature security+ (unsafePerformIO $ parseUrl "https://api-3t.paypal.com/nvp")+ -- URL for certificate security+ (unsafePerformIO $ parseUrl "https://api.paypal.com/nvp")++-- | Submit a request to PayPal.+submit :: (Failure HttpException m, MonadIO m, PayPalRequest req) =>+ Service+ -> Credentials+ -> req+ -> m (Either Response (PayPal.Status (PayPalResponse req)))+submit service cred req = do+ -- Re-using connections (i.e. not creating a new manager each time) fails with+ -- an exception for some reason:+ --+ -- too few bytes. Failed reading at byte position 1+ mgr <- liftIO newManager+ run_ $ httpRedirect (prepareRequest service cred req) (processResponse req) mgr++-- | Construct an HTTP request for the specified PayPal request.+prepareRequest :: (Monad m, PayPalRequest req) =>+ Service+ -> Credentials+ -> req+ -> HTTP.Request m+prepareRequest (Service url _) (Credentials user pwd (Signature sig) version) req =+ urlEncodedBody vars url+ where+ vars =+ [("USER", user),+ ("PWD", pwd),+ ("VERSION", version),+ ("SIGNATURE", sig)] ++ toVariables req++processResponse :: (PayPalRequest req, Monad m) =>+ req+ -> HTTP.Status+ -> ResponseHeaders+ -> Iteratee B.ByteString m (Either Response (PayPal.Status (PayPalResponse req)))+processResponse req (Status statusCode _) headers = do+ body <- L.fromChunks <$> consume+ return $ case statusCode of+ 200 -> Right . decodeResponseChecking+ . map (textify *** textify)+ . decodeUrlPairs $ body+ _ -> Left $ Response statusCode headers body+ where+ textify = mconcat . L.toChunks+
+ Network/PayPal/Types.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE TypeFamilies, OverloadedStrings, FlexibleInstances,+ UndecidableInstances, GeneralizedNewtypeDeriving #-}+module Network.PayPal.Types (+ -- * Types+ Security(..),+ Credentials(..),+ Status(..),+ -- * Classes+ ToText(..),+ FromText(..),+ ToVariables(..),+ FromVariables(..),+ PayPalRequest(decodeResponse),+ PayPalResponse(..),+ -- * Helpers+ decodeResponseChecking,+ toTextTime,+ fromTextTime+ ) where++import Control.Applicative+import qualified Data.ByteString.Char8 as C+import Data.Map (Map)+import qualified Data.Map as M+import Data.Monoid+import Data.Ratio+import Data.Time.Calendar (Day(..))+import Data.Time.Clock+import Data.Time.Format+import Data.Time.LocalTime (TimeOfDay(..))+import System.Locale (defaultTimeLocale)+import Numeric+++-- | Security. Signature only at present: Certificate security is not yet supported.+data Security = Signature C.ByteString++data Credentials = Credentials {+ crUsername :: C.ByteString,+ crPassword :: C.ByteString,+ crSecurity :: Security,+ crVersion :: C.ByteString -- ^ e.g. "56.0"+ }++-- | Check for errors, then delegate to decodeResponse if there aren't any.+decodeResponseChecking :: PayPalRequest req =>+ [(C.ByteString, C.ByteString)]+ -> Status (PayPalResponse req)+decodeResponseChecking pairs =+ case "ACK" `M.lookup` m of+ Just "Success" -> decodeResponse m+ Just "Failure" -> case messages 0 of+ [] -> noParse+ msgs -> Failure msgs+ _ -> noParse+ where+ m = M.fromList pairs+ noParse = ParseFailure (M.toList m) $ "malformed error message"+ messages i = case (`M.lookup` m) . (`mappend` si) <$>+ ["L_ERRORCODE", "L_SHORTMESSAGE", "L_LONGMESSAGE", "L_SEVERITYCODE"] of+ [Just err, Just short, Just long, Just severity] ->+ case reads (C.unpack err) of+ [(errNo, "")] -> Message errNo short long severity : messages (i+1)+ _ -> []+ _ -> []+ where+ si = C.pack (show i)++data Status res = Success res+ | Failure [Message]+ | ParseFailure [(C.ByteString, C.ByteString)] String+ deriving Show++instance Functor Status where+ f `fmap` Success res = Success (f res)+ f `fmap` Failure msgs = Failure msgs+ f `fmap` ParseFailure pairs descr = ParseFailure pairs descr++-- | ErrorCode ShortMessage LongMessage SeverityCode+data Message = Message Int C.ByteString C.ByteString C.ByteString+ deriving Show++class ToText a where+ toText :: a -> C.ByteString++class FromText a where+ fromText :: C.ByteString -> Maybe a++class ToVariables a where+ toVariables :: a -> [(C.ByteString, C.ByteString)]++class FromVariables a where+ fromVariables :: Map C.ByteString C.ByteString -> Either String a++class ToVariables req => PayPalRequest req where+ data PayPalResponse req :: *+ decodeResponse :: Map C.ByteString C.ByteString -> Status (PayPalResponse req)++instance ToText Double where+ toText dbl = C.pack $ showFFloat Nothing dbl ""++instance FromText Double where+ fromText txt = case reads (C.unpack txt) of+ [(amt, "")] -> Just amt+ _ -> Nothing++instance ToText Int where+ toText = C.pack . show++instance FromText Int where+ fromText txt = case reads (C.unpack txt) of+ [(amt, "")] -> Just amt+ _ -> Nothing++instance ToText (Ratio Integer) where+ toText amt = C.pack $ showFFloat (Just 2) (realToFrac amt) ""++instance FromText (Ratio Integer) where+ fromText txt = case reads (C.unpack txt) of+ [(amt, "")] -> Just $ round ((amt :: Double) * 100) % 100+ _ -> Nothing++defaultTimeFormat :: String+defaultTimeFormat = "%Y-%m-%dT%H:%M:%SZ"++toTextTime :: FormatTime t => t -> C.ByteString+toTextTime = C.pack . formatTime defaultTimeLocale defaultTimeFormat++fromTextTime :: ParseTime t => C.ByteString -> Maybe t+fromTextTime = parseTime defaultTimeLocale defaultTimeFormat . C.unpack+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ example.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where++import qualified Data.ByteString.Char8 as C+import Network.PayPal.ButtonManager+import Data.Ratio+import Data.Time.Calendar+import Data.Time.LocalTime+import Control.Monad+import Network.HTTP.Enumerator (newManager)++me = Credentials {+ crUsername = "your_username_here",+ crPassword = "your_password_here",+ crSecurity = Signature "your_signature_here",+ crVersion = "56.0"+ }++main :: IO ()+main = do+ putStrLn "creating a new non-hosted button..."+ let cb :: CreateButton (NONHOSTED CLEARTEXT) CART+ cb = CreateButton {+ cbVariables = Variables_CART {+ cartItem = Item {+ itAmount = 250 % 100,+ itItemName = Just "small button image",+ itBusiness = Nothing,+ itItemNumber = Just "SML001",+ itQuantity = Nothing,+ itShipping = Just (45 % 100),+ itShipping2 = Nothing,+ itTax = Nothing,+ itTaxRate = Just 0.15,+ itUndefinedQuantity = (),+ itWeight = Just (0.5, Kg)+ },+ cartPayment = Payment {+ payAddressOverride = Nothing,+ payCurrencyCode = Just "NZD",+ payCustom = Nothing,+ payHandling = Nothing,+ payInvoice = Just "000002",+ payTaxCart = Nothing,+ payWeight = Nothing+ },+ cartCart = ShoppingCart {+ caAction = Add,+ caHandlingCart = Nothing,+ caPaymentAction = Sale,+ caShoppingURL = Just "http://hip-to-be-square.com/"+ }+ },+ cbButtonSubtype = Nothing,+ cbOptions = Options $ Just (+ Option "Size" [Select "Small" (Just (200 % 100)),+ Select "Medium" (Just (250 % 100)),+ Select "Large" (Just (300 % 100))],+ [Option "Colour" [Select "Red" (),+ Select "Green" (),+ Select "Blue" ()]]+ ),+ cbButtonImage = Just (Left SML),+ cbButtonText = (),+ cbCountry = Just "BE",+ cbLanguage = Just "fr",+ cbExtras = []+ }+ --print cb+ --print (toVariables cb)+ reply <- submit sandbox me cb+ case reply of+ Right (Success (CreateButton_NonHosted_Response _ html)) -> do+ C.writeFile "test.html" html+ err -> putStrLn $ "FAILED: "++show err++ putStrLn "fetching list of buttons currently hosted at paypal..."+ let bs = ButtonSearch {+ bsStartDate = LocalTime (fromGregorian 2011 1 1) midnight,+ bsEndDate = Nothing+ }+ --print (toVariables bs)+ searchRes <- submit sandbox me bs+ --print searchRes+ case searchRes of+ Right (Success (ButtonSearch_Response items)) ->+ forM_ items $ \item -> do+ print item+ det <- submit sandbox me (GetButtonDetails (biButtonID item))+ print det+ err -> putStrLn $ "FAILED: "++show err+
+ paypal-api.cabal view
@@ -0,0 +1,60 @@+name: paypal-api+version: 0.1+cabal-version: >=1.6+build-type: Simple+license: BSD3+license-file: LICENSE+copyright: Copyright (C) 2011 by Stephen Blackheath+maintainer: http://blacksapphire.com/antispam/+stability: alpha+homepage: http://code.haskell.org/paypal-api/+package-url:+bug-reports:+synopsis: PayPal API, currently supporting "ButtonManager"+description: This package is a moderately successful attempt to tame the confusingness of+ PayPal's API using Haskell types. Currently only the ButtonManager API is+ supported.+ .+ Type families are used extensively to encode PayPal's validation rules,+ so they can be checked at compile time. Haddock doesn't get all the type+ family stuff across, so you may find it easier to read the source code.+ Because PayPal's documents leave you to guessing, it will take trial and+ error to get the logic in this package correct, so please contribute your+ fixes. Code changes to this package are likely to break your code, so please+ depend on a specific version.+ .+ Take a look at example.hs.+ .+ /The benefits of using PayPal:/+ .+ * You can accept credit cards on your website priced for low transaction volumes.+ .+ /The drawbacks of using PayPal:/+ .+ * PayPal tries to harvest your customers, by annoying them into becoming PayPal members.+ .+ * If you are outside the USA, you can't have different shipping rates by country, which is...+ beyond pathetic.+category: Network+author: Stephen Blackheath++Extra-Source-Files:+ example.hs++library+ exposed-modules:+ Network.PayPal.ButtonManager+ Network.PayPal.NVP+ Network.PayPal.Types+ exposed: True+ buildable: True+ build-depends: base >=4 && <5, bytestring -any, containers -any,+ enumerator -any, failure -any, http-enumerator -any,+ http-types -any, monads-fd -any, old-locale -any, text -any,+ time -any, wai -any, web-encodings -any+ ghc-options:+ -fwarn-unused-binds+ -fwarn-incomplete-patterns+ -fwarn-overlapping-patterns+ -fwarn-missing-fields+