diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Network/PayPal/ButtonManager.hs b/Network/PayPal/ButtonManager.hs new file mode 100644 --- /dev/null +++ b/Network/PayPal/ButtonManager.hs @@ -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=
+ + + + +
+-} +--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)] + } +-} + diff --git a/Network/PayPal/NVP.hs b/Network/PayPal/NVP.hs new file mode 100644 --- /dev/null +++ b/Network/PayPal/NVP.hs @@ -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 + diff --git a/Network/PayPal/Types.hs b/Network/PayPal/Types.hs new file mode 100644 --- /dev/null +++ b/Network/PayPal/Types.hs @@ -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 + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/example.hs b/example.hs new file mode 100644 --- /dev/null +++ b/example.hs @@ -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 + diff --git a/paypal-api.cabal b/paypal-api.cabal new file mode 100644 --- /dev/null +++ b/paypal-api.cabal @@ -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 +