{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Web.PayPal.Adaptive.Core where
import Prelude hiding (mapM)
import Control.Applicative
import Control.Exception
import Control.Lens hiding ((.=))
import Control.Monad ((>=>))
import Data.Aeson
import Data.Aeson.TH hiding (Options)
import Data.Aeson.Types hiding (Options)
import Data.ByteString.Lazy (ByteString)
import Data.Char
import Data.Default
import Data.Maybe
import Data.Monoid
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding
import Data.Text.Read
import Data.Traversable
import qualified Data.Vector as V
import Network.HTTP.Client (HttpException (NoResponseDataReceived))
import Network.Wreq
--------------------------------------------------
-- Client
--------------------------------------------------
data PpClient = PpClient
{ _clAppId :: Text
, _clEnv :: PpEnv
, _clPassword :: Text
, _clSig :: Text
, _clUserId :: Text
} deriving (Eq, Show)
data PpEnv = PpSandbox | PpProduction deriving (Eq, Show, Read)
--------------------------------------------------
-- API class
--------------------------------------------------
class AdaptiveAPI a where
toPayPal :: PpClient -> a -> IO (Either AdaptiveErr PayResp)
-- | Exported by Web.PayPal.Adaptive.Internal
ppPost :: (ToJSON a) => PpClient -> Text -> a -> IO (Either AdaptiveErr (Response ByteString))
ppPost c endpoint p = catch (return . Right =<< runPost) handler
where
runPost :: IO (Response ByteString)
runPost = postWith opts (clBaseUrl <> T.unpack endpoint) (toJSON p)
clBaseUrl :: String
clBaseUrl =
case _clEnv c of
PpSandbox -> "https://svcs.sandbox.paypal.com/AdaptivePayments/"
PpProduction -> "https://svcs.paypal.com/AdaptivePayments/"
handler :: HttpException -> IO (Either AdaptiveErr (Response ByteString))
handler NoResponseDataReceived = return (Left AeNoResponse)
handler e = return . Left . AeConnectionErr . T.pack . show $ e
opts :: Options
opts = defaults
& header "X-PAYPAL-SECURITY-USERID" .~ [ encodeUtf8 (_clUserId c) ]
& header "X-PAYPAL-SECURITY-PASSWORD" .~ [ encodeUtf8 (_clPassword c) ]
& header "X-PAYPAL-SECURITY-SIGNATURE" .~ [ encodeUtf8 (_clSig c) ]
& header "X-PAYPAL-APPLICATION-ID" .~ [ encodeUtf8 (_clAppId c) ]
& header "X-PAYPAL-REQUEST-DATA-FORMAT" .~ [ "JSON" ]
& header "X-PAYPAL-RESPONSE-DATA-FORMAT" .~ [ "JSON" ]
-- | Exported by Web.PayPal.Adaptive.Internal
ppDecode :: (FromJSON a) => Response ByteString -> Either AdaptiveErr a
ppDecode r =
let b = r ^. responseBody
in case eitherDecode b of
Right d -> Right d
Left e -> -- If the response isn't a PayResp, it might be a PayPal error message.
case decode b of
Just (AeErrCodes codes) -> Left $ codeErr codes
_ -> Left $ AeDecodeFailed b (T.pack e)
where
codeErr :: [Int] -> AdaptiveErr
codeErr cs =
if | elem 520003 cs -> AeInvalidCredentials
| elem 589039 cs -> AeNoSuchEmail
| otherwise -> AeErrCodes cs
--------------------------------------------------
-- Errors
--------------------------------------------------
-- | Text is an error message in all the below types.
--
-- AeShouldNotHappen is meant to cover PayPal responses to API requests
-- that this library doesn't support sending in the first place.
-- TODO: is this actually how we're using it?
--
-- AeNoSuchEmail is raised when the CreatePayment sender
-- email doesn't exist.
data AdaptiveErr
= AeNoResponse
| AeConnectionErr Text
| AeDecodeFailed ByteString Text
| AeInvalidCredentials
| AeNoSuchEmail
| AeErrCodes [Int]
| AePending PayResp
| AeRefused PayResp
| AeShouldNotHappen PayResp Text
deriving (Eq, Show)
-- Error responses are what's returned if, e.g., your password is incorrect.
--
-- Here's an example error response. Only the parts we parse are included.
--
-- {
-- "error": [
-- {
-- "errorId": "111111",
-- }
-- ]
-- }
instance FromJSON AdaptiveErr where
parseJSON = withObject "error response" $ \o ->
AeErrCodes . V.toList <$> (mapM parseErrId =<< o .: "error")
-- | Exported by Web.PayPal.Adaptive.Internal
parseErrId :: Value -> Parser Int
parseErrId = withObject "error array item" $ \o -> do
a <- o .: "errorId"
case decimal a of
Left _ -> fail "Could not parse error response code to Int"
Right (b,_) -> return b
--------------------------------------------------
-- Common payload things
--------------------------------------------------
data ReceiverList = ReceiverList
{ _rlAmount :: Money
, _rlEmail :: Text
} deriving (Eq, Show)
instance ToJSON ReceiverList where
toJSON (ReceiverList a e) =
object [ "receiver" .= [ object ["amount" .= m2PayPal a, "email" .= e] ] ]
-- | Exported by Web.PayPal.Adaptive.Internal
--
-- "en_US" is hardcoded because it's the only supported error language.
requestEnvelope :: Value
requestEnvelope = object ["errorLanguage" .= ("en_US" :: Text)]
--------------------------------------------------
-- Send Payment
--------------------------------------------------
-- | Send a single payment from your account.
--
--
-- "Pay" operation docs:
--
--
-- This is a "Simple Payment" which means there's a single sender
-- and receiver (same as CreatePayment).
--
-- It uses the "Implicit" payment approval type, meaning the application
-- making the API call must also be the sender of the payment.
data SendPayment = SendPayment
{ _spReceiverList :: ReceiverList
, _spReturnUrl :: Text
, _spCancelUrl :: Text
, _spSenderEmail :: Text
} deriving (Eq, Show)
instance Default SendPayment where
def = SendPayment
{ _spReceiverList = ReceiverList mempty mempty
, _spReturnUrl = "https://example.com/"
, _spCancelUrl = "https://example.com/cancel"
, _spSenderEmail = mempty
}
instance ToJSON SendPayment where
toJSON p = object
[ "actionType" .= ("PAY" :: Text)
, "currencyCode" .= (m2Currency . _rlAmount . _spReceiverList) p
, "receiverList" .= _spReceiverList p
, "returnUrl" .= _spReturnUrl p
, "cancelUrl" .= _spCancelUrl p
, "requestEnvelope" .= requestEnvelope
, "senderEmail" .= _spSenderEmail p
]
instance AdaptiveAPI SendPayment where
toPayPal c p = (>>= ppDecode >=> ensureSucceeded) <$> ppPost c "Pay" p
where
ensureSucceeded :: PayResp -> Either AdaptiveErr PayResp
ensureSucceeded a =
case _prPayExecStatus a of
PeProcessing -> Left $ AePending a
PePending -> Left $ AePending a
PeError -> Left $ AeRefused a
PeCompleted ->
let infos = _prPayInfo a
in if length infos /= 1
then Left $ AeShouldNotHappen a "sendPayment expects one PayInfo in reponse"
else
let info = head infos
in case _piTransactionStatus info of
Just TsCompleted -> Right a
Just TsPending -> Left $ AePending a
Just TsProcessing -> Left $ AePending a
Just TsDenied -> Left $ AeRefused a
Just TsFailed -> Left $ AeRefused a
_ -> Left $ AeShouldNotHappen a "got unsupported TransactionStatus"
_ -> Left $ AeShouldNotHappen a "got unsupported PayExecStatus"
--------------------------------------------------
-- Create Payment
--------------------------------------------------
-- | Start the process of someone paying you. You have to redirect the payer's
-- browser to PayPal to finish it.
--
--
-- "Pay" operation docs:
--
--
-- This is a "Simple Payment" which means there's a single sender
-- and receiver (same as SendPayment).
--
-- It uses the "Explicit" payment approval type, meaning the payer must go to
-- PayPal in their browser to approve the payment. Here's an example payment
-- approval URL with a PayKey of "foo":
--
-- https://www.paypal.com/cgi-bin/webscr?cmd=_ap-payment&paykey=foo
data CreatePayment = CreatePayment
{ _cpReceiverList :: ReceiverList
, _cpReturnUrl :: Text
, _cpCancelUrl :: Text
, _cpSenderEmail :: Text
} deriving (Eq, Show)
instance Default CreatePayment where
def = CreatePayment
{ _cpReceiverList = ReceiverList mempty mempty
, _cpReturnUrl = "https://example.com/"
, _cpCancelUrl = "https://example.com/cancel"
, _cpSenderEmail = mempty
}
instance ToJSON CreatePayment where
toJSON p = object
[ "actionType" .= ("PAY" :: Text)
, "currencyCode" .= (m2Currency . _rlAmount . _cpReceiverList) p
, "receiverList" .= _cpReceiverList p
, "returnUrl" .= _cpReturnUrl p
, "cancelUrl" .= _cpCancelUrl p
, "requestEnvelope" .= requestEnvelope
, "senderEmail" .= _cpSenderEmail p
]
instance AdaptiveAPI CreatePayment where
toPayPal c p = (>>= ppDecode >=> ensureSucceeded) <$> ppPost c "Pay" p
where
ensureSucceeded :: PayResp -> Either AdaptiveErr PayResp
ensureSucceeded a =
case _prPayExecStatus a of
PeCreated -> Right a
PeProcessing -> Left $ AePending a
PePending -> Left $ AePending a
PeError -> Left $ AeRefused a
_ -> Left $ AeShouldNotHappen a "got unsupported PayExecStatus"
approvalUrl :: PpClient -> PayKey -> Text
approvalUrl c k =
case _clEnv c of
PpSandbox ->
"https://www.sandbox.paypal.com/cgi-bin/webscr?cmd=_ap-payment&paykey="
<> _unPayKey k
PpProduction ->
"https://www.paypal.com/cgi-bin/webscr?cmd=_ap-payment&paykey="
<> _unPayKey k
--------------------------------------------------
-- Lookup Payment
--------------------------------------------------
-- | Lookup information about a payment.
--
--
data LookupPayment a where
LookupTrID :: TransactionId -> LookupPayment TransactionId
LookupPayKey :: PayKey -> LookupPayment PayKey
instance ToJSON (LookupPayment a) where
toJSON (LookupTrID (TransactionId p)) =
object [ "transactionId" .= p
, "requestEnvelope" .= requestEnvelope
]
toJSON (LookupPayKey (PayKey p)) =
object [ "payKey" .= p
, "requestEnvelope" .= requestEnvelope
]
instance AdaptiveAPI (LookupPayment a) where
toPayPal c p = (>>= ppDecode) <$> ppPost c "PaymentDetails" p
--------------------------------------------------
-- Payment Responses
--------------------------------------------------
data PayResp = PayResp
{ _prPayError :: Maybe Text -- Nothing for all Right responses
, _prPayExecStatus :: PayExecStatus
, _prPayKey :: PayKey
, _prPayInfo :: [PayInfo] -- Empty in CreatePayment responses
} deriving (Eq, Show)
instance FromJSON PayResp where
parseJSON = withObject "PayResp" $ \o -> do
e <- o .:? "payErrorList"
k <- o .: "payKey"
s <- o .:? "paymentExecStatus"
s' <- o .:? "status"
status <- maybe (fail "no paymentExecStatus or status") return (if isJust s then s else s')
a <- o .:? "paymentInfoList"
case a of
Nothing -> return $ PayResp e status k mempty
Just v -> do
infos <- v .:? "paymentInfo" .!= mempty
return $ PayResp e status k infos
-- | This is "paymentExecStatus" in responses to sendPayment and createPayment.
-- It's called "status" in responses to lookupPayment.
data PayExecStatus
= PeCreated
| PeCompleted
| PeIncomplete
| PeError
| PeReversalError
| PeProcessing
| PePending
deriving (Eq, Show, Read)
-- | Defaults to expiring after three hours:
--
--
newtype PayKey = PayKey { _unPayKey :: Text } deriving (Eq, Show)
instance FromJSON PayKey where
parseJSON = withText "PayKey" $ return . PayKey
instance ToJSON PayKey where
toJSON (PayKey a) = toJSON a
-- | All the API calls we support return a PayInfo along with three Justs, with two
-- exceptions.
--
-- 1. toPayPal CreatePayment returns no PayInfo at all.
--
-- 2. toPayPal LookupPayment on such a payment does return a PayInfo, but with
-- three Nothings.
--
-- NOTE: _piSenderTransactionId and _piTransactionStatus will be different, but
-- both can be used to look up a payment.
data PayInfo = PayInfo
{ _piReceiver :: Receiver
, _piSenderTransactionId :: Maybe TransactionId
, _piTransactionStatus :: Maybe TransactionStatus
, _piTransactionId :: Maybe TransactionId
} deriving (Eq, Show)
data Receiver = Receiver
-- Haven't converted this to Money yet because I'm not sure how
-- to determine its currency.
{ _reAmount :: Text
, _reEmail :: Text
, _reAccountId :: Text
} deriving (Eq, Show)
newtype TransactionId = TransactionId { _unTransactionId :: Text } deriving (Eq, Show)
instance FromJSON TransactionId where
parseJSON = withText "TransactionId" $ return . TransactionId
instance ToJSON TransactionId where
toJSON (TransactionId a) = toJSON a
data TransactionStatus
= TsCompleted
| TsPending
| TsCreated
| TsPartiallyRefunded
| TsDenied
| TsProcessing
| TsReversed
| TsRefunded
| TsFailed
deriving (Eq, Show, Read)
--------------------------------------------------
-- Money
--------------------------------------------------
data Money = USD { _usdCents :: Int } deriving (Eq, Show)
-- NOTE: Once we add more currencies this instance will violate the
-- Monoid laws.
instance Monoid Money where
mempty = USD 0
mappend (USD c1) (USD c2) = USD $ c1 + c2
m2Currency :: Money -> Text
m2Currency (USD _) = "USD"
m2PayPal :: Money -> String
m2PayPal (USD c) =
let s = show (abs c)
a = case length s of
0 -> "0.00"
1 -> "0.0" <> s
2 -> "0." <> s
_ -> tailInsert 2 '.' s
in if c < 0 then '-':a else a
where
tailInsert :: Int -> a -> [a] -> [a]
tailInsert i x xs =
let (ys, zs) = splitAt i (reverse xs)
in reverse (ys <> pure x <> zs)
$(deriveFromJSON defaultOptions { fieldLabelModifier = (\(x:xs) -> toLower x:xs) . drop 3 } ''PayInfo)
$(deriveFromJSON defaultOptions { constructorTagModifier = map toUpper . drop 2 } ''PayExecStatus)
$(deriveFromJSON defaultOptions { fieldLabelModifier = (\(x:xs) -> toLower x:xs) . drop 3 } ''Receiver)
$(deriveFromJSON defaultOptions { constructorTagModifier = map toUpper . camelTo '_' . drop 2 } ''TransactionStatus)
$(makePrisms ''AdaptiveErr)
$(makeLenses ''PpClient)
$(makeLenses ''CreatePayment)
$(makePrisms ''PpEnv)
$(makePrisms ''PayExecStatus)
$(makeLenses ''PayInfo)
$(makeLenses ''PayResp)
$(makeLenses ''Receiver)
$(makeLenses ''ReceiverList)
$(makeLenses ''SendPayment)
$(makePrisms ''TransactionId)
$(makePrisms ''TransactionStatus)