module Network.PayPal.ButtonManager (
CreateButton(..),
ButtonSearch(..),
GetButtonDetails(..),
PayPalResponse(..),
HOSTED,
NONHOSTED,
ENCRYPTED,
CLEARTEXT,
TOKEN,
BUYNOW,
CART,
GIFTCERTIFICATE,
SUBSCRIBE,
DONATE,
UNSUBSCRIBE,
VIEWCART,
Item(..),
Subscription(..),
Payment(..),
ShoppingCart(..),
Duration(..),
WeightUnit(..),
ButtonType, Variables(..), Amount, Shipping, UndefinedQuantity,
ButtonSubtype(..),
CartAction(..),
PaymentAction(..),
PeriodicPrice(..),
HostedButtonID(..),
ButtonInfo(..),
TypeOfButton(..),
ButtonImageType(..),
BuyNowText(..),
SubscribeText(..),
HostedButton(..),
UpdateButton(..),
Options(..),
Option(..),
Select(..),
Rank(..),
FIRST,
NONFIRST,
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.Conduit
import Numeric
data HOSTED
instance ToText HOSTED where { toText _ = "HOSTED" }
data NONHOSTED a
data ENCRYPTED
instance ToText (NONHOSTED ENCRYPTED) where { toText _ = "ENCRYPTED" }
data CLEARTEXT
instance ToText (NONHOSTED CLEARTEXT) where { toText _ = "CLEARTEXT" }
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 {
payAddressOverride :: Maybe Bool,
payCurrencyCode :: Maybe C.ByteString,
payCustom :: Maybe C.ByteString,
payHandling :: Maybe Rational,
payInvoice :: Maybe C.ByteString,
payTaxCart :: Maybe Rational,
payWeight :: Maybe (Double, WeightUnit)
}
deriving Show
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 (("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 {
caAction :: CartAction,
caHandlingCart :: Maybe Rational,
--Important:
caPaymentAction :: PaymentAction,
caShoppingURL :: Maybe C.ByteString
}
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 {
ppPrice :: Rational,
ppCycle :: Int,
ppCycleUnits :: Duration
}
deriving Show
data Subscription = Subscription {
suBusiness :: C.ByteString,
suItemName :: Maybe C.ByteString,
suCurrencyCode :: Maybe C.ByteString,
suTrialPeriod :: Maybe (PeriodicPrice, Maybe PeriodicPrice),
suRegularPrice :: PeriodicPrice,
suRecurring :: Maybe (Int, Bool),
suCustom :: Maybe C.ByteString,
suInvoice :: Maybe C.ByteString,
suModification :: Int,
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 {
itAmount :: Amount bt,
itItemName :: Maybe Text,
itBusiness :: Maybe C.ByteString,
itItemNumber :: Maybe C.ByteString,
itQuantity :: Maybe Int,
itShipping :: Shipping bt,
itShipping2 :: Shipping bt,
itTax :: Maybe Rational,
itTaxRate :: Maybe Double,
itUndefinedQuantity :: UndefinedQuantity bt,
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
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
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
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
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)
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)
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)
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)
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)
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)
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
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)
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,
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
| SML
| CC
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
| PAYNOW_TEXT
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
| SUBSCRIBE_SUBSCRIPTION
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
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"]
}