paypal-api-0.1: Network/PayPal/ButtonManager.hs
{-# 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)]
}
-}