module Web.Stripe.Coupon
( Coupon(..)
, CpnId(..)
, CpnDuration(..)
, CpnPercentOff(..)
, CpnMaxRedeems(..)
, CpnRedeemBy(..)
, createCoupon
, getCoupon
, getCoupons
, delCoupon
, delCouponById
, Count(..)
, Offset(..)
, SConfig(..)
, StripeT(StripeT)
, runStripeT
) where
import Control.Applicative ( (<$>) )
import Control.Monad ( liftM, ap )
import Control.Monad.Error ( MonadIO, throwError, strMsg )
import Data.Char ( toLower )
import Network.HTTP.Types ( StdMethod(..) )
import Text.JSON ( Result(Error), JSON(..), JSValue(JSObject)
, resultToEither, valFromObj
)
import Web.Stripe.Client ( StripeT(..), SConfig(..), SRequest(..), baseSReq
, query, query_, runStripeT
)
import Web.Stripe.Utils ( Count(..), Offset(..), jGet, mjGet, optionalArgs )
data Coupon = Coupon
{ cpnId :: Maybe CpnId
, cpnDuration :: CpnDuration
, cpnPercentOff :: CpnPercentOff
} deriving Show
newtype CpnId = CpnId { unCpnId :: String } deriving Show
data CpnDuration
= Once
| Repeating Int
| Forever
| UnknownDuration String
deriving Show
newtype CpnPercentOff = CpnPercentOff { unCpnPercentOff :: Int } deriving Show
newtype CpnMaxRedeems = CpnMaxRedeems { unCpnMaxRedeems :: Int } deriving Show
newtype CpnRedeemBy = CpnRedeemBy { unCpnRedeemBy :: Int } deriving Show
createCoupon :: MonadIO m => Coupon -> Maybe CpnMaxRedeems -> Maybe CpnRedeemBy
-> StripeT m ()
createCoupon c mmr mrb = query_ (cpnRq []) { sMethod = POST, sData = fdata }
where
fdata = poff:cpnDurationKV (cpnDuration c) ++ optionalArgs odata
poff = ("percent_off", show . unCpnPercentOff . cpnPercentOff $ c)
odata = [ ("id", unCpnId <$> cpnId c)
, ("max_redemptions", show . unCpnMaxRedeems <$> mmr)
, ("redeem_by", show . unCpnRedeemBy <$> mrb)
]
getCoupon :: MonadIO m => CpnId -> StripeT m Coupon
getCoupon (CpnId cid) = return . snd =<< query (cpnRq [cid])
getCoupons :: MonadIO m => Maybe Count -> Maybe Offset -> StripeT m [Coupon]
getCoupons mc mo = do
(_, rsp) <- query (cpnRq []) { sQString = qs }
either err return . resultToEither . valFromObj "data" $ rsp
where
qs = optionalArgs [ ("count", show . unCount <$> mc)
, ("offset", show . unOffset <$> mo)
]
err _ = throwError $ strMsg "Unable to parse coupon list."
delCoupon :: MonadIO m => Coupon -> StripeT m Bool
delCoupon = handleCpnId . cpnId
where
handleCpnId Nothing = throwError $ strMsg "No coupon ID provided."
handleCpnId (Just cid) = delCouponById cid
delCouponById :: MonadIO m => CpnId -> StripeT m Bool
delCouponById (CpnId cid) = query (cpnRq [cid]) { sMethod = DELETE } >>=
either err return . resultToEither . valFromObj "deleted" . snd
where err _ = throwError $ strMsg "Unable to parse coupon delete."
cpnRq :: [String] -> SRequest
cpnRq pcs = baseSReq { sDestination = "coupons":pcs }
cpnDurationKV :: CpnDuration -> [ (String, String) ]
cpnDurationKV d@(Repeating m) = [ ("duration", fromCpnDuration d)
, ("duration_in_months", show m)
]
cpnDurationKV d = [ ("duration", fromCpnDuration d) ]
fromCpnDuration :: CpnDuration -> String
fromCpnDuration Once = "once"
fromCpnDuration (Repeating _) = "repeating"
fromCpnDuration Forever = "forever"
fromCpnDuration (UnknownDuration d) = d
toCpnDuration :: String -> Maybe Int -> CpnDuration
toCpnDuration d Nothing = case map toLower d of
"once" -> Once
"forever" -> Forever
_ -> UnknownDuration d
toCpnDuration d (Just ms) = case map toLower d of
"repeating" -> Repeating ms
_ -> UnknownDuration d
instance JSON Coupon where
readJSON (JSObject c) = do
drn <- jGet c "duration"
drns <- mjGet c "duration_in_months"
Coupon `liftM` (return . Just . CpnId =<< jGet c "id")
`ap` return (toCpnDuration drn drns)
`ap` (return . CpnPercentOff =<< jGet c "percent_off")
readJSON _ = Error "Unable to read Stripe coupon."
showJSON _ = undefined