{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TemplateHaskell #-} module PayPal.Adaptive.Core where import Prelude hiding (mapM) import Control.Applicative import Control.Exception import Control.Lens hiding ((.=)) 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.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.Wreq -------------------------------------------------- -- Client -------------------------------------------------- data Client = Client { _clAppId :: Text , _clUserId :: Text , _clEnv :: Env , _clPassword :: Text , _clSig :: Text -- | Not needed for authentication, but deposits are sent -- to here and withdrawals are sent from here. Must be the -- email associated with your PayPal app. , _clAccountEmail :: Text } deriving (Eq, Show) data Env = Sandbox | Production deriving (Eq, Show, Read) -------------------------------------------------- -- 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? data AdaptiveErr = AeConnectionErr Text | AeDecodeFailed ByteString Text | AeInvalidCredentials -- ^ Just a wrapper around an AeErrCodes Int. | AeNoSuchEmail -- ^ Just a wrapper around an AeErrCodes Int. Raised when the Deposit -- sender email or the Withdrawal account email doesn't exist. | 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 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 -------------------------------------------------- -- * Payment Responses -------------------------------------------------- -- | Used for forgiving attempts to parse PayPal responses. For instance, -- this library never expects more than one PayInfo. We still try to -- parse them as a list here so we can still sucessfully parse a PayResp -- to use in an 'AdaptiveError' if for some reason more than one 'PayInfo' -- is returned data PayResp = PayResp { _prPayError :: Maybe Text , _prPayExecStatus :: PayExecStatus , _prPayKey :: PayKey , _prPayInfos :: [PayInfo] } deriving (Eq, Show) -- | A version of 'PayResp' for completed transactions. -- -- Status fields are omitted since they should be complete. -- -- Has no separate field for a 'PayInfo' list since successful transactions -- will always have exactly one. Instead the pay info fields have been -- flattened into the top level of this structure. data CompletePayResp = CompletePayResp { _crPayKey :: PayKey , _crReceiver :: Receiver , _crSenderTransactionId :: TransactionId , _crTransactionId :: TransactionId } deriving (Eq, Show) checkComplete :: PayResp -> Either AdaptiveErr CompletePayResp checkComplete pr = do errorFieldNothing pr payExecStatusCompleted pr checkPayKey pr info <- getPayInfo pr sid <- transactionIdJust pr (_piSenderTransactionId info) transactionStatusCompleted pr info tid <- transactionIdJust pr (_piTransactionId info) return $ CompletePayResp (_prPayKey pr) (_piReceiver info) sid tid 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 refers to the processing of this request. To make sure a payment -- has actually gone through, check 'TransactionStatus' instead. -- -- PayPal returns this using the JSON object key "paymentExecStatus" -- in responses to Withdrawal and Deposit and "status" in responses to -- LookupPayment. data PayExecStatus = PeCreated | PeCompleted | PeIncomplete | PeError | PeReversalError | PeProcessing | PePending deriving (Eq, Show, Read) -- | Expires 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 -- | Right toPayPal responses return a PayInfo along with a -- _piTransactionStatus Just, with some exceptions. -- -- 1. Withdrawals to nonexistent accounts return no PayInfos. -- -- 2. Lookups on such transactions return one PayInfo with a -- _piTransactionStatus of Nothing. -- -- 3. Deposits don't return PayInfos. -- -- 4. Lookups on such transactions return one PayInfo with a -- _piTransactionStatus of Nothing. -- -- NOTE: We use the same newtype for both _piSenderTransactionId and -- _piTransactionStatus. They will have different values, but either -- 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 { _reAmount :: Text -- ^ Haven't converted this to Money yet because I'm not sure how -- to determine its currency. , _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) -------------------------------------------------- -- Internal Helpers -------------------------------------------------- -- | "en_US" is hardcoded because it's the only supported error language. requestEnvelope :: Value requestEnvelope = object ["errorLanguage" .= ("en_US" :: Text)] ppPost :: (ToJSON a) => Client -> 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 Sandbox -> "https://svcs.sandbox.paypal.com/AdaptivePayments/" Production -> "https://svcs.paypal.com/AdaptivePayments/" handler :: SomeException -> IO (Either AdaptiveErr (Response ByteString)) 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" ] ppDecode :: Response ByteString -> Either AdaptiveErr PayResp 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 payExecStatusCompleted :: PayResp -> Either AdaptiveErr () payExecStatusCompleted a = case _prPayExecStatus a of PeCompleted -> Right () PeProcessing -> Left $ AePending a PePending -> Left $ AePending a PeError -> Left $ AeRefused a _ -> Left $ AeShouldNotHappen a "unsupported PayExecStatus" -- | TODO: this makes the assumption that an empty PayInfo list means -- the transaction is pending. Is this always right? getPayInfo :: PayResp -> Either AdaptiveErr PayInfo getPayInfo a = case _prPayInfos a of [] -> Left $ AePending a [info] -> Right info _ -> Left $ AeShouldNotHappen a "more than one PayInfo in reponse" transactionStatusCompleted :: PayResp -> PayInfo -> Either AdaptiveErr () transactionStatusCompleted a info = case _piTransactionStatus info of Just TsCompleted -> Right () Just TsPending -> Left $ AePending a Just TsProcessing -> Left $ AePending a Just TsDenied -> Left $ AeRefused a Just TsFailed -> Left $ AeRefused a _ -> Left $ AeShouldNotHappen a "unsupported TransactionStatus" errorFieldNothing :: PayResp -> Either AdaptiveErr () errorFieldNothing a | _prPayError a == Nothing = Right () | otherwise = Left $ AeShouldNotHappen a "PayResp error field is Just in otherwise correct payment" checkPayKey :: PayResp -> Either AdaptiveErr () checkPayKey a | T.null . _unPayKey . _prPayKey $ a = Left $ AeShouldNotHappen a "got a PayKey with length zero" | otherwise = Right () payExecStatusCreated :: PayResp -> Either AdaptiveErr () payExecStatusCreated a = case _prPayExecStatus a of PeCreated -> Right () PeProcessing -> Left $ AePending a PePending -> Left $ AePending a PeError -> Left $ AeRefused a _ -> Left $ AeShouldNotHappen a "unsupported PayExecStatus" noPayInfo :: PayResp -> Either AdaptiveErr () noPayInfo a = case _prPayInfos a of [] -> Right () _ -> Left $ AeShouldNotHappen a "At least one PayInfo present in otherwise successful deposit resp" transactionIdJust :: PayResp -> Maybe TransactionId -> Either AdaptiveErr TransactionId transactionIdJust a Nothing = Left $ AeShouldNotHappen a "expected a Just for Maybe TransactionId" transactionIdJust _ (Just tid) = Right tid $(deriveFromJSON defaultOptions { constructorTagModifier = map toUpper . drop 2 } ''PayExecStatus) $(deriveFromJSON defaultOptions { fieldLabelModifier = (\(x:xs) -> toLower x:xs) . drop 3 } ''PayInfo) $(deriveFromJSON defaultOptions { fieldLabelModifier = (\(x:xs) -> toLower x:xs) . drop 3 } ''Receiver) $(deriveFromJSON defaultOptions { constructorTagModifier = map toUpper . camelTo '_' . drop 2 } ''TransactionStatus)