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
data Client = Client
{ _clAppId :: Text
, _clUserId :: Text
, _clEnv :: Env
, _clPassword :: Text
, _clSig :: Text
, _clAccountEmail :: Text
} deriving (Eq, Show)
data Env = Sandbox | Production deriving (Eq, Show, Read)
data AdaptiveErr
= AeConnectionErr Text
| AeDecodeFailed ByteString Text
| AeInvalidCredentials
| AeNoSuchEmail
| AeErrCodes [Int]
| AePending PayResp
| AeRefused PayResp
| AeShouldNotHappen PayResp Text
deriving (Eq, Show)
instance FromJSON AdaptiveErr where
parseJSON = withObject "error response" $ \o ->
AeErrCodes . V.toList <$> (mapM parseErrId =<< o .: "error")
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
data PayResp = PayResp
{ _prPayError :: Maybe Text
, _prPayExecStatus :: PayExecStatus
, _prPayKey :: PayKey
, _prPayInfos :: [PayInfo]
} deriving (Eq, Show)
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
data PayExecStatus
= PeCreated
| PeCompleted
| PeIncomplete
| PeError
| PeReversalError
| PeProcessing
| PePending
deriving (Eq, Show, Read)
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
data PayInfo = PayInfo
{ _piReceiver :: Receiver
, _piSenderTransactionId :: Maybe TransactionId
, _piTransactionStatus :: Maybe TransactionStatus
, _piTransactionId :: Maybe TransactionId
} deriving (Eq, Show)
data Receiver = Receiver
{ _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)
data Money = USD { _usdCents :: Int } deriving (Eq, Show)
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)
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 ->
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"
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)