diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) 2014, Prowdsponsor +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, this + list of conditions and the following disclaimer in the documentation and/or + other materials provided with the distribution. + +* Neither the name of the Prowdsponsor nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON +ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/exe/Main.hs b/exe/Main.hs new file mode 100644 --- /dev/null +++ b/exe/Main.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Web.MangoPay + +import Data.Aeson +import Data.Text +import Network.HTTP.Conduit + +import System.Environment (getArgs) +import qualified Data.ByteString.Lazy as BS +import Data.Maybe (fromJust) + +-- | get a new secret from the given client id and name +-- shows the secret on standard out +-- write the credentials in a JSON file called client.conf in current directory +main :: IO() +main = do + args<-getArgs + case args of + [cid,name,email]->do + let cred=Credentials (pack cid) (pack name) (pack email) Nothing + cred2<-withManager (\mgr-> + runMangoPayT cred mgr Sandbox createCredentialsSecret) + putStrLn $ unpack $ fromJust $ cClientSecret cred2 + BS.writeFile "client.conf" $ encode cred2 + return () + _ -> putStrLn "Usage: mangopay-passphrase clientid name email" diff --git a/mangopay.cabal b/mangopay.cabal new file mode 100644 --- /dev/null +++ b/mangopay.cabal @@ -0,0 +1,146 @@ +name: mangopay +version: 1.0 +cabal-version: >= 1.8 +build-type: Simple +author: JP Moresmau +license: BSD3 +license-file: LICENSE +copyright: (c) 2014 Prowdsponsor +category: Web +homepage: https://github.com/prowdsponsor/mangopay +maintainer: Prowdsponsor +synopsis: Bindings to the MangoPay API + +description: + This package provides Haskell bindings to the + payment provider. + . + See also the @yesod-mangopay@ package. + +source-repository head + type: git + location: git://github.com/prowdsponsor/mangopay.git + +flag debug + default: False + description: Print debugging info. + +library + hs-source-dirs: src + build-depends: + base >= 4 && < 5 + , bytestring >= 0.9 && < 0.11 + , text == 0.11.* + , transformers >= 0.2 && < 0.4 + , transformers-base + , monad-control + , resourcet + , conduit == 1.0.* + , http-types + , http-conduit == 2.0.* + , attoparsec >= 0.10 && < 0.12 + , attoparsec-conduit == 1.0.* + , aeson >= 0.5 && < 0.8 + , time + , data-default + , lifted-base + , unordered-containers + , base16-bytestring + , utf8-string >=0.3.7 && <0.4 + , base64-bytestring >=1.0.0 && <1.1 + , case-insensitive >=1.1.0 && <1.2 + ghc-options: -Wall + other-modules: + Web.MangoPay.Access, + Web.MangoPay.Events, + Web.MangoPay.Monad, + Web.MangoPay.Types, + Web.MangoPay.Users, + Web.MangoPay.Wallets, + Web.MangoPay.Documents, + Web.MangoPay.Payins, + Web.MangoPay.Cards, + Web.MangoPay.Refunds, + Web.MangoPay.Payouts, + Web.MangoPay.Accounts + + if flag(debug) + cpp-options: -DDEBUG + exposed-modules: Web.MangoPay + +executable mangopay-passphrase + build-depends: + base >= 4 + , mangopay + , bytestring >= 0.9 && < 0.11 + , text == 0.11.* + , transformers >= 0.2 && < 0.4 + , transformers-base + , monad-control + , resourcet + , conduit == 1.0.* + , http-types + , http-conduit == 2.0.* + , attoparsec >= 0.10 && < 0.12 + , attoparsec-conduit == 1.0.* + , aeson >= 0.5 && < 0.8 + , time + , data-default + , lifted-base + , unordered-containers + , base16-bytestring + , utf8-string >=0.3.7 && <0.4 + , case-insensitive >=1.1.0 && <1.2 + ghc-options: -Wall -rtsopts + hs-source-dirs: exe + main-is: Main.hs + if flag(debug) + cpp-options: -DDEBUG + +test-suite mangopay-tests + type: exitcode-stdio-1.0 + main-is: mangopay-tests.hs + ghc-options: -Wall -rtsopts -threaded + build-depends: + base >= 4, HTF > 0.9 + , mangopay + , bytestring >= 0.9 && < 0.11 + , text == 0.11.* + , transformers >= 0.2 && < 0.4 + , transformers-base + , monad-control + , resourcet + , conduit == 1.0.* + , http-types + , http-conduit == 2.0.* + , attoparsec >= 0.10 && < 0.12 + , attoparsec-conduit == 1.0.* + , aeson >= 0.5 && < 0.8 + , time + , data-default + , lifted-base + , unordered-containers + , base16-bytestring + , HUnit >=1.2.5 && <1.3 + , utf8-string >=0.3.7 && <0.4 + , blaze-builder >=0.3.1 && <0.4 + , warp + , wai + , base64-bytestring >=1.0.0 && <1.1 + , case-insensitive >=1.1.0 && <1.2 + other-modules: + Web.MangoPay.UsersTest, + Web.MangoPay.TestUtils, + Web.MangoPay.WalletsTest, + Web.MangoPay.AccessTest, + Web.MangoPay.DocumentsTest, + Web.MangoPay.PayinsTest, + Web.MangoPay.CardsTest, + Web.MangoPay.RefundsTest, + Web.MangoPay.AccountsTest, + Web.MangoPay.PayoutsTest + hs-source-dirs: + test, + src + if flag(debug) + cpp-options: -DDEBUG diff --git a/src/Web/MangoPay.hs b/src/Web/MangoPay.hs new file mode 100644 --- /dev/null +++ b/src/Web/MangoPay.hs @@ -0,0 +1,148 @@ +-- | API entry point +module Web.MangoPay ( + -- generic functions + MangoPayT + ,runMangoPayT + ,runResourceInMp + ,MpException + ,getAll + + -- useful types + ,Credentials(..) + ,AccessPoint(..) + ,AccessToken(..) + ,OAuthToken(..) + ,Pagination(..) + ,PagedList(..) + + -- access + ,createCredentialsSecret + ,oauthLogin + ,toAccessToken + + -- Users + ,NaturalUser(..) + ,IncomeRange(..) + ,NaturalUserID + ,LegalUser(..) + ,LegalUserType(..) + ,LegalUserID + ,UserRef(..) + ,PersonType(..) + ,AnyUserID + ,storeNaturalUser + ,fetchNaturalUser + ,storeLegalUser + ,fetchLegalUser + ,getUser + ,listUsers + + -- Wallets + ,Wallet(..) + ,Amount(..) + ,WalletID + ,Currency + ,storeWallet + ,fetchWallet + ,listWallets + ,Transfer(..) + ,TransferID + ,TransferStatus(..) + ,Transaction(..) + ,TransactionID + ,TransactionType(..) + ,TransactionNature(..) + ,createTransfer + ,fetchTransfer + ,listTransactions + ,listTransactionsForUser + + -- Events and Hooks + ,Event(..) + ,EventType(..) + ,EventSearchParams(..) + ,searchEvents + ,HookStatus(..) + ,HookValidity(..) + ,HookID + ,Hook(..) + ,storeHook + ,fetchHook + ,listHooks + ,eventFromQueryString + ,eventFromQueryStringT + + -- Documents and pages + ,Document(..) + ,DocumentID + ,DocumentType(..) + ,DocumentStatus(..) + ,storeDocument + ,fetchDocument + ,storePage + + -- Accounts + ,BankAccount(..) + ,BankAccountID + ,BankAccountDetails(..) + ,PaymentType(..) + ,storeAccount + ,fetchAccount + ,listAccounts + + -- Payins + ,PaymentExecution(..) + ,BankWireID + ,BankWire(..) + ,storeBankWire + ,fetchBankWire + ,mkBankWire + ,CardPayinID + ,CardPayin(..) + ,storeCardPayin + ,fetchCardPayin + ,mkCardPayin + + -- Payouts + ,PayoutID + ,Payout(..) + ,mkPayout + ,storePayout + ,fetchPayout + + -- Cards + ,CardRegistration(..) + ,CardRegistrationID + ,CardID + ,CardInfo(..) + ,Card(..) + ,CardValidity(..) + ,mkCardRegistration + ,storeCardRegistration + ,registerCard + ,fullRegistration + ,fetchCard + ,listCards + + -- Refunds + ,RefundID + ,Refund(..) + ,RefundRequest(..) + ,refundTransfer + ,refundPayin + ,fetchRefund +) +where + +import Web.MangoPay.Access +import Web.MangoPay.Accounts +import Web.MangoPay.Cards +import Web.MangoPay.Documents +import Web.MangoPay.Events +import Web.MangoPay.Monad +import Web.MangoPay.Payins +import Web.MangoPay.Payouts +import Web.MangoPay.Refunds +import Web.MangoPay.Users +import Web.MangoPay.Types +import Web.MangoPay.Wallets diff --git a/src/Web/MangoPay/Access.hs b/src/Web/MangoPay/Access.hs new file mode 100644 --- /dev/null +++ b/src/Web/MangoPay/Access.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE FlexibleContexts, OverloadedStrings #-} +-- | access methods for login, creating clients... +module Web.MangoPay.Access +( +createCredentialsSecret +,oauthLogin +) +where + +import Web.MangoPay.Monad +import Web.MangoPay.Types + +import Data.Conduit +import Data.Text + +import Network.HTTP.Conduit (applyBasicAuth) +import Control.Monad (liftM) +import qualified Network.HTTP.Types as HT +import qualified Data.Text.Encoding as TE +import Data.Maybe (isNothing) + +-- | populate the passphrase for our clientId IFF we don't have one +createCredentialsSecret :: (MonadBaseControl IO m, MonadResource m) => MangoPayT m Credentials +createCredentialsSecret =do + creds<- getCreds + if isNothing $ cClientSecret creds + then postExchange "/v2/clients" Nothing creds + else return creds + +-- | login with given user name and password +-- returns the OAuth token that can be used to generate the opaque AccessToken and carries the expiration delay +oauthLogin :: (MonadBaseControl IO m, MonadResource m) => Text -> Text -> MangoPayT m OAuthToken +oauthLogin user pass = do + req<- liftM (applyBasicAuth (TE.encodeUtf8 user) (TE.encodeUtf8 pass)) $ getPostRequest "/v2/oauth/token" Nothing ([("grant_type",Just "client_credentials")]::HT.Query) + getJSONResponse req diff --git a/src/Web/MangoPay/Accounts.hs b/src/Web/MangoPay/Accounts.hs new file mode 100644 --- /dev/null +++ b/src/Web/MangoPay/Accounts.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, OverloadedStrings, FlexibleContexts, FlexibleInstances, PatternGuards #-} +-- | handle bank accounts +module Web.MangoPay.Accounts where + +import Web.MangoPay.Monad +import Web.MangoPay.Types +import Web.MangoPay.Users + +import Data.Conduit +import Data.Text +import Data.Typeable (Typeable) +import Data.Aeson +import Data.Aeson.Types +import Data.Time.Clock.POSIX (POSIXTime) +import Control.Applicative +import qualified Network.HTTP.Types as HT + +-- | create an account +storeAccount :: (MonadBaseControl IO m, MonadResource m) => BankAccount -> AccessToken -> MangoPayT m BankAccount +storeAccount ba at + | Just uid<-baUserId ba= do + url<-getClientURLMultiple ["/users/",uid,"/bankaccounts/",typeName $ baDetails ba] + postExchange url (Just at) ba + | otherwise=error "no user provided for account" + +-- | fetch an account from its ID +fetchAccount :: (MonadBaseControl IO m, MonadResource m) => AnyUserID -> BankAccountID -> AccessToken -> MangoPayT m BankAccount +fetchAccount uid aid at=do + url<-getClientURLMultiple ["/users/",uid,"/bankaccounts/",aid] + req<-getGetRequest url (Just at) ([]::HT.Query) + getJSONResponse req + +-- | list all accounts for a given user +listAccounts :: (MonadBaseControl IO m, MonadResource m) => AnyUserID -> Maybe Pagination -> AccessToken -> MangoPayT m (PagedList BankAccount) +listAccounts uid mp at=do + url<-getClientURLMultiple ["/users/",uid,"/bankaccounts/"] + req<-getGetRequest url (Just at) (paginationAttributes mp) + getJSONList req + +-- | account details, depending on the type +data BankAccountDetails=IBAN { + atIBAN :: Text + ,atBIC :: Text + } | GB { + atAccountNumber :: Text + ,atSortCode :: Text + } | US { + atAccountNumber :: Text + ,atABA :: Text + } | CA { + atAccountNumber :: Text + ,atBankName :: Text + ,atInstitutionNumber :: Text + ,atBranchCode :: Text + } | Other { + atAccountNumber :: Text + ,atBIC :: Text + ,atCountry :: Text + } deriving (Show,Read,Eq,Ord,Typeable) + +-- | from json as per MangoPay format +instance FromJSON BankAccountDetails where + parseJSON (Object v) =do + typ<-v .: "Type" + case typ of + "IBAN"->IBAN <$> + v .: "IBAN" <*> + v .: "BIC" + "GB"->GB <$> + v .: "AccountNumber" <*> + v .: "SortCode" + "US"->US <$> + v .: "AccountNumber" <*> + v .: "ABA" + "CA"->CA <$> + v .: "AccountNumber" <*> + v .: "BankName" <*> + v .: "InstitutionNumber" <*> + v .: "BranchCode" + "OTHER"->Other <$> + v .: "AccountNumber" <*> + v .: "BIC" <*> + v .: "Country" + _->fail $ "BankAccountDetails: unknown type:" ++ typ + parseJSON _=fail "BankAccountDetails" + +-- | type name for details +typeName :: BankAccountDetails -> Text +typeName (IBAN {})="IBAN" +typeName (GB {})="GB" +typeName (US {})="US" +typeName (CA {})="CA" +typeName (Other {})="OTHER" + +-- | the details attribute to be added to the account object +toJSONPairs :: BankAccountDetails -> [Pair] +toJSONPairs (IBAN iban bic)=["IBAN" .= iban,"BIC" .= bic] +toJSONPairs (GB nb sc)=["AccountNumber" .= nb,"SortCode" .= sc] +toJSONPairs (US nb aba)=["AccountNumber" .= nb,"ABA" .= aba] +toJSONPairs (CA nb bn inb bc)=["AccountNumber" .= nb,"BankName" .= bn,"InstitutionNumber" .= inb, "BranchCode" .= bc] +toJSONPairs (Other nb bic c)=["AccountNumber" .= nb,"BIC" .= bic,"Country" .= c] + +-- | ID of a bank account +type BankAccountID = Text + +-- | bank account details +data BankAccount = BankAccount { + baId :: Maybe BankAccountID + ,baCreationDate :: Maybe POSIXTime + ,baUserId :: Maybe AnyUserID + ,baTag :: Maybe Text + ,baDetails :: BankAccountDetails + ,baOwnerName :: Text + ,baOwnerAddress :: Maybe Text +} deriving (Show,Eq,Ord,Typeable) + +-- | to json as per MangoPay format +instance ToJSON BankAccount where + toJSON ba=object $ ["OwnerName" .= baOwnerName ba,"Type" .= typeName (baDetails ba) + ,"OwnerAddress" .= baOwnerAddress ba, "UserId" .= baUserId ba, "Tag" .= baTag ba] + ++ toJSONPairs (baDetails ba) + +-- | from json as per MangoPay format +instance FromJSON BankAccount where + parseJSON o@(Object v) = + BankAccount <$> + v .:? "Id" <*> + v .:? "CreationDate" <*> + v .:? "UserId" <*> + v .:? "Tag" <*> + parseJSON o <*> + v .: "OwnerName" <*> + v .:? "OwnerAddress" + parseJSON _=fail "BankAccount" + +-- | type of payment +data PaymentType = CARD | BANK_WIRE | AUTOMATIC_DEBIT | DIRECT_DEBIT + deriving (Show,Read,Eq,Ord,Bounded,Enum,Typeable) + +-- | to json as per MangoPay format +instance ToJSON PaymentType where + toJSON =toJSON . show + +-- | from json as per MangoPay format +instance FromJSON PaymentType where + parseJSON (String s) + | ((a,_):_)<-reads $ unpack s=pure a + parseJSON _ =fail "PaymentType" diff --git a/src/Web/MangoPay/Cards.hs b/src/Web/MangoPay/Cards.hs new file mode 100644 --- /dev/null +++ b/src/Web/MangoPay/Cards.hs @@ -0,0 +1,203 @@ +{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, OverloadedStrings, FlexibleContexts, FlexibleInstances, PatternGuards #-} +-- | handle cards +module Web.MangoPay.Cards where + +import Web.MangoPay.Documents +import Web.MangoPay.Monad +import Web.MangoPay.Types +import Web.MangoPay.Users + +import Data.Conduit +import Data.Text +import Data.Typeable (Typeable) +import Data.Aeson +import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime) +import Control.Applicative +import qualified Network.HTTP.Types as HT + +import qualified Network.HTTP.Conduit as H +import Control.Monad.IO.Class (liftIO) +import qualified Data.Conduit.List as EL (consume) +import qualified Data.Text.Encoding as TE +import qualified Data.ByteString as BS + +import qualified Data.HashMap.Lazy as HM +import Control.Exception.Base (throw) + +-- | card registration ID +type CardRegistrationID=Text + +-- | perform the full registration of a card +fullRegistration :: (MonadBaseControl IO m, MonadResource m) => AnyUserID -> Currency -> CardInfo -> AccessToken -> MangoPayT m CardRegistration +fullRegistration uid currency cardInfo at=do + -- create registration + let cr1=mkCardRegistration uid currency + cr2<-storeCardRegistration cr1 at + -- register it + cr3<-registerCard cardInfo cr2 + -- save registered version + storeCardRegistration cr3 at + + +-- | create or edit a card registration +storeCardRegistration :: (MonadBaseControl IO m, MonadResource m) => CardRegistration -> AccessToken -> MangoPayT m CardRegistration +storeCardRegistration cr at= + case crId cr of + Nothing-> do + url<-getClientURL "/cardregistrations" + postExchange url (Just at) cr + Just i-> do + url<-getClientURLMultiple ["/cardregistrations/",i] + let Object m=toJSON cr + putExchange url (Just at) $ Object $ HM.filterWithKey (\k _->k=="RegistrationData") m + +-- | credit card information +data CardInfo = CardInfo { + ciNumber :: Text + ,ciExpire :: Text + ,ciCSC :: Text + } deriving (Show,Read,Eq,Ord,Typeable) + +-- | register a card with the registration URL +registerCard :: (MonadBaseControl IO m, MonadResource m) => CardInfo -> CardRegistration -> MangoPayT m CardRegistration +registerCard ci cr | + Just url <- crCardRegistrationURL cr, + Just pre <- crPreregistrationData cr, + Just ak <- crAccessKey cr=do + req <-liftIO $ H.parseUrl $ unpack url + mgr<-getManager + let b=HT.renderQuery False $ HT.toQuery [ + "accessKeyRef" ?+ ak + ,"data" ?+ pre + ,"cardNumber" ?+ ciNumber ci + ,"cardExpirationDate" ?+ ciExpire ci + ,"cardCvx" ?+ ciCSC ci] + let req'=req {H.method=HT.methodPost + , H.requestHeaders=[("content-type","application/x-www-form-urlencoded")] + , H.requestBody=H.RequestBodyBS b} + res<- H.http req' mgr + reg <- H.responseBody res $$+- EL.consume + let t=TE.decodeUtf8 $ BS.concat reg + if "data=" `isPrefixOf` t + then return cr{crRegistrationData=Just t} + else do + pt<-liftIO getPOSIXTime + throw $ MpAppException $ MpError "" "RegistrationError" t $ Just pt +registerCard _ _=do + pt<-liftIO getPOSIXTime + throw $ MpAppException $ MpError "" "IllegalState" "CardRegistration not ready" $ Just pt + +-- | helper function to create a new card registration +mkCardRegistration :: AnyUserID -> Currency -> CardRegistration +mkCardRegistration uid currency=CardRegistration Nothing Nothing Nothing uid currency Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + +-- | a card registration +data CardRegistration = CardRegistration { + crId :: Maybe CardRegistrationID -- ^ The Id of the object + ,crCreationDate :: Maybe POSIXTime -- ^ The creation date of the object + ,crTag :: Maybe Text -- ^ Custom data + ,crUserId :: AnyUserID -- ^ The ID of the author + ,crCurrency :: Currency -- ^ The currency of the card registrated + ,crAccessKey :: Maybe Text -- ^ This key has to be sent with the card details and the PreregistrationData + ,crPreregistrationData :: Maybe Text -- ^ This passphrase has to be sent with the card details and the AccessKey + ,crCardRegistrationURL :: Maybe Text -- ^ The URL where to POST the card details, the AccessKey and PreregistrationData + ,crRegistrationData :: Maybe Text -- ^ You get the CardRegistrationData once you posted the card details, the AccessKey and PreregistrationData + ,crCardType :: Maybe Text -- ^ « CB_VISA_MASTERCARD » is the only value available yet + ,crCardId :: Maybe CardID -- ^ You get the CardId (to process payments) once you edited the CardRegistration Object with the RegistrationData + ,crResultCode :: Maybe Text -- ^ The result code of the object + ,crResultMessage :: Maybe Text -- ^ The message explaining the result code + ,crStatus :: Maybe DocumentStatus -- ^ The status of the object. +} deriving (Show,Eq,Ord,Typeable) + + +-- | to json as per MangoPay format +instance ToJSON CardRegistration where + toJSON cr=object ["Tag" .= crTag cr,"UserId" .= crUserId cr + ,"Currency" .= crCurrency cr,"RegistrationData" .= crRegistrationData cr + ,"CardRegistrationURL" .= crCardRegistrationURL cr] + +-- | from json as per MangoPay format +instance FromJSON CardRegistration where + parseJSON (Object v) =CardRegistration <$> + v .: "Id" <*> + v .: "CreationDate" <*> + v .:? "Tag" <*> + v .: "UserId" <*> + v .: "Currency" <*> + v .:? "AccessKey" <*> + v .:? "PreregistrationData" <*> + v .:? "CardRegistrationURL" <*> + v .:? "RegistrationData" <*> + v .:? "CardType" <*> + v .:? "CardId" <*> + v .:? "ResultCode" <*> + v .:? "ResultMessage" <*> + v .:? "Status" + parseJSON _=fail "CardRegistration" + +-- | fetch a card from its ID +fetchCard :: (MonadBaseControl IO m, MonadResource m) => CardID -> AccessToken -> MangoPayT m Card +fetchCard cid at=do + url<-getClientURLMultiple ["/cards/",cid] + req<-getGetRequest url (Just at) ([]::HT.Query) + getJSONResponse req + +-- | list all cards for a given user +listCards :: (MonadBaseControl IO m, MonadResource m) => AnyUserID -> Maybe Pagination -> AccessToken -> MangoPayT m (PagedList Card) +listCards uid mp at=do + url<-getClientURLMultiple ["/users/",uid,"/cards"] + req<-getGetRequest url (Just at) (paginationAttributes mp) + getJSONList req + +-- | validity of a card +data CardValidity=UNKNOWN | VALID | INVALID + deriving (Show,Read,Eq,Ord,Bounded,Enum,Typeable) + + +-- | to json as per MangoPay format +instance ToJSON CardValidity where + toJSON =toJSON . show + +-- | from json as per MangoPay format +instance FromJSON CardValidity where + parseJSON (String s)=pure $ read $ unpack s + parseJSON _ =fail "CardValidity" + + +-- | a registered card +data Card=Card { + cId :: CardID + ,cCreationDate :: POSIXTime + ,cTag :: Maybe Text + ,cExpirationDate :: Text -- ^ MMYY + ,cAlias :: Text -- ^ Example: 497010XXXXXX4414 + ,cCardProvider :: Text -- ^ The card provider, it could be « CB », « VISA », « MASTERCARD », etc. + ,cCardType :: Text -- ^ « CB_VISA_MASTERCARD » is the only value available yet + ,cProduct :: Maybe Text + ,cBankCode :: Maybe Text + ,cActive :: Bool + ,cCurrency :: Currency + ,cValidity :: CardValidity -- ^ Once we proceed (or attempted to process) a payment with the card we are able to indicate if it is « valid » or « invalid ». If we didn’t process a payment yet the « Validity » stay at « unknown ». + ,cCountry :: Text + ,cUserId :: AnyUserID + } deriving (Show,Eq,Ord,Typeable) + +-- | from json as per MangoPay format +instance FromJSON Card where + parseJSON (Object v) =Card <$> + v .: "Id" <*> + v .: "CreationDate" <*> + v .:? "Tag" <*> + v .: "ExpirationDate" <*> + v .: "Alias" <*> + v .: "CardProvider" <*> + v .: "CardType" <*> + v .:? "Product" <*> + v .:? "BankCode" <*> + v .: "Active" <*> + v .: "Currency" <*> + v .: "Validity" <*> + v .: "Country" <*> + v .: "UserId" + parseJSON _=fail "Card" + diff --git a/src/Web/MangoPay/Documents.hs b/src/Web/MangoPay/Documents.hs new file mode 100644 --- /dev/null +++ b/src/Web/MangoPay/Documents.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, OverloadedStrings, FlexibleContexts, FlexibleInstances #-} +-- | handle documents and pages +module Web.MangoPay.Documents where + + +import Web.MangoPay.Monad +import Web.MangoPay.Types +import Web.MangoPay.Users + +import Data.Conduit +import Data.Text +import Data.Typeable (Typeable) +import Data.Aeson +import Data.Time.Clock.POSIX (POSIXTime) +import Control.Applicative +import qualified Network.HTTP.Types as HT + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 as BS + +import qualified Data.Text.Encoding as TE + +-- | create or edit a document +storeDocument :: (MonadBaseControl IO m, MonadResource m) => AnyUserID -> Document -> AccessToken -> MangoPayT m Document +storeDocument uid d at= + case dId d of + Nothing-> do + url<-getClientURLMultiple ["/users/",uid,"/KYC/documents/"] + postExchange url (Just at) d + Just i-> do + url<-getClientURLMultiple ["/users/",uid,"/KYC/documents/",i] + putExchange url (Just at) d + + +-- | fetch a document from its ID +fetchDocument :: (MonadBaseControl IO m, MonadResource m) => AnyUserID -> DocumentID -> AccessToken -> MangoPayT m Document +fetchDocument uid did at=do + url<-getClientURLMultiple ["/users/",uid,"/KYC/documents/",did] + req<-getGetRequest url (Just at) ([]::HT.Query) + getJSONResponse req + +-- | create a page +-- note that per the MangoPay API the document HAS to be in CREATED status +-- should we check it here? Since MangoPay returns a 500 Internal Server Error if the document is in another status... +storePage :: (MonadBaseControl IO m, MonadResource m) => AnyUserID -> DocumentID -> BS.ByteString -> AccessToken -> MangoPayT m () +storePage uid did contents at=do + let val=object ["File" .= TE.decodeLatin1 (BS.encode contents)] + url<-getClientURLMultiple ["/users/",uid,"/KYC/documents/",did,"/pages"] + postNoReply url (Just at) val + +-- | ID of a document +type DocumentID = Text + +-- | type of the document +data DocumentType= IDENTITY_PROOF -- ^ For legal and natural users + | REGISTRATION_PROOF -- ^ Only for legal users + | ARTICLES_OF_ASSOCIATION -- ^ Only for legal users + | SHAREHOLDER_DECLARATION -- ^ Only for legal users + | ADDRESS_PROOF -- ^ For legal and natural users + deriving (Show,Read,Eq,Ord,Bounded,Enum,Typeable) + +-- | to json as per MangoPay format +instance ToJSON DocumentType where + toJSON =toJSON . show + +-- | from json as per MangoPay format +instance FromJSON DocumentType where + parseJSON (String s)=pure $ read $ unpack s + parseJSON _ =fail "DocumentType" + +-- | status of a document +data DocumentStatus=CREATED + | VALIDATION_ASKED + | VALIDATED + | REFUSED + deriving (Show,Read,Eq,Ord,Bounded,Enum,Typeable) + +-- | to json as per MangoPay format +instance ToJSON DocumentStatus where + toJSON =toJSON . show + +-- | from json as per MangoPay format +instance FromJSON DocumentStatus where + parseJSON (String s)=pure $ read $ unpack s + parseJSON _ =fail "DocumentStatus" + +-- | a document +data Document = Document { + dId :: Maybe DocumentID + ,dCreationDate :: Maybe POSIXTime + ,dTag :: Maybe Text -- ^ custom data for client + ,dType :: DocumentType + ,dStatus :: Maybe DocumentStatus + ,dRefusedReasonType :: Maybe Text + ,dRefusedReasonMessage :: Maybe Text + } deriving (Show,Ord,Eq,Typeable) + + +-- | to json as per MangoPay format +instance ToJSON Document where + toJSON d=object ["Tag" .= dTag d, + "Type" .= dType d,"Status" .= dStatus d] + +-- | from json as per MangoPay format +instance FromJSON Document where + parseJSON (Object v) =Document <$> + v .: "Id" <*> + v .: "CreationDate" <*> + v .:? "Tag" <*> + v .: "Type" <*> + v .: "Status" <*> + v .:? "RefusedReasonType" <*> + v .:? "RefusedReasonMessage" + parseJSON _=fail "Document" + + + + diff --git a/src/Web/MangoPay/Events.hs b/src/Web/MangoPay/Events.hs new file mode 100644 --- /dev/null +++ b/src/Web/MangoPay/Events.hs @@ -0,0 +1,213 @@ +{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, OverloadedStrings, FlexibleContexts, FlexibleInstances #-} +-- | handle events +-- +module Web.MangoPay.Events where + +import Web.MangoPay.Monad +import Web.MangoPay.Types + +import Data.Conduit +import Data.Text hiding (filter) +import Data.Typeable (Typeable) +import Data.Aeson +import Data.Time.Clock.POSIX (POSIXTime) +import Data.Default +import Control.Applicative +import qualified Network.HTTP.Types as HT +import Data.Maybe (isJust) +import qualified Data.HashMap.Lazy as HM (delete) +import qualified Data.Text.Encoding as TE +import Control.Monad (join) +import qualified Data.ByteString.Char8 as BS + +-- | create or edit a natural user +searchEvents :: (MonadBaseControl IO m, MonadResource m) => EventSearchParams -> AccessToken -> MangoPayT m [Event] +searchEvents esp at=do + url<-getClientURL "/events" + req<-getGetRequest url (Just at) esp + getJSONResponse req + +-- | create or edit a hook +storeHook :: (MonadBaseControl IO m, MonadResource m) => Hook -> AccessToken -> MangoPayT m Hook +storeHook h at= + case hId h of + Nothing-> do + url<-getClientURL "/hooks" + postExchange url (Just at) h + Just i-> do + url<-getClientURLMultiple ["/hooks/",i] + let Object m=toJSON h + putExchange url (Just at) (Object $ HM.delete "EventType" m) + +-- | fetch a wallet from its ID +fetchHook :: (MonadBaseControl IO m, MonadResource m) => HookID -> AccessToken -> MangoPayT m Hook +fetchHook wid at=do + url<-getClientURLMultiple ["/hooks/",wid] + req<-getGetRequest url (Just at) ([]::HT.Query) + getJSONResponse req + +-- | list all wallets for a given user +listHooks :: (MonadBaseControl IO m, MonadResource m) => Maybe Pagination -> AccessToken -> MangoPayT m (PagedList Hook) +listHooks mp at=do + url<-getClientURL "/hooks" + req<-getGetRequest url (Just at) (paginationAttributes mp) + getJSONList req + +-- | Event type +data EventType=PAYIN_NORMAL_CREATED + | PAYIN_NORMAL_SUCCEEDED + | PAYIN_NORMAL_FAILED + | PAYOUT_NORMAL_CREATED + | PAYOUT_NORMAL_SUCCEEDED + | PAYOUT_NORMAL_FAILED + | TRANSFER_NORMAL_CREATED + | TRANSFER_NORMAL_SUCCEEDED + | TRANSFER_NORMAL_FAILED + | PAYIN_REFUND_CREATED + | PAYIN_REFUND_SUCCEEDED + | PAYIN_REFUND_FAILED + | PAYOUT_REFUND_CREATED + | PAYOUT_REFUND_SUCCEEDED + | PAYOUT_REFUND_FAILED + | TRANSFER_REFUND_CREATED + | TRANSFER_REFUND_SUCCEEDED + | TRANSFER_REFUND_FAILED + deriving (Show,Read,Eq,Ord,Bounded,Enum,Typeable) + +instance ToHtQuery (Maybe EventType) where + n ?+ d=n ?+ fmap show d + +-- | to json as per MangoPay format +instance ToJSON EventType where + toJSON =toJSON . show + +-- | from json as per MangoPay format +instance FromJSON EventType where + parseJSON (String s)=pure $ read $ unpack s + parseJSON _ =fail "EventType" + +-- | search parameters for events +data EventSearchParams=EventSearchParams{ + espEventType :: Maybe EventType + ,espBeforeDate :: Maybe POSIXTime + ,espAfterDate :: Maybe POSIXTime + ,espPagination :: Maybe Pagination + } + deriving (Show,Eq,Ord,Typeable) + +instance Default EventSearchParams where + def=EventSearchParams Nothing Nothing Nothing Nothing + +instance HT.QueryLike EventSearchParams where + toQuery (EventSearchParams et bd ad p)=filter (isJust .snd) + ["eventtype" ?+ et + ,"beforeDate" ?+ bd + ,"afterDate" ?+ ad + ] ++ paginationAttributes p + +--instance ToJSON EventSearchParams where +-- toJSON esp=object $ ["eventtype" .= espEventType esp, +-- "beforeDate" .= espBeforeDate esp, "afterDate" .= espAfterDate esp] +-- ++ paginationAttributes (espPagination esp) + +-- | a event +data Event=Event { + eResourceId :: Text + ,eEventType :: EventType + ,eDate :: POSIXTime + } + deriving (Show,Eq,Ord,Typeable) + +-- | to json as per MangoPay format +instance ToJSON Event where + toJSON e=object ["ResourceId" .= eResourceId e,"EventType" .= eEventType e,"Date" .= eDate e] + +-- | from json as per MangoPay format +instance FromJSON Event where + parseJSON (Object v) =Event <$> + v .: "ResourceId" <*> + v .: "EventType" <*> + v .: "Date" + parseJSON _=fail "Event" + +-- | parse an event from the query string +-- the MangoPay is not very clear on notifications, but see v1 +-- v2 works the same, the event is passed via parameters of the query string +eventFromQueryString :: HT.Query -> Maybe Event +eventFromQueryString q=do + rid<-fmap TE.decodeUtf8 $ join $ findAssoc q "RessourceId" -- yes, two ss here + et<-join $ fmap (maybeRead . BS.unpack) $ join $ findAssoc q "EventType" + d<-fmap fromIntegral $ join $ fmap ((maybeRead :: String -> Maybe Integer). BS.unpack) $ join $ findAssoc q "Date" + return $ Event rid et d + + +-- | parse an event from the query string represented as Text +-- the MangoPay is not very clear on notifications, but see v1 +-- v2 works the same, the event is passed via parameters of the query string +eventFromQueryStringT :: [(Text, Text)] -> Maybe Event +eventFromQueryStringT q=do + rid<- findAssoc q "RessourceId" -- yes, two ss here + et<-join $ fmap (maybeRead . unpack) $ findAssoc q "EventType" + d<-fmap fromIntegral $ join $ fmap ((maybeRead :: String -> Maybe Integer). unpack) $ findAssoc q "Date" + return $ Event rid et d + +-- | status of notification hook +data HookStatus=Enabled | Disabled + deriving (Show,Read,Eq,Ord,Bounded,Enum,Typeable) + +-- | to json as per MangoPay format +instance ToJSON HookStatus where + toJSON Enabled="ENABLED" + toJSON Disabled="DISABLED" + +-- | from json as per MangoPay format +instance FromJSON HookStatus where + parseJSON (String "ENABLED") =pure Enabled + parseJSON (String "DISABLED") =pure Disabled + parseJSON _= fail "HookStatus" + +-- | validity of notification hook +data HookValidity=Valid | Invalid + deriving (Show,Read,Eq,Ord,Bounded,Enum,Typeable) + +-- | to json as per MangoPay format +instance ToJSON HookValidity where + toJSON Valid="VALID" + toJSON Invalid="INVALID" + +-- | from json as per MangoPay format +instance FromJSON HookValidity where + parseJSON (String "VALID") =pure Valid + parseJSON (String "INVALID") =pure Invalid + parseJSON _= fail "HookValidity" + +-- | id for hook +type HookID=Text + +-- | a notification hook +data Hook=Hook { + hId :: Maybe HookID -- ^ The Id of the hook details + ,hCreationDate :: Maybe POSIXTime + ,hTag :: Maybe Text -- ^ Custom data + ,hUrl :: Text -- ^This is the URL where you receive notification for each EventType + ,hStatus :: HookStatus + ,hValidity :: Maybe HookValidity + ,hEventType :: EventType + } + deriving (Show,Eq,Ord,Typeable) + +-- | to json as per MangoPay format +instance ToJSON Hook where + toJSON h=object ["Tag" .= hTag h,"EventType" .= hEventType h,"Url" .= hUrl h,"Status" .= hStatus h] + +-- | from json as per MangoPay format +instance FromJSON Hook where + parseJSON (Object v) =Hook <$> + v .: "Id" <*> + v .: "CreationDate" <*> + v .: "Tag" <*> + v .: "Url" <*> + v .: "Status" <*> + v .: "Validity" <*> + v .: "EventType" + parseJSON _=fail "Hook" diff --git a/src/Web/MangoPay/Monad.hs b/src/Web/MangoPay/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Web/MangoPay/Monad.hs @@ -0,0 +1,349 @@ +{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables, GeneralizedNewtypeDeriving, FlexibleInstances, + MultiParamTypeClasses, UndecidableInstances, TypeFamilies, + FlexibleContexts, RankNTypes,CPP #-} +-- | the utility monad and related functions, taking care of the HTTP, JSON, etc. +module Web.MangoPay.Monad where + +import Web.MangoPay.Types + +import Control.Applicative +import Control.Monad (MonadPlus, liftM, void, join) +import Control.Monad.Base (MonadBase(..)) +import Control.Monad.Fix (MonadFix) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans.Class (MonadTrans(lift)) +import Control.Monad.Trans.Control ( MonadTransControl(..), MonadBaseControl(..) + , ComposeSt, defaultLiftBaseWith + , defaultRestoreM ) +import Control.Monad.Trans.Reader (ReaderT(..), ask, mapReaderT) +import Data.Typeable (Typeable) +import Data.Default +import qualified Control.Monad.Trans.Resource as R +import qualified Control.Exception.Lifted as L + +import qualified Data.Conduit as C +import qualified Network.HTTP.Conduit as H +import qualified Network.HTTP.Types as HT +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Lazy.Char8 as BSLC +import Data.Aeson (json,fromJSON,Result(..),FromJSON, ToJSON,encode) +import Data.Conduit.Attoparsec (sinkParser, ParseError) +import Control.Exception.Base (throw) +import qualified Data.Text.Encoding as TE +import qualified Data.Text as T (Text) +import Data.Maybe (fromMaybe) +import Data.CaseInsensitive (CI) + +#if DEBUG +import Data.Conduit.Binary (sinkHandle) +import System.IO (stdout) +import Data.Conduit.Util (zipSinks) +#endif + + +-- | the mangopay monad transformer +-- this encapsulates the data necessary to pass the app credentials, etc +newtype MangoPayT m a = Mp { unIs :: ReaderT MpData m a } + deriving ( Functor, Applicative, Alternative, Monad + , MonadFix, MonadPlus, MonadIO, MonadTrans + , R.MonadThrow, R.MonadActive, R.MonadResource ) + +instance MonadBase b m => MonadBase b (MangoPayT m) where + liftBase = lift . liftBase + +instance MonadTransControl MangoPayT where + newtype StT MangoPayT a = MpStT { unMpStT :: StT (ReaderT MpData) a } + liftWith f = Mp $ liftWith (\run -> f (liftM MpStT . run . unIs)) + restoreT = Mp . restoreT . liftM unMpStT + +instance MonadBaseControl b m => MonadBaseControl b (MangoPayT m) where + newtype StM (MangoPayT m) a = StMT {unStMT :: ComposeSt MangoPayT m a} + liftBaseWith = defaultLiftBaseWith StMT + restoreM = defaultRestoreM unStMT + +-- | Run a computation in the 'MangoPayT' monad transformer with +-- your credentials. +runMangoPayT :: Credentials -- ^ Your app's credentials. + -> H.Manager -- ^ Connection manager (see 'H.withManager'). + -> AccessPoint + -> MangoPayT m a -- ^ the action to run + -> m a -- ^ the result +runMangoPayT creds manager ap (Mp act) = + runReaderT act (MpData creds manager ap) + +-- | Get the user's credentials. +getCreds :: Monad m => MangoPayT m Credentials +getCreds = mpCreds `liftM` Mp ask + +-- | Get the MangoPay host +getHost :: Monad m => MangoPayT m ByteString +getHost = (getAccessPointURL . mpAccessPoint) `liftM` Mp ask + +-- | build a post request to MangoPay +getPostRequest :: (Monad m,MonadIO m,HT.QueryLike q) => ByteString -- ^ the url path + -> Maybe AccessToken + -> q -- ^ the query parameters + -> MangoPayT m H.Request -- ^ the properly configured request +getPostRequest path mat query=do + host<-getHost + let b=HT.renderQuery False $ HT.toQuery query +#if DEBUG + liftIO $ BSC.putStrLn path + liftIO $ BSC.putStrLn b +#endif + return $ def { + H.secure=True + , H.host = host + , H.port = 443 + , H.path = path + , H.method=HT.methodPost + , H.requestHeaders=[("content-type","application/x-www-form-urlencoded")] ++ + case mat of + Just (AccessToken at)->[("Authorization",at)] + _->[] + , H.requestBody=H.RequestBodyBS b + } + +-- | build a get request to MangoPay +getGetRequest :: (Monad m,MonadIO m,HT.QueryLike q) => ByteString -- ^ the url path + -> Maybe AccessToken + -> q -- ^ the query parameters + -> MangoPayT m H.Request -- ^ the properly configured request +getGetRequest path mat query=do + host<-getHost + let qs=HT.renderQuery True $ HT.toQuery query +#if DEBUG + liftIO $ BSC.putStrLn $ BS.append path qs +#endif + return $ def { + H.secure=True + , H.host = host + , H.port = 443 + , H.path = path + , H.method=HT.methodGet + , H.queryString=qs + , H.requestHeaders=getJSONHeaders mat + } + +-- | build a delete request to MangoPay +getDeleteRequest :: (Monad m,MonadIO m,HT.QueryLike q) => ByteString -- ^ the url path + -> Maybe AccessToken + -> q -- ^ the query parameters + -> MangoPayT m H.Request -- ^ the properly configured request +getDeleteRequest path mat query=do + get<-getGetRequest path mat query + return $ get {H.method=HT.methodDelete} + +-- | get the url to use for our clientId +getClientURL :: (Monad m)=> ByteString -- ^ the url path + -> MangoPayT m ByteString -- ^ the URL +getClientURL path=do + cid<- liftM clientIDBS getCreds + return $ BS.concat ["/v2/",cid,path] + +-- | get the url to use for our clientId +getClientURLMultiple :: (Monad m)=> [T.Text] -- ^ the url components + -> MangoPayT m ByteString -- ^ the URL +getClientURLMultiple path=do + cid<- liftM clientIDBS getCreds + return $ BS.concat $ ["/v2/",cid] ++ map TE.encodeUtf8 path + +-- | build a URL for a get operation with a single query +getQueryURL :: (Monad m,HT.QueryLike q) => ByteString -- ^ the url path + -> q -- ^ the query parameters + -> MangoPayT m ByteString -- ^ the URL +getQueryURL path query=do + host<-getHost + return $ BS.concat ["https://",host,path,HT.renderQuery True $ HT.toQuery query] + +-- | perform a HTTP request and deal with the JSON result +-- The logic for errors is as follows: we have several cases: +-- If the HTTP request return OK and we can parse the proper result, we return it. +-- If we can't parse it into the data type we expect, we throw a MpJSONException: the server returned ok but we can't parse the result. +-- If we get an HTTP error code, we try to parse the result and send the proper exception: we have encountered probably a normal error, when the user has filled in incorrect data, etc. +-- If we can't even parse the result as JSON or if we can't understand the JSON error message, we throw an MpHttpException. +mpReq :: forall b (m :: * -> *) wrappedErr c . + (MonadBaseControl IO m, C.MonadResource m,FromJSON b,FromJSON wrappedErr) => + H.Request + -> (wrappedErr -> MpError) -- ^ extract the error from the JSON + -> (HT.ResponseHeaders -> b -> c) + -> MangoPayT m c +mpReq req extractError addHeaders=do + -- we check the status ourselves + let req' = req { H.checkStatus = \_ _ _ -> Nothing } + mgr<-getManager + res<-H.http req' mgr + let status = H.responseStatus res + headers = H.responseHeaders res + cookies = H.responseCookieJar res + ok=isOkay status + err=H.StatusCodeException status headers cookies + L.catch (do +#if DEBUG + (value,_)<-H.responseBody res C.$$+- zipSinks (sinkParser json) (sinkHandle stdout) + liftIO $ BSC.putStrLn "" + liftIO $ print headers +#else + value<-H.responseBody res C.$$+- sinkParser json +#endif + if ok + then + -- parse response as the expected value + case fromJSON value of + Success ot->return $ addHeaders headers ot + Error jerr->throw $ MpJSONException jerr -- got an ok response we couldn't parse + else + -- parse response as an error + case fromJSON value of + Success ise-> throw $ MpAppException $ extractError ise + _ -> throw $ MpHttpException err $ Just value -- we can't even parse the error, throw the HTTP error inside our error type, but keep the JSON in case a human can make sens of it + ) (\(_::ParseError)->throw $ MpHttpException err Nothing) -- the error body wasn't even json, throw the HTTP error inside our error type + +-- | get a JSON response from a request to MangoPay +-- MangoPay returns either a result, or an error +getJSONResponse :: forall (m :: * -> *) v. + (MonadBaseControl IO m, C.MonadResource m,FromJSON v) => + H.Request + -> MangoPayT + m v +getJSONResponse req=mpReq req id (const id) + +-- | get a PagedList from the JSON items +getJSONList:: forall (m :: * -> *) v. + (MonadBaseControl IO m, C.MonadResource m,FromJSON v) => + H.Request + -> MangoPayT + m (PagedList v) +getJSONList req=mpReq req id buildList + +-- | build a PagedList from the headers information +buildList :: HT.ResponseHeaders -> [b] -> PagedList b +buildList headers items=let + cnt=fromMaybe (fromIntegral $ length items) $ getI "X-Number-Of-Items" -- yes, doc is wrong (they forgot the s) + pgs=fromMaybe 1 $ getI "X-Number-Of-Pages" + in PagedList items cnt pgs + where + getI :: CI ByteString -> Maybe Integer + getI =join . fmap ((maybeRead :: String -> Maybe Integer). BSC.unpack) . findAssoc headers + +-- | get all items, hiding the pagination system +getAll :: (MonadBaseControl IO m, C.MonadResource m,FromJSON v) => + (Maybe Pagination -> AccessToken -> MangoPayT m (PagedList v)) -> AccessToken -> + MangoPayT m [v] +getAll f at=readAll 1 [] + where + readAll p accum=do + retL<-f (Just $ Pagination p 100) at + let dts=accum ++ plData retL + if plPageCount retL > p + then readAll (p + 1) dts + else return dts + +-- | get the headers necessary for a JSON call +getJSONHeaders :: Maybe AccessToken -> HT.RequestHeaders +getJSONHeaders mat= ("content-type", "application/json") : + case mat of + Just (AccessToken at) -> [("Authorization", at)] + _ -> [] + + +-- | send JSON via post, get JSON back +postExchange :: forall (m :: * -> *) v p. + (MonadBaseControl IO m, C.MonadResource m,FromJSON v,ToJSON p) => + ByteString + -> Maybe AccessToken + -> p + -> MangoPayT + m v +postExchange=jsonExchange HT.methodPost + +-- | send JSON via post, get JSON back +putExchange :: forall (m :: * -> *) v p. + (MonadBaseControl IO m, C.MonadResource m,FromJSON v,ToJSON p) => + ByteString + -> Maybe AccessToken + -> p + -> MangoPayT + m v +putExchange=jsonExchange HT.methodPut + +-- | send JSON, get JSON back +jsonExchange :: forall (m :: * -> *) v p. + (MonadBaseControl IO m, C.MonadResource m,FromJSON v,ToJSON p) => + HT.Method + -> ByteString + -> Maybe AccessToken + -> p + -> MangoPayT + m v +jsonExchange meth path mat p= getJSONRequest meth path mat p >>= getJSONResponse + +-- | get JSON request +getJSONRequest :: forall (m :: * -> *) p. + (MonadBaseControl IO m, C.MonadResource m,ToJSON p) => + HT.Method + -> ByteString + -> Maybe AccessToken + -> p + -> MangoPayT m H.Request -- ^ the properly configured request +getJSONRequest meth path mat p= do + host<-getHost +#if DEBUG + liftIO $ BSC.putStrLn path + liftIO $ BSLC.putStrLn $ encode p +#endif + return def { + H.secure=True + , H.host = host + , H.port = 443 + , H.path = path + , H.method=meth + , H.requestHeaders=getJSONHeaders mat + , H.requestBody=H.RequestBodyLBS $ encode p + } + +-- | post JSON content and ignore the reply +postNoReply :: forall (m :: * -> *) p. + (MonadBaseControl IO m, C.MonadResource m,ToJSON p) => + ByteString + -> Maybe AccessToken + -> p + -> MangoPayT + m () +postNoReply path mat p= do + req<- getJSONRequest HT.methodPost path mat p + mgr<-getManager + void $ H.http req mgr + +-- | Get the 'H.Manager'. +getManager :: Monad m => MangoPayT m H.Manager +getManager = mpManager `liftM` Mp ask + +-- | Run a 'ResourceT' inside a 'MangoPayT'. +runResourceInMp :: (C.MonadResource m, MonadBaseControl IO m) => + MangoPayT (C.ResourceT m) a + -> MangoPayT m a +runResourceInMp (Mp inner) = Mp $ ask >>= lift . C.runResourceT . runReaderT inner + +-- | Transform the computation inside a 'MangoPayT'. +mapMangoPayT :: (m a -> n b) -> MangoPayT m a -> MangoPayT n b +mapMangoPayT f = Mp . mapReaderT f . unIs + +-- | the data kept through the computations +data MpData = MpData { + mpCreds::Credentials -- ^ app credentials + ,mpManager::H.Manager -- ^ HTTP connection manager + ,mpAccessPoint:: AccessPoint -- ^ access point + } + deriving (Typeable) + +-- | @True@ if the the 'Status' is ok (i.e. @2XX@). +isOkay :: HT.Status -> Bool +isOkay status = + let sc = HT.statusCode status + in 200 <= sc && sc < 300 + + diff --git a/src/Web/MangoPay/Payins.hs b/src/Web/MangoPay/Payins.hs new file mode 100644 --- /dev/null +++ b/src/Web/MangoPay/Payins.hs @@ -0,0 +1,200 @@ +{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, OverloadedStrings, FlexibleContexts, FlexibleInstances #-} +-- | handle payins +module Web.MangoPay.Payins where + +import Web.MangoPay.Accounts +import Web.MangoPay.Monad +import Web.MangoPay.Types +import Web.MangoPay.Users +import Web.MangoPay.Wallets + +import Data.Conduit +import Data.Text +import Data.Typeable (Typeable) +import Data.Aeson +import Data.Time.Clock.POSIX (POSIXTime) +import Control.Applicative +import qualified Network.HTTP.Types as HT + +-- | create or edit a bankwire +storeBankWire :: (MonadBaseControl IO m, MonadResource m) => BankWire -> AccessToken -> MangoPayT m BankWire +storeBankWire bw at= do + url<-getClientURL "/payins/bankwire/direct" + postExchange url (Just at) bw + +-- | fetch a bank wire from its ID +fetchBankWire :: (MonadBaseControl IO m, MonadResource m) => BankWireID -> AccessToken -> MangoPayT m BankWire +fetchBankWire bwid at=do + url<-getClientURLMultiple ["/payins/",bwid] + req<-getGetRequest url (Just at) ([]::HT.Query) + getJSONResponse req + +-- | create or edit a direct card pay in +storeCardPayin :: (MonadBaseControl IO m, MonadResource m) => CardPayin -> AccessToken -> MangoPayT m CardPayin +storeCardPayin cp at= do + url<-getClientURL "/payins/card/direct" + postExchange url (Just at) cp + +-- | fetch a direct pay in from its ID +fetchCardPayin :: (MonadBaseControl IO m, MonadResource m) => CardPayinID -> AccessToken -> MangoPayT m CardPayin +fetchCardPayin cpid at=do + url<-getClientURLMultiple ["/payins/",cpid] + req<-getGetRequest url (Just at) ([]::HT.Query) + getJSONResponse req + +data PaymentExecution = WEB -- ^ through a web interface + | DIRECT -- ^ with a tokenized card + deriving (Show,Read,Eq,Ord,Bounded,Enum,Typeable) + +-- | to json as per MangoPay format +instance ToJSON PaymentExecution where + toJSON =toJSON . show + +-- | from json as per MangoPay format +instance FromJSON PaymentExecution where + parseJSON (String s)=pure $ read $ unpack s + parseJSON _ =fail "PaymentExecution" + +-- | helper function to create a new bank wire with the needed information +mkBankWire :: AnyUserID -> AnyUserID -> WalletID -> Amount -> Amount -> BankWire +mkBankWire aid uid wid amount fees= BankWire Nothing Nothing Nothing aid uid Nothing + wid Nothing Nothing Nothing amount fees Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + +-- | bankwire or card pay in +type AnyPayinID=Text + +-- | id of a bankwire +type BankWireID=Text + +-- | a bank wire +-- there are a lot of common fields between all kinds of payments +-- so this could probably become a "Payment" type +data BankWire=BankWire { + bwId :: Maybe BankWireID + ,bwCreationDate :: Maybe POSIXTime + ,bwTag :: Maybe Text -- ^ custom data + ,bwAuthorId :: AnyUserID -- ^ The user ID of the author + ,bwCreditedUserId :: AnyUserID -- ^ It represents the amount credited on the targeted e-wallet. + ,bwFees :: Maybe Amount -- ^ It represents your fees taken on the DebitedFundsDebitedFunds – Fees = CreditedFunds (amount received on wallet) + ,bwCreditedWalletId :: WalletID -- ^ The ID of the credited wallet + ,bwDebitedWalletId :: Maybe WalletID -- ^ The ID of the debited wallet + ,bwDebitedFunds :: Maybe Amount -- ^ It represents the amount debited from the bank account. + ,bwCreditedFunds :: Maybe Amount -- ^ It represents the amount credited on the targeted e-wallet. + ,bwDeclaredDebitedFunds :: Amount -- ^ It represents the expected amount by the platform before that the user makes the payment. + ,bwDeclaredFees :: Amount -- ^ It represents the expected fees amount by the platform before that the user makes the payment. + ,bwWireReference :: Maybe Text -- ^ It is a reference generated by MANGOPAY and displayed to the user by the platform. The user have to indicate it into the bank wire. + ,bwBankAccount :: Maybe BankAccount -- ^ The bank account is generated by MANGOPAY and displayed to the user. + ,bwStatus :: Maybe TransferStatus -- ^ The status of the payment + ,bwResultCode :: Maybe Text -- ^ The transaction result code + ,bwResultMessage :: Maybe Text -- ^ The transaction result Message + ,bwExecutionDate :: Maybe POSIXTime -- ^ The date when the payment is processed + ,bwType :: Maybe TransactionType -- ^ The type of the transaction + ,bwNature :: Maybe TransactionNature -- ^ The nature of the transaction: + ,bwPaymentType :: Maybe PaymentType -- ^ The type of the payment (which type of mean of payment is used). + ,bwExecutionType :: Maybe PaymentExecution -- ^ How the payment has been executed: + } deriving (Show,Eq,Ord,Typeable) + +-- | to json as per MangoPay format +instance ToJSON BankWire where + toJSON bw=object ["Tag" .= bwTag bw,"AuthorId" .= bwAuthorId bw + ,"CreditedUserId" .= bwCreditedUserId bw,"CreditedWalletId" .= bwCreditedWalletId bw + ,"DeclaredDebitedFunds" .= bwDeclaredDebitedFunds bw,"DeclaredFees" .= bwDeclaredFees bw] + +-- | from json as per MangoPay format +instance FromJSON BankWire where + parseJSON (Object v) =BankWire <$> + v .: "Id" <*> + v .: "CreationDate" <*> + v .:? "Tag" <*> + v .: "AuthorId" <*> + v .: "CreditedUserId" <*> + v .:? "Fees" <*> + v .: "CreditedWalletId" <*> + v .:? "DebitedWalletId" <*> + v .:? "DebitedFunds" <*> + v .:? "CreditedFunds" <*> + v .: "DeclaredDebitedFunds" <*> + v .: "DeclaredFees" <*> + v .:? "WireReference" <*> + v .:? "BankAccount" <*> + v .:? "Status" <*> + v .:? "ResultCode" <*> + v .:? "ResultMessage" <*> + v .:? "ExecutionDate" <*> + v .:? "Type" <*> + v .:? "Nature" <*> + v .:? "PaymentType" <*> + v .:? "ExecutionType" + parseJSON _=fail "BankWire" + +-- | ID of a direct pay in +type CardPayinID=Text + +-- | helper function to create a new direct payin with the needed information +-- | the url is only used in secure mode but is REQUIRED by MangoPay +mkCardPayin :: AnyUserID -> AnyUserID -> WalletID -> Amount -> Amount -> Text -> CardID -> CardPayin +mkCardPayin aid uid wid amount fees url cid= CardPayin Nothing Nothing Nothing aid uid fees + wid Nothing amount Nothing (Just url) Nothing Nothing cid Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + + +-- | direct pay in via registered card +data CardPayin=CardPayin { + cpId :: Maybe CardPayinID + ,cpCreationDate :: Maybe POSIXTime + ,cpTag :: Maybe Text -- ^ custom data + ,cpAuthorId :: AnyUserID -- ^ The user ID of the author + ,cpCreditedUserId :: AnyUserID -- ^ The user ID of the owner of the credited wallet + ,cpFees :: Amount -- ^ It represents your fees taken on the DebitedFundsDebitedFunds – Fees = CreditedFunds (amount received on wallet) + ,cpCreditedWalletId :: WalletID -- ^ The ID of the credited wallet + ,cpDebitedWalletId :: Maybe WalletID -- ^ The ID of the debited wallet + ,cpDebitedFunds :: Amount -- ^ It represents the amount debited from the bank account. + ,cpCreditedFunds :: Maybe Amount -- ^ It represents the amount credited on the targeted e-wallet. + ,cpSecureModeReturnURL :: Maybe Text -- ^ This URL will be used in case the SecureMode is activated. + ,cpSecureMode :: Maybe Text -- ^ The SecureMode correspond to « 3D secure » for CB Visa and MasterCard or « Amex Safe Key » for American Express. This field lets you activate it manually. + ,cpSecureModeRedirectURL :: Maybe Text -- ^ This URL will be used in case the SecureMode is activated. + ,cpCardId :: CardID -- ^ The ID of the registered card (Got through CardRegistration object) + ,cpStatus :: Maybe TransferStatus -- ^ The status of the payment + ,cpResultCode :: Maybe Text -- ^ The transaction result code + ,cpResultMessage :: Maybe Text -- ^ The transaction result Message + ,cpExecutionDate :: Maybe POSIXTime -- The date when the payment is processed + ,cpType :: Maybe TransactionType -- ^ The type of the transaction + ,cpNature :: Maybe TransactionNature -- ^ The nature of the transaction: + ,cpPaymentType :: Maybe Text -- ^ The type of the payment (which type of mean of payment is used). + ,cpExecutionType :: Maybe PaymentExecution -- ^ How the payment has been executed: + } deriving (Show,Eq,Ord,Typeable) + +-- | to json as per MangoPay format +instance ToJSON CardPayin where + toJSON cp=object ["Tag" .= cpTag cp,"AuthorId" .= cpAuthorId cp + ,"CreditedUserId" .= cpCreditedUserId cp,"CreditedWalletId" .= cpCreditedWalletId cp + ,"DebitedFunds" .= cpDebitedFunds cp,"Fees" .= cpFees cp,"CardID" .= cpCardId cp + ,"SecureModeReturnURL" .= cpSecureModeReturnURL cp + ,"SecureMode" .= cpSecureMode cp] + +-- | from json as per MangoPay format +instance FromJSON CardPayin where + parseJSON (Object v) =CardPayin <$> + v .: "Id" <*> + v .: "CreationDate" <*> + v .:? "Tag" <*> + v .: "AuthorId" <*> + v .: "CreditedUserId" <*> + v .: "Fees" <*> + v .: "CreditedWalletId" <*> + v .:? "DebitedWalletId" <*> + v .: "DebitedFunds" <*> + v .:? "CreditedFunds" <*> + v .:? "SecureModeReturnURL" <*> + v .:? "SecureModeRedirectURL" <*> + v .:? "SecureMode" <*> + v .: "CardId" <*> + v .:? "Status" <*> + v .:? "ResultCode" <*> + v .:? "ResultMessage" <*> + v .:? "ExecutionDate" <*> + v .:? "Type" <*> + v .:? "Nature" <*> + v .:? "PaymentType" <*> + v .:? "ExecutionType" + parseJSON _=fail "CardPayin" + diff --git a/src/Web/MangoPay/Payouts.hs b/src/Web/MangoPay/Payouts.hs new file mode 100644 --- /dev/null +++ b/src/Web/MangoPay/Payouts.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, OverloadedStrings, FlexibleContexts, FlexibleInstances #-} +-- | handle payouts +module Web.MangoPay.Payouts where + +import Web.MangoPay.Accounts +import Web.MangoPay.Monad +import Web.MangoPay.Types +import Web.MangoPay.Users +import Web.MangoPay.Wallets + +import Data.Conduit +import Data.Text +import Data.Typeable (Typeable) +import Data.Aeson +import Data.Time.Clock.POSIX (POSIXTime) +import Control.Applicative +import qualified Network.HTTP.Types as HT + +-- | create a payout +storePayout :: (MonadBaseControl IO m, MonadResource m) => Payout -> AccessToken -> MangoPayT m Payout +storePayout pt at= do + url<-getClientURL "/payouts/bankwire" + postExchange url (Just at) pt + +-- | fetch an payout from its ID +fetchPayout :: (MonadBaseControl IO m, MonadResource m) => PayoutID -> AccessToken -> MangoPayT m Payout +fetchPayout ptid at=do + url<-getClientURLMultiple ["/payouts/",ptid] + req<-getGetRequest url (Just at) ([]::HT.Query) + getJSONResponse req + +-- | make a simplep payout for creation +mkPayout :: AnyUserID -> WalletID -> Amount -> Amount -> BankAccountID -> Payout +mkPayout aid wid fds fees bid=Payout Nothing Nothing Nothing aid wid fds fees bid Nothing Nothing Nothing Nothing Nothing + Nothing Nothing Nothing Nothing Nothing + +-- | id of payout +type PayoutID = Text + +-- | payout +data Payout=Payout { + ptId :: Maybe PayoutID + ,ptCreationDate :: Maybe POSIXTime + ,ptTag :: Maybe Text -- ^ custom data for client + ,ptAuthorId :: AnyUserID -- ^ The user ID of the author + ,ptDebitedWalletId :: WalletID + ,ptDebitedFunds :: Amount + ,ptFees :: Amount + ,ptBankAccountId :: BankAccountID + ,ptCreditedUserId :: Maybe AnyUserID + ,ptCreditedFunds :: Maybe Amount + ,ptStatus :: Maybe TransferStatus + ,ptResultCode :: Maybe Text -- ^ The transaction result code + ,ptResultMessage :: Maybe Text -- ^ The transaction result code + ,ptExecutionDate :: Maybe POSIXTime + ,ptType :: Maybe TransactionType + ,ptNature :: Maybe TransactionNature + ,ptPaymentType :: Maybe PaymentType + ,ptMeanOfPaymentType :: Maybe PaymentType -- ^ « BANK_WIRE », + } deriving (Show,Eq,Ord,Typeable) + + +-- | to json as per MangoPay format +instance ToJSON Payout where + toJSON pt=object ["Tag" .= ptTag pt,"AuthorId" .= ptAuthorId pt + ,"DebitedWalletId" .= ptDebitedWalletId pt + ,"DebitedFunds" .= ptDebitedFunds pt,"Fees" .= ptFees pt,"BankAccountId" .= ptBankAccountId pt] + +-- | from json as per MangoPay format +instance FromJSON Payout where + parseJSON (Object v) =Payout <$> + v .: "Id" <*> + v .: "CreationDate" <*> + v .:? "Tag" <*> + v .: "AuthorId" <*> + v .: "DebitedWalletId" <*> + v .: "DebitedFunds" <*> + v .: "Fees" <*> + v .: "BankAccountId" <*> + v .:? "CreditedUserId" <*> + v .:? "CreditedFunds" <*> + v .:? "Status" <*> + v .:? "ResultCode" <*> + v .:? "ResultMessage" <*> + v .:? "ExecutionDate" <*> + v .:? "Type" <*> + v .:? "Nature" <*> + v .:? "PaymentType" <*> + v .:? "MeanOfPaymentType" + parseJSON _=fail "Payout" + + diff --git a/src/Web/MangoPay/Refunds.hs b/src/Web/MangoPay/Refunds.hs new file mode 100644 --- /dev/null +++ b/src/Web/MangoPay/Refunds.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, FlexibleContexts #-} +-- | refunds on payins and transfers +module Web.MangoPay.Refunds where + +import Web.MangoPay.Monad +import Web.MangoPay.Payins +import Web.MangoPay.Types +import Web.MangoPay.Users +import Web.MangoPay.Wallets + +import Data.Conduit +import Data.Text +import Data.Typeable (Typeable) +import Data.Aeson +import Data.Time.Clock.POSIX (POSIXTime) +import Control.Applicative +import qualified Network.HTTP.Types as HT + +-- | refund a transfer +refundTransfer :: (MonadBaseControl IO m, MonadResource m) => TransferID -> AnyUserID -> AccessToken -> MangoPayT m Refund +refundTransfer tid authID at= do + url<-getClientURLMultiple ["/transfers/",tid,"/refunds"] + postExchange url (Just at) (RefundRequest authID Nothing Nothing) + +-- | refund a pay-in +refundPayin :: (MonadBaseControl IO m, MonadResource m) => AnyPayinID -> RefundRequest -> AccessToken -> MangoPayT m Refund +refundPayin pid rr at= do + url<-getClientURLMultiple ["/payins/",pid,"/refunds"] + postExchange url (Just at) rr + +-- | fetch a refund from its ID +fetchRefund :: (MonadBaseControl IO m, MonadResource m) => RefundID -> AccessToken -> MangoPayT m Refund +fetchRefund rid at=do + url<-getClientURLMultiple ["/refunds/",rid] + req<-getGetRequest url (Just at) ([]::HT.Query) + getJSONResponse req + +-- | refund request +data RefundRequest=RefundRequest{ + rrAuthorId :: AnyUserID -- ^ The user ID of the author + ,rrDebitedFunds :: Maybe Amount -- ^ Strictly positive amount. In cents. + ,rrFees :: Maybe Amount -- ^ In cents + }deriving (Show,Eq,Ord,Typeable) + + -- | to json as per MangoPay format +instance ToJSON RefundRequest where + toJSON rr=object ["AuthorId" .= rrAuthorId rr,"DebitedFunds" .= rrDebitedFunds rr, + "Fees" .= rrFees rr] + + +-- | id of a refund +type RefundID = Text + +-- | refund of a transfer +data Refund=Refund{ + rId :: RefundID -- ^ Id of the refund + ,rCreationDate :: POSIXTime + ,rTag :: Maybe Text -- ^ Custom data + ,rAuthorId :: AnyUserID -- ^ The user ID of the author + ,rDebitedFunds :: Amount -- ^ Strictly positive amount. In cents. + ,rFees :: Amount -- ^ In cents + ,rCreditedFunds :: Amount -- ^ In cents + ,rStatus :: TransferStatus + ,rResultCode :: Text -- ^ The transaction result code + ,rResultMessage :: Maybe Text -- ^ The transaction result Message + ,rExecutionDate :: POSIXTime + ,rType :: TransactionType + ,rNature :: TransactionNature + ,rCreditedUserId :: Maybe AnyUserID -- ^ Id of the user owner of the credited wallet + ,rInitialTransactionId :: TransactionID -- ^ Id of the transaction being refunded + ,rInitialTransactionType :: TransactionType -- ^ The type of the transaction before being refunded (PayIn, Refund) + ,rDebitedWalletId :: WalletID -- ^ The Id of the debited Wallet + ,rCreditedWalletID :: Maybe WalletID -- ^ The Id of the credited Wallet + } deriving (Show,Eq,Ord,Typeable) + + -- | from json as per MangoPay format +instance FromJSON Refund where + parseJSON (Object v) =Refund <$> + v .: "Id" <*> + v .: "CreationDate" <*> + v .:? "Tag" <*> + v .: "AuthorId" <*> + v .: "DebitedFunds" <*> + v .: "Fees" <*> + v .: "CreditedFunds" <*> + v .: "Status" <*> + v .: "ResultCode" <*> + v .:? "ResultMessage" <*> + v .: "ExecutionDate" <*> + v .: "Type" <*> + v .: "Nature" <*> + v .:? "CreditedUserId" <*> + v .: "InitialTransactionId" <*> + v .: "InitialTransactionType" <*> + v .: "DebitedWalletId" <*> + v .:? "CreditedWalletID" + parseJSON _=fail "Refund" diff --git a/src/Web/MangoPay/Types.hs b/src/Web/MangoPay/Types.hs new file mode 100644 --- /dev/null +++ b/src/Web/MangoPay/Types.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, ScopedTypeVariables, TypeSynonymInstances, FlexibleInstances #-} +-- | useful types and simple accessor functions +module Web.MangoPay.Types where + + +import Control.Applicative +import Control.Exception.Base (Exception) +import Data.Text as T +import Data.Typeable (Typeable) +import Data.ByteString (ByteString) +import Data.Time.Clock.POSIX (POSIXTime) +import Data.Aeson +import Data.Default + +import qualified Data.Text.Encoding as TE +import qualified Data.ByteString.UTF8 as UTF8 +import Data.Maybe (listToMaybe) +import Network.HTTP.Conduit (HttpException) + +-- | the MangoPay access point +data AccessPoint = Sandbox | Production | Custom ByteString + deriving (Show,Read,Eq,Ord,Typeable) + +-- | get the real url for the given access point +getAccessPointURL :: AccessPoint -> ByteString +getAccessPointURL Sandbox="api.sandbox.mangopay.com" +getAccessPointURL Production="api.mangopay.com" +getAccessPointURL (Custom bs)=bs + +-- | the app credentials +data Credentials = Credentials { + cClientID :: Text -- ^ client id + ,cName :: Text -- ^ the name + ,cEmail :: Text -- ^ the email + ,cClientSecret :: Maybe Text -- ^ client secret, maybe be Nothing if we haven't generated it + } + deriving (Show,Read,Eq,Ord,Typeable) + +-- | to json as per MangoPay format +instance ToJSON Credentials where + toJSON c=object ["ClientId" .= cClientID c, "Name" .= cName c , "Email" .= cEmail c,"Passphrase" .= cClientSecret c] + +-- | from json as per MangoPay format +instance FromJSON Credentials where + parseJSON (Object v) =Credentials <$> + v .: "ClientId" <*> + v .: "Name" <*> + v .: "Email" <*> + v .: "Passphrase" + parseJSON _= fail "Credentials" + +-- | get client id in ByteString form +clientIDBS :: Credentials -> ByteString +clientIDBS=TE.encodeUtf8 . cClientID + + +-- | the access token is simply a Text +newtype AccessToken=AccessToken ByteString + deriving (Eq, Ord, Read, Show, Typeable) + + +-- | the oauth token returned after authentication +data OAuthToken = OAuthToken { + oaAccessToken :: Text -- ^ the access token + ,oaTokenType :: Text -- ^ the token type + ,oaExpires :: Int -- ^ expiration + } + deriving (Show,Read,Eq,Ord,Typeable) + +-- | to json as per MangoPay format +instance ToJSON OAuthToken where + toJSON oa=object ["access_token" .= oaAccessToken oa, "token_type" .= oaTokenType oa, "expires_in" .= oaExpires oa] + +-- | from json as per MangoPay format +instance FromJSON OAuthToken where + parseJSON (Object v) =OAuthToken <$> + v .: "access_token" <*> + v .: "token_type" <*> + v .: "expires_in" + parseJSON _= fail "OAuthToken" + +-- | build the access token from the OAuthToken +toAccessToken :: OAuthToken -> AccessToken +toAccessToken oa=AccessToken $ TE.encodeUtf8 $ T.concat [oaTokenType oa, " ",oaAccessToken oa] + +-- | an exception that a call to MangoPay may throw +data MpException = MpJSONException String -- ^ JSON parsingError + | MpAppException MpError -- ^ application exception + | MpHttpException HttpException (Maybe Value) -- ^ HTTP level exception, maybe with some JSON payload + deriving (Show,Typeable) + +-- | make our exception type a normal exception +instance Exception MpException + + +-- | an error returned to us by MangoPay +data MpError = MpError { + igeID :: Text + ,igeType :: Text + ,igeMessage :: Text + ,igeDate :: Maybe POSIXTime + } + deriving (Show,Eq,Ord,Typeable) + + + +-- | from json as per MangoPay format +instance FromJSON MpError where + parseJSON (Object v) = MpError <$> + v .: "Id" <*> + v .: "Type" <*> + v .: "Message" <*> + v .: "Date" + parseJSON _= fail "MpError" + +instance FromJSON POSIXTime where + parseJSON n@(Number _)=(fromIntegral . (round::Double -> Integer)) <$> parseJSON n + parseJSON _ = fail "POSIXTime" + +-- | to json as per MangoPay format +instance ToJSON POSIXTime where + toJSON pt=toJSON (round pt :: Integer) + +-- | Pagination info for searches +-- +data Pagination = Pagination { + pPage :: Integer + ,pPerPage :: Integer + } + deriving (Show,Read,Eq,Ord,Typeable) + +instance Default Pagination where + def=Pagination 1 10 + +-- | get pagination attributes for query +paginationAttributes :: Maybe Pagination -> [(ByteString,Maybe ByteString)] +paginationAttributes (Just p)=["page" ?+ pPage p, "per_page" ?+ pPerPage p] +paginationAttributes _=[] + +data PagedList a= PagedList { + plData :: [a] + ,plItemCount :: Integer + ,plPageCount :: Integer + } + deriving (Show,Read,Eq,Ord,Typeable) + +-- | ID of a card +type CardID=Text + +-- | alias for Currency +type Currency=Text + +-- | simple class used to hide the serialization of parameters ansd simplify the calling code +class ToHtQuery a where + (?+) :: ByteString -> a -> (ByteString,Maybe ByteString) + +instance ToHtQuery Double where + n ?+ d=n ?+ show d + +instance ToHtQuery (Maybe Double) where + n ?+ d=n ?+ fmap show d + +instance ToHtQuery Integer where + n ?+ d=n ?+ show d + +instance ToHtQuery (Maybe Integer) where + n ?+ d=n ?+ fmap show d + +instance ToHtQuery (Maybe POSIXTime) where + n ?+ d=n ?+ fmap (show . (round :: POSIXTime -> Integer)) d + +instance ToHtQuery (Maybe T.Text) where + n ?+ d=(n,fmap TE.encodeUtf8 d) + +instance ToHtQuery T.Text where + n ?+ d=(n,Just $ TE.encodeUtf8 d) + + +instance ToHtQuery (Maybe String) where + n ?+ d=(n,fmap UTF8.fromString d) + +instance ToHtQuery String where + n ?+ d=(n,Just $ UTF8.fromString d) + +-- | find in assoc list +findAssoc :: Eq a=> [(a,b)] -> a -> Maybe b +findAssoc xs n=listToMaybe $ Prelude.map snd $ Prelude.filter ((n==) . fst) xs + +-- | read an object or return Nothing +maybeRead :: Read a => String -> Maybe a +maybeRead = fmap fst . listToMaybe . reads diff --git a/src/Web/MangoPay/Users.hs b/src/Web/MangoPay/Users.hs new file mode 100644 --- /dev/null +++ b/src/Web/MangoPay/Users.hs @@ -0,0 +1,274 @@ +{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, OverloadedStrings, FlexibleContexts, FlexibleInstances #-} +-- | handle users +module Web.MangoPay.Users where + +import Web.MangoPay.Monad +import Web.MangoPay.Types + +import Data.Conduit +import Data.Text +import Data.Typeable (Typeable) +import Data.Aeson +import Data.Time.Clock.POSIX (POSIXTime) +import Control.Applicative +import qualified Network.HTTP.Types as HT + +-- | create or edit a natural user +storeNaturalUser :: (MonadBaseControl IO m, MonadResource m) => NaturalUser -> AccessToken -> MangoPayT m NaturalUser +storeNaturalUser u at= + case uId u of + Nothing-> do + url<-getClientURL "/users/natural" + postExchange url (Just at) u + Just i-> do + url<-getClientURLMultiple ["/users/natural/",i] + putExchange url (Just at) u{uProofOfIdentity=Nothing,uProofOfAddress=Nothing} + + +-- | fetch a natural user from her ID +fetchNaturalUser :: (MonadBaseControl IO m, MonadResource m) => NaturalUserID -> AccessToken -> MangoPayT m NaturalUser +fetchNaturalUser uid at=do + url<-getClientURLMultiple ["/users/natural/",uid] + req<-getGetRequest url (Just at) ([]::HT.Query) + getJSONResponse req + +-- | create or edit a natural user +storeLegalUser :: (MonadBaseControl IO m, MonadResource m) => LegalUser -> AccessToken -> MangoPayT m LegalUser +storeLegalUser u at= + case lId u of + Nothing-> do + url<-getClientURL "/users/legal" + postExchange url (Just at) u + Just i-> do + url<-getClientURLMultiple ["/users/legal/",i] + putExchange url (Just at) u + + +-- | fetch a natural user from her ID +fetchLegalUser :: (MonadBaseControl IO m, MonadResource m) => LegalUserID -> AccessToken -> MangoPayT m LegalUser +fetchLegalUser uid at=do + url<-getClientURLMultiple ["/users/legal/",uid] + req<-getGetRequest url (Just at) ([]::HT.Query) + getJSONResponse req + +-- | get a user, natural or legal +getUser :: (MonadBaseControl IO m, MonadResource m) => AnyUserID -> AccessToken -> MangoPayT m (Either NaturalUser LegalUser) +getUser uid at=do + url<-getClientURLMultiple ["/users/",uid] + req<-getGetRequest url (Just at) ([]::HT.Query) + getJSONResponse req + +-- | list all user references +listUsers :: (MonadBaseControl IO m, MonadResource m) => Maybe Pagination -> AccessToken -> MangoPayT m (PagedList UserRef) +listUsers mp at=do + url<-getClientURL "/users/" + req<-getGetRequest url (Just at) (paginationAttributes mp) + getJSONList req + +instance FromJSON (Either NaturalUser LegalUser) where + parseJSON o@(Object v)=do + pt::PersonType<-v .: "PersonType" + case pt of + Natural->Left <$> parseJSON o + Legal->Right <$> parseJSON o + parseJSON _=fail "EitherUsers" + +-- not supported +--deleteNaturalUser :: (MonadBaseControl IO m, MonadResource m) => UserID -> AccessToken -> MangoPayT m () +--deleteNaturalUser uid at=do +-- url<-getClientURL (TE.encodeUtf8 $ Data.Text.concat ["/users/natural/",uid]) +-- req<-getDeleteRequest url (Just at) ([]::HT.Query) +-- _::Object<- getJSONResponse req +-- return () + +-- | ID for any kind of user +type AnyUserID = Text + +-- | User ID +type NaturalUserID = Text + +-- | supported income ranges +data IncomeRange=IncomeRange1 | IncomeRange2 | IncomeRange3 | IncomeRange4 | IncomeRange5 | IncomeRange6 + deriving (Show,Read,Eq,Ord,Bounded, Enum, Typeable) + +-- | to json as per MangoPay format +-- the samples do show string format when writing, integer format when reading... +instance ToJSON IncomeRange where + toJSON IncomeRange1="1" + toJSON IncomeRange2="2" + toJSON IncomeRange3="3" + toJSON IncomeRange4="4" + toJSON IncomeRange5="5" + toJSON IncomeRange6="6" + +-- | from json as per MangoPay format +-- the samples do show string format when writing, integer format when reading... +instance FromJSON IncomeRange where + parseJSON (String "1") =pure IncomeRange1 + parseJSON (String "2") =pure IncomeRange2 + parseJSON (String "3") =pure IncomeRange3 + parseJSON (String "4") =pure IncomeRange4 + parseJSON (String "5") =pure IncomeRange5 + parseJSON (String "6") =pure IncomeRange6 + parseJSON (Number 1) =pure IncomeRange1 + parseJSON (Number 2) =pure IncomeRange2 + parseJSON (Number 3) =pure IncomeRange3 + parseJSON (Number 4) =pure IncomeRange4 + parseJSON (Number 5) =pure IncomeRange5 + parseJSON (Number 6) =pure IncomeRange6 + parseJSON _= fail "IncomeRange" + +-- | a natural user +-- +data NaturalUser=NaturalUser { + uId :: Maybe NaturalUserID -- ^ The Id of the object + ,uCreationDate :: Maybe POSIXTime -- ^ The creation date of the user object + ,uEmail :: Text -- ^ User’s e-mail + ,uFirstName :: Text -- ^ User’s firstname + ,uLastName :: Text -- ^ User’s lastname + ,uAddress :: Maybe Text -- ^ User’s address + ,uBirthday :: POSIXTime -- ^ User’s birthdate + ,uNationality :: Text -- ^ User’s Nationality + ,uCountryOfResidence:: Text -- ^User’s country of residence + ,uOccupation :: Maybe Text -- ^User’s occupation (ie. Work) + ,uIncomeRange :: Maybe IncomeRange -- ^ User’s income range + ,uTag :: Maybe Text -- ^ Custom data + ,uProofOfIdentity :: Maybe Text -- ^ + ,uProofOfAddress :: Maybe Text -- ^ + } + deriving (Show,Eq,Ord,Typeable) + +-- | to json as per MangoPay format +instance ToJSON NaturalUser where + toJSON u=object ["Tag" .= uTag u,"Email" .= uEmail u,"FirstName".= uFirstName u,"LastName" .= uLastName u,"Address" .= uAddress u, "Birthday" .= uBirthday u + ,"Nationality" .= uNationality u,"CountryOfResidence" .= uCountryOfResidence u,"Occupation" .= uOccupation u, "IncomeRange" .= uIncomeRange u,"ProofOfIdentity" .= uProofOfIdentity u + ,"ProofOfAddress" .= uProofOfAddress u,"PersonType" .= Natural] + +-- | from json as per MangoPay format +instance FromJSON NaturalUser where + parseJSON (Object v) =NaturalUser <$> + v .: "Id" <*> + v .: "CreationDate" <*> + v .: "Email" <*> + v .: "FirstName" <*> + v .: "LastName" <*> + v .:? "Address" <*> + v .: "Birthday" <*> + v .: "Nationality" <*> + v .: "CountryOfResidence" <*> + v .:? "Occupation" <*> + v .:? "IncomeRange" <*> + v .:? "Tag" <*> + v .:? "ProofOfIdentity" <*> + v .:? "ProofOfAddress" + parseJSON _= fail "NaturalUser" + +-- | User ID +type LegalUserID = Text + +-- | the type of legal user +data LegalUserType = Business | Organization + deriving (Show,Read,Eq,Ord,Enum,Bounded,Typeable) + +-- | to json as per MangoPay format +instance ToJSON LegalUserType where + toJSON Business="BUSINESS" + toJSON Organization="ORGANIZATION" + +-- | from json as per MangoPay format +instance FromJSON LegalUserType where + parseJSON (String "BUSINESS") =pure Business + parseJSON (String "ORGANIZATION") =pure Organization + parseJSON _= fail "LegalUserType" + +-- | a legal user +-- +data LegalUser=LegalUser { + lId :: Maybe Text -- ^ The Id of the object + ,lCreationDate :: Maybe POSIXTime -- ^ The creation date of the user object + ,lEmail :: Text -- ^ The email of the company or the organization + ,lName :: Text -- ^ The name of the company or the organization + ,lLegalPersonType :: LegalUserType -- ^ The type of the legal user (‘BUSINESS’ or ’ORGANIZATION’) + ,lHeadquartersAddress :: Maybe Text -- ^ The address of the company’s headquarters + ,lLegalRepresentativeFirstName :: Text -- ^ The firstname of the company’s Legal representative person + ,lLegalRepresentativeLastName :: Text -- ^ The lastname of the company’s Legal representative person + ,lLegalRepresentativeAddress :: Maybe Text -- ^ The address of the company’s Legal representative person + ,lLegalRepresentativeEmail :: Maybe Text -- ^ The email of the company’s Legal representative person + ,lLegalRepresentativeBirthday :: POSIXTime -- ^ The birthdate of the company’s Legal representative person + ,lLegalRepresentativeNationality :: Text -- ^ the nationality of the company’s Legal representative person + ,lLegalRepresentativeCountryOfResidence :: Text -- ^ The country of residence of the company’s Legal representative person + ,lStatute :: Maybe Text -- ^ The business statute of the company + ,lTag :: Maybe Text -- ^ Custom data + ,lProofOfRegistration :: Maybe Text -- ^ The proof of registration of the company + ,lShareholderDeclaration :: Maybe Text -- ^ The shareholder declaration of the company + } + deriving (Show,Eq,Ord,Typeable) + +-- | to json as per MangoPay format +instance ToJSON LegalUser where + toJSON u=object ["Tag" .= lTag u,"Email" .= lEmail u,"Name".= lName u,"LegalPersonType" .= lLegalPersonType u,"HeadquartersAddress" .= lHeadquartersAddress u, "LegalRepresentativeFirstName" .= lLegalRepresentativeFirstName u + ,"LegalRepresentativeLastName" .= lLegalRepresentativeLastName u,"LegalRepresentativeAddress" .= lLegalRepresentativeAddress u,"LegalRepresentativeEmail" .= lLegalRepresentativeEmail u, "LegalRepresentativeBirthday" .= lLegalRepresentativeBirthday u,"LegalRepresentativeNationality" .= lLegalRepresentativeNationality u + ,"LegalRepresentativeCountryOfResidence" .= lLegalRepresentativeCountryOfResidence u,"Statute" .= lStatute u,"ProofOfRegistration" .=lProofOfRegistration u,"ShareholderDeclaration" .=lShareholderDeclaration u,"PersonType" .= Legal] + +-- | from json as per MangoPay format +instance FromJSON LegalUser where + parseJSON (Object v) =LegalUser <$> + v .: "Id" <*> + v .: "CreationDate" <*> + v .: "Email" <*> + v .: "Name" <*> + v .: "LegalPersonType" <*> + v .:? "HeadquartersAddress" <*> + v .: "LegalRepresentativeFirstName" <*> + v .: "LegalRepresentativeLastName" <*> + v .:? "LegalRepresentativeAddress" <*> + v .:? "LegalRepresentativeEmail" <*> + v .: "LegalRepresentativeBirthday" <*> + v .: "LegalRepresentativeNationality" <*> + v .: "LegalRepresentativeCountryOfResidence" <*> + v .:? "Statute" <*> + v .:? "Tag" <*> + v .:? "ProofOfRegistration" <*> + v .:? "ShareholderDeclaration" + parseJSON _= fail "NaturalUser" + +data PersonType = Natural | Legal + deriving (Show,Read,Eq,Ord,Bounded,Enum,Typeable) + +-- | to json as per MangoPay format +instance ToJSON PersonType where + toJSON Natural="NATURAL" + toJSON Legal="LEGAL" + +-- | from json as per MangoPay format +instance FromJSON PersonType where + parseJSON (String "NATURAL") =pure Natural + parseJSON (String "LEGAL") =pure Legal + parseJSON _= fail "PersonType" + +-- | a short user reference +data UserRef=UserRef { + urId :: AnyUserID + , urCreationDate :: POSIXTime + , urPersonType :: PersonType + , urEmail :: Text + , urTag :: Maybe Text + } + deriving (Show,Eq,Ord,Typeable) + +-- | to json as per MangoPay format +instance ToJSON UserRef where + toJSON ur=object [ "PersonType" .= urPersonType ur, "Email" .= urEmail ur,"Id" .= urId ur, + "Tag" .= urTag ur,"CreationDate" .= urCreationDate ur] + + +-- | from json as per MangoPay format +instance FromJSON UserRef where + parseJSON (Object v) =UserRef <$> + v .: "Id" <*> + v .: "CreationDate"<*> + v .: "PersonType" <*> + v .: "Email" <*> + v .:? "Tag" + parseJSON _=fail "UserRef" + diff --git a/src/Web/MangoPay/Wallets.hs b/src/Web/MangoPay/Wallets.hs new file mode 100644 --- /dev/null +++ b/src/Web/MangoPay/Wallets.hs @@ -0,0 +1,267 @@ +{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, OverloadedStrings, FlexibleContexts, FlexibleInstances, PatternGuards #-} +-- | handle wallets +module Web.MangoPay.Wallets where + + +import Web.MangoPay.Monad +import Web.MangoPay.Types +import Web.MangoPay.Users + +import Data.Conduit +import Data.Text +import Data.Typeable (Typeable) +import Data.Aeson +import Data.Time.Clock.POSIX (POSIXTime) +import Control.Applicative +import qualified Network.HTTP.Types as HT +import qualified Data.HashMap.Lazy as HM (delete) + +-- | create or edit a wallet +storeWallet :: (MonadBaseControl IO m, MonadResource m) => Wallet -> AccessToken -> MangoPayT m Wallet +storeWallet w at= + case wId w of + Nothing-> do + url<-getClientURL "/wallets" + postExchange url (Just at) w + Just i-> do + url<-getClientURLMultiple ["/wallets/",i] + let Object m=toJSON w + putExchange url (Just at) (Object $ HM.delete "Currency" m) + + +-- | fetch a wallet from its ID +fetchWallet :: (MonadBaseControl IO m, MonadResource m) => WalletID -> AccessToken -> MangoPayT m Wallet +fetchWallet wid at=do + url<-getClientURLMultiple ["/wallets/",wid] + req<-getGetRequest url (Just at) ([]::HT.Query) + getJSONResponse req + +-- | list all wallets for a given user +listWallets :: (MonadBaseControl IO m, MonadResource m) => AnyUserID -> Maybe Pagination -> AccessToken -> MangoPayT m (PagedList Wallet) +listWallets uid mp at=do + url<-getClientURLMultiple ["/users/",uid,"/wallets"] + req<-getGetRequest url (Just at) (paginationAttributes mp) + getJSONList req + +-- | create a new fund transfer +createTransfer :: (MonadBaseControl IO m, MonadResource m) => Transfer -> AccessToken -> MangoPayT m Transfer +createTransfer t at= do + url<-getClientURL "/transfers" + postExchange url (Just at) t + +-- | fetch a transfer from its ID +fetchTransfer :: (MonadBaseControl IO m, MonadResource m) => TransferID -> AccessToken -> MangoPayT m Transfer +fetchTransfer wid at=do + url<-getClientURLMultiple ["/transfers/",wid] + req<-getGetRequest url (Just at) ([]::HT.Query) + getJSONResponse req + +-- | list transfers for a given wallet +listTransactions :: (MonadBaseControl IO m, MonadResource m) => WalletID -> Maybe Pagination -> AccessToken -> MangoPayT m (PagedList Transaction) +listTransactions wid mp at=do + url<-getClientURLMultiple ["/wallets/",wid,"/transactions"] + req<-getGetRequest url (Just at) (paginationAttributes mp) + getJSONList req + +-- | list transfer for a given user +listTransactionsForUser :: (MonadBaseControl IO m, MonadResource m) => AnyUserID -> Maybe Pagination -> AccessToken -> MangoPayT m (PagedList Transaction) +listTransactionsForUser uid mp at=do + url<-getClientURLMultiple ["/users/",uid,"/transactions"] + req<-getGetRequest url (Just at) (paginationAttributes mp) + getJSONList req + +-- | currency amount +data Amount=Amount { + aCurrency :: Currency + ,aAmount :: Integer -- ^ all amounts should be in cents! + } + deriving (Show,Read,Eq,Ord,Typeable) + +-- | to json as per MangoPay format +instance ToJSON Amount where + toJSON b=object ["Currency" .= aCurrency b,"Amount" .= aAmount b] + +-- | from json as per MangoPay format +instance FromJSON Amount where + parseJSON (Object v) =Amount <$> + v .: "Currency" <*> + v .: "Amount" + parseJSON _=fail "Amount" + +-- | ID of a wallet +type WalletID=Text + +-- | a wallet +data Wallet = Wallet { + wId:: Maybe WalletID -- ^ The Id of the wallet + ,wCreationDate :: Maybe POSIXTime -- ^ The creation date of the object + ,wTag :: Maybe Text -- ^ Custom data + ,wOwners :: [Text] -- ^ The owner of the wallet + ,wDescription :: Text -- ^ A description of the wallet + ,wCurrency :: Currency -- ^ Currency of the wallet + ,wBalance :: Maybe Amount -- ^ The amount held on the wallet + } + deriving (Show,Eq,Ord,Typeable) + +-- | to json as per MangoPay format +instance ToJSON Wallet where + toJSON w=object ["Tag" .= wTag w,"Owners" .= wOwners w,"Description" .= wDescription w,"Currency" .= wCurrency w] + +-- | from json as per MangoPay format +instance FromJSON Wallet where + parseJSON (Object v) =Wallet <$> + v .: "Id" <*> + v .: "CreationDate" <*> + v .:? "Tag" <*> + v .: "Owners" <*> + v .: "Description" <*> + v .: "Currency" <*> + v .: "Balance" + parseJSON _=fail "Wallet" + + +-- | ID of a transfer +type TransferID=Text + +-- | status of a transfer +data TransferStatus= Created | Succeeded | Failed + deriving (Show,Read,Eq,Ord,Bounded,Enum,Typeable) + +-- | to json as per MangoPay format +instance ToJSON TransferStatus where + toJSON Created="CREATED" + toJSON Succeeded="SUCCEEDED" + toJSON Failed="FAILED" + +-- | from json as per MangoPay format +instance FromJSON TransferStatus where + parseJSON (String "CREATED") =pure Created + parseJSON (String "SUCCEEDED") =pure Succeeded + parseJSON (String "FAILED") =pure Failed + parseJSON _= fail "TransferStatus" + +-- | transfer between wallets +data Transfer = Transfer{ + tId :: Maybe TransferID -- ^ Id of the transfer + ,tCreationDate :: Maybe POSIXTime -- ^ The creation date of the object + ,tTag :: Maybe Text -- ^ Custom data + ,tAuthorId :: AnyUserID -- ^ The Id of the author + ,tCreditedUserId :: Maybe AnyUserID -- ^ The Id of the user owner of the credited wallet + ,tDebitedFunds :: Amount -- ^ The funds debited from the « debited wallet »DebitedFunds – Fees = CreditedFunds (amount received on wallet) + ,tFees :: Amount -- ^ The fees taken on the transfer.DebitedFunds – Fees = CreditedFunds (amount received on wallet) + ,tDebitedWalletID :: WalletID -- ^ The debited wallet (where the funds are held before the transfer) + ,tCreditedWalletID:: WalletID -- ^ The credited wallet (where the funds will be held after the transfer) + ,tCreditedFunds :: Maybe Amount -- ^ The funds credited on the « credited wallet »DebitedFunds – Fees = CreditedFunds (amount received on wallet) + ,tStatus :: Maybe TransferStatus -- ^ The status of the transfer: + ,tResultCode :: Maybe Text -- ^ The transaction result code + ,tResultMessage :: Maybe Text -- ^ The transaction result message + ,tExecutionDate :: Maybe POSIXTime -- ^ The execution date of the transfer + } + deriving (Show,Eq,Ord,Typeable) + +-- | to json as per MangoPay format +instance ToJSON Transfer where + toJSON t=object ["AuthorId" .= tAuthorId t,"CreditedUserId" .= tCreditedUserId t,"DebitedFunds" .= tDebitedFunds t, + "Fees" .= tFees t,"DebitedWalletID" .= tDebitedWalletID t,"CreditedWalletID" .= tCreditedWalletID t, + "Tag" .= tTag t] + + -- | from json as per MangoPay format +instance FromJSON Transfer where + parseJSON (Object v) =Transfer <$> + v .: "Id" <*> + v .: "CreationDate" <*> + v .:? "Tag" <*> + v .: "AuthorId" <*> + v .: "CreditedUserId" <*> + v .: "DebitedFunds" <*> + v .: "Fees" <*> + v .: "DebitedWalletId" <*> -- yes, it's ID one way, Id the other + v .: "CreditedWalletId" <*> -- yes, it's ID one way, Id the other + v .:? "CreditedFunds" <*> + v .:? "Status" <*> + v .:? "ResultCode" <*> + v .:? "ResultMessage" <*> + v .:? "ExecutionDate" + parseJSON _=fail "Transfer" + +-- | type of transaction +data TransactionType = PAYIN + | PAYOUT + | TRANSFER + deriving (Show,Read,Eq,Ord,Bounded,Enum,Typeable) + +-- | to json as per MangoPay format +instance ToJSON TransactionType where + toJSON =toJSON . show + +-- | from json as per MangoPay format +instance FromJSON TransactionType where + parseJSON (String s) + | ((a,_):_)<-reads $ unpack s=pure a + parseJSON _ =fail "TransactionType" + +data TransactionNature = REGULAR -- ^ just as you created the object + | REFUND -- ^ the transaction has been refunded + | REPUDIATION -- ^ the transaction has been repudiated + deriving (Show,Read,Eq,Ord,Bounded,Enum,Typeable) + +-- | to json as per MangoPay format +instance ToJSON TransactionNature where + toJSON =toJSON . show + +-- | from json as per MangoPay format +instance FromJSON TransactionNature where + parseJSON (String s) + | ((a,_):_)<-reads $ unpack s=pure a + parseJSON _ =fail "TransactionNature" + + +type TransactionID = Text + +-- | any transaction +data Transaction = Transaction{ + txId :: Maybe TransactionID -- ^ Id of the transfer + ,txCreationDate :: Maybe POSIXTime -- ^ The creation date of the object + ,txTag :: Maybe Text -- ^ Custom data + ,txAuthorId :: AnyUserID -- ^ The Id of the author + ,txCreditedUserId :: Maybe AnyUserID -- ^ The Id of the user owner of the credited wallet + ,txDebitedFunds :: Amount -- ^ The funds debited from the « debited wallet »DebitedFunds – Fees = CreditedFunds (amount received on wallet) + ,txFees :: Amount -- ^ The fees taken on the transfer.DebitedFunds – Fees = CreditedFunds (amount received on wallet) + ,txDebitedWalletID :: Maybe WalletID -- ^ The debited wallet (where the funds are held before the transfer) + ,txCreditedWalletID:: Maybe WalletID -- ^ The credited wallet (where the funds will be held after the transfer) + ,txCreditedFunds :: Maybe Amount -- ^ The funds credited on the « credited wallet »DebitedFunds – Fees = CreditedFunds (amount received on wallet) + ,txStatus :: Maybe TransferStatus -- ^ The status of the transfer: + ,txResultCode :: Maybe Text -- ^ The transaction result code + ,txResultMessage :: Maybe Text -- ^ The transaction result message + ,txExecutionDate :: Maybe POSIXTime -- ^ The execution date of the transfer + ,txType :: TransactionType -- ^ The type of the transaction + ,txNature :: TransactionNature -- ^ The nature of the transaction: + } + deriving (Show,Eq,Ord,Typeable) + +-- | to json as per MangoPay format +instance ToJSON Transaction where + toJSON t=object ["AuthorId" .= txAuthorId t,"CreditedUserId" .= txCreditedUserId t,"DebitedFunds" .= txDebitedFunds t, + "Fees" .= txFees t,"DebitedWalletID" .= txDebitedWalletID t,"CreditedWalletID" .= txCreditedWalletID t, + "Tag" .= txTag t,"Type" .= txType t,"Nature" .= txNature t] + + -- | from json as per MangoPay format +instance FromJSON Transaction where + parseJSON (Object v) =Transaction <$> + v .: "Id" <*> + v .: "CreationDate" <*> + v .:? "Tag" <*> + v .: "AuthorId" <*> + v .: "CreditedUserId" <*> + v .: "DebitedFunds" <*> + v .: "Fees" <*> + v .:? "DebitedWalletId" <*> -- yes, it's ID one way, Id the other + v .:? "CreditedWalletId" <*> -- yes, it's ID one way, Id the other + v .:? "CreditedFunds" <*> + v .:? "Status" <*> + v .:? "ResultCode" <*> + v .:? "ResultMessage" <*> + v .:? "ExecutionDate" <*> + v .: "Type" <*> + v .: "Nature" + parseJSON _=fail "Transfer" diff --git a/test/Web/MangoPay/AccessTest.hs b/test/Web/MangoPay/AccessTest.hs new file mode 100644 --- /dev/null +++ b/test/Web/MangoPay/AccessTest.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -F -pgmF htfpp #-} +-- | test access functions that can be tested +module Web.MangoPay.AccessTest where + + +import Web.MangoPay +import Web.MangoPay.TestUtils + +import Test.Framework +import Test.HUnit (Assertion) +import Data.Aeson +import qualified Data.Text as T +import Data.Maybe (fromJust, isJust) +import Data.ByteString.Lazy as BS +import Data.Time.Clock.POSIX (getPOSIXTime) +import Data.IORef (modifyIORef,readIORef) +import Control.Monad (liftM) +import Data.Conduit (runResourceT) + +-- | Take the name/email from client.conf in the current directory +-- (this file can be generated by mangopay-passphrase) +-- generates a new id/name, keeps the same email and generates a new secret +-- saves the secret to use in other tests +test_CreateCredentials :: Assertion +test_CreateCredentials=do + js<-BS.readFile "client.conf" + let mcred=decode js + assertBool (isJust mcred) + ct<-getPOSIXTime + -- max 20 characters in ClientID + let suff=T.take 20 $ T.pack $ show $ round ct + let creds=(fromJust mcred) + let newCreds=creds{cClientSecret=Nothing, + cClientID=T.append (cClientID creds) suff, + cName=T.append (cName creds) suff} + mgr<-liftM tsManager $ readIORef testState + creds2<-runResourceT $ runMangoPayT newCreds mgr Sandbox createCredentialsSecret + assertBool (isJust $ cClientSecret creds2) + let s=fromJust $ cClientSecret creds2 + -- login once with our new credentials + oat<-runResourceT $ runMangoPayT creds2 mgr Sandbox $ + oauthLogin (cClientID creds2) s + -- store access token and credentials + modifyIORef testState (\ts->ts{tsAccessToken=toAccessToken oat,tsCredentials=creds2}) + -- create hooks for all event types + mapM_ createHook [minBound .. maxBound] diff --git a/test/Web/MangoPay/AccountsTest.hs b/test/Web/MangoPay/AccountsTest.hs new file mode 100644 --- /dev/null +++ b/test/Web/MangoPay/AccountsTest.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -F -pgmF htfpp #-} +-- | test accounts +module Web.MangoPay.AccountsTest where + +import Web.MangoPay +import Web.MangoPay.TestUtils + +import Data.Maybe (isJust, fromJust) +import Test.Framework +import Test.HUnit (Assertion) + +-- | test bank account creation +test_BankAccount :: Assertion +test_BankAccount=do + usL<-testMP $ listUsers (Just $ Pagination 1 1) + assertEqual 1 (length $ plData usL) + let uid=urId $ head $ plData usL + let details=IBAN "FR3020041010124530725S03383" "CRLYFRPP" + let acc1=BankAccount Nothing Nothing (Just uid) Nothing details "JP Moresmau" (Just "Earth") + acc2<-testMP $ storeAccount acc1 + assertBool $ isJust $ baId acc2 + assertBool $ isJust $ baCreationDate acc2 + assertEqual details $ baDetails acc2 + acc3<-testMP $ fetchAccount uid $ fromJust $ baId acc2 + assertEqual details $ baDetails acc3 + accs<-testMP $ listAccounts uid Nothing + assertBool $ acc3 `elem` (plData accs) + diff --git a/test/Web/MangoPay/CardsTest.hs b/test/Web/MangoPay/CardsTest.hs new file mode 100644 --- /dev/null +++ b/test/Web/MangoPay/CardsTest.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -F -pgmF htfpp #-} +-- | test cards +module Web.MangoPay.CardsTest where + +import Web.MangoPay +import Web.MangoPay.TestUtils + +import Data.Maybe (isJust, isNothing, fromJust) +import Test.Framework +import Test.HUnit (Assertion) + +import qualified Data.Text as T + +-- | test a card registration +test_Card :: Assertion +test_Card = do + usL<-testMP $ listUsers (Just $ Pagination 1 1) + assertEqual 1 (length $ plData usL) + let uid=urId $ head $ plData usL + let cr1=mkCardRegistration uid "EUR" + cr2<-testMP $ storeCardRegistration cr1 + assertBool (isJust $ crId cr2) + assertBool (isJust $ crCreationDate cr2) + assertBool (isJust $ crCardRegistrationURL cr2) + assertBool (isJust $ crAccessKey cr2) + assertBool (isJust $ crPreregistrationData cr2) + assertBool (isNothing $ crRegistrationData cr2) + assertBool (isNothing $ crCardId cr2) + cr3<-testMP (\_->registerCard testCardInfo1 cr2) + assertBool (isJust $ crRegistrationData cr3) + cr4<-testMP $ storeCardRegistration cr3 + assertBool (isJust $ crCardId cr4) + let cid=fromJust $ crCardId cr4 + c<-testMP $ fetchCard cid + assertEqual cid $ cId c + assertBool $ not $ T.null $ cAlias c + assertBool $ not $ T.null $ cCardProvider c + assertBool $ not $ T.null $ cExpirationDate c + assertEqual UNKNOWN $ cValidity c + assertBool $ cActive c + assertEqual uid $ cUserId c + assertEqual "CB_VISA_MASTERCARD" $ cCardType c + cs<-testMP $ getAll $ listCards uid + assertBool $ not $ null cs + assertBool $ any (\ c1 -> cId c == cid) cs + + + + diff --git a/test/Web/MangoPay/DocumentsTest.hs b/test/Web/MangoPay/DocumentsTest.hs new file mode 100644 --- /dev/null +++ b/test/Web/MangoPay/DocumentsTest.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -F -pgmF htfpp #-} +-- | test documents +module Web.MangoPay.DocumentsTest where + +import Web.MangoPay +import Web.MangoPay.TestUtils + +import Test.Framework +import Test.HUnit (Assertion) +import Data.Maybe (isJust, fromJust) +import qualified Data.ByteString as BS + +-- | test document API +test_Document :: Assertion +test_Document=do + usL<-testMP $ listUsers (Just $ Pagination 1 1) + assertEqual 1 (length $ plData usL) + let uid=urId $ head $ plData usL + let d=Document Nothing Nothing Nothing IDENTITY_PROOF (Just CREATED) Nothing Nothing + d2<-testMP $ storeDocument uid d + assertBool (isJust $ dId d2) + assertBool (isJust $ dCreationDate d2) + assertEqual IDENTITY_PROOF (dType d2) + tf<-BS.readFile "data/test.jpg" + -- document has to be in CREATED status + testMP $ storePage uid (fromJust $ dId d2) tf + d3<-testMP $ storeDocument uid d2{dStatus=Just VALIDATION_ASKED} + assertEqual (Just VALIDATION_ASKED) (dStatus d3) + assertEqual (dId d2) (dId d3) + d4<-testMP $ fetchDocument uid (fromJust $ dId d2) + assertEqual (Just VALIDATION_ASKED) (dStatus d4) + + diff --git a/test/Web/MangoPay/PayinsTest.hs b/test/Web/MangoPay/PayinsTest.hs new file mode 100644 --- /dev/null +++ b/test/Web/MangoPay/PayinsTest.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -F -pgmF htfpp #-} +-- | test payins +module Web.MangoPay.PayinsTest where + +import Web.MangoPay +import Web.MangoPay.TestUtils + +import Data.Maybe (isJust, fromJust) +import Test.Framework +import Test.HUnit (Assertion) + +-- | test bankwire +test_BankWire :: Assertion +test_BankWire=do + usL<-testMP $ listUsers (Just $ Pagination 1 1) + assertEqual 1 (length $ plData usL) + let uid=urId $ head $ plData usL + let w=Wallet Nothing Nothing (Just "custom") [uid] "my wallet" "EUR" Nothing + w2<-testMP $ storeWallet w + assertBool (isJust $ wId w2) + -- bank wire does not succeed since the real transfer needs to be performed afterwards + testEventTypes [PAYIN_NORMAL_CREATED] $ do + let bw1=mkBankWire uid uid (fromJust $ wId w2) (Amount "EUR" 100) (Amount "EUR" 1) + bw2<-testMP $ storeBankWire bw1 + assertBool (isJust $ bwId bw2) + assertBool (isJust $ bwBankAccount bw2) + bw3<-testMP $ fetchBankWire (fromJust $ bwId bw2) + assertEqual (bwId bw2) (bwId bw3) + return $ bwId bw2 + +-- | test a successful card pay in +test_CardOK :: Assertion +test_CardOK = do + usL<-testMP $ listUsers (Just $ Pagination 1 1) + assertEqual 1 (length $ plData usL) + let uid=urId $ head $ plData usL + cr<-testMP $ fullRegistration uid "EUR" testCardInfo1 + assertBool (isJust $ crCardId cr) + let cid=fromJust $ crCardId cr + let w=Wallet Nothing Nothing (Just "custom") [uid] "my wallet" "EUR" Nothing + w2<-testMP $ storeWallet w + assertBool (isJust $ wId w2) + let wid=fromJust $ wId w2 + testEventTypes [PAYIN_NORMAL_CREATED,PAYIN_NORMAL_SUCCEEDED] $ do + let cp=mkCardPayin uid uid wid (Amount "EUR" 333) (Amount "EUR" 1) "http://dummy" cid + cp2<-testMP $ storeCardPayin cp + assertBool (isJust $ cpId cp2) + assertEqual (Just Succeeded) (cpStatus cp2) + w3<-testMP $ fetchWallet wid + assertEqual (Just $ Amount "EUR" 332) (wBalance w3) + ts1 <- testMP $ listTransactions wid Nothing + assertEqual 1 (length $ filter ((cpId cp2==) . txId) $ plData ts1) + return $ cpId cp2 + +-- | test a failed card pay in +-- according to +test_CardKO :: Assertion +test_CardKO = do + usL<-testMP $ listUsers (Just $ Pagination 1 1) + assertEqual 1 (length $ plData usL) + let uid=urId $ head $ plData usL + cr<-testMP $ fullRegistration uid "EUR" testCardInfo1 + assertBool (isJust $ crCardId cr) + let cid=fromJust $ crCardId cr + let w=Wallet Nothing Nothing (Just "custom") [uid] "my wallet" "EUR" Nothing + w2<-testMP $ storeWallet w + assertBool (isJust $ wId w2) + let wid=fromJust $ wId w2 + testEventTypes [PAYIN_NORMAL_CREATED,PAYIN_NORMAL_FAILED] $ do + let cp=mkCardPayin uid uid wid (Amount "EUR" 33394) (Amount "EUR" 0) "http://dummy" cid + cp2<-testMP $ storeCardPayin cp + assertBool (isJust $ cpId cp2) + assertEqual (Just Failed) (cpStatus cp2) + assertEqual (Just "009199") (cpResultCode cp2) + assertEqual (Just "PSP technical error") (cpResultMessage cp2) + w3<-testMP $ fetchWallet wid + assertEqual (Just $ Amount "EUR" 0) (wBalance w3) + return $ cpId cp2 + diff --git a/test/Web/MangoPay/PayoutsTest.hs b/test/Web/MangoPay/PayoutsTest.hs new file mode 100644 --- /dev/null +++ b/test/Web/MangoPay/PayoutsTest.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -F -pgmF htfpp #-} +-- | test payouts +module Web.MangoPay.PayoutsTest where + +import Web.MangoPay +import Web.MangoPay.TestUtils + +import Data.Maybe (isJust, fromJust) +import Test.Framework +import Test.HUnit (Assertion) + +-- | test successful payout +test_PayoutOK :: Assertion +test_PayoutOK=do + usL<-testMP $ listUsers (Just $ Pagination 1 1) + assertEqual 1 (length $ plData usL) + let uid=urId $ head $ plData usL + accs<-testMP $ listAccounts uid Nothing + assertBool $ not $ null $ plData accs + let aid=fromJust $ baId $ head $ plData accs + ws<- testMP $ listWallets uid Nothing + assertBool $ not $ null $ plData ws + let wid=fromJust $ wId $ head $ plData ws + let Just (Amount _ nb) =wBalance $ head $ plData ws + assertBool $ nb >= 100 + -- no events triggered !!! + --testEventTypes [PAYOUT_NORMAL_SUCCEEDED] $ do + let pt1=mkPayout uid wid (Amount "EUR" 100) (Amount "EUR" 0) aid + pt2<-testMP $ storePayout pt1 + assertBool $ isJust $ ptId pt2 + assertEqual (Just Created) (ptStatus pt2) + assertEqual (Just (Amount "EUR" 100)) (ptCreditedFunds pt2) + pt3 <- testMP $ fetchPayout $ fromJust $ ptId pt2 + assertEqual (Just BANK_WIRE) (ptPaymentType pt3) + -- return $ ptId pt2 + +-- | test failing payout +test_PayoutKO :: Assertion +test_PayoutKO=do + usL<-testMP $ listUsers (Just $ Pagination 1 1) + assertEqual 1 (length $ plData usL) + let uid=urId $ head $ plData usL + accs<-testMP $ listAccounts uid Nothing + assertBool $ not $ null $ plData accs + let aid=fromJust $ baId $ head $ plData accs + ws<- testMP $ listWallets uid Nothing + assertBool $ not $ null $ plData ws + let wid=fromJust $ wId $ head $ plData ws + testEventTypes [PAYOUT_NORMAL_FAILED] $ do + let pt1=mkPayout uid wid (Amount "EUR" 100000) (Amount "EUR" 0) aid + pt2<-testMP $ storePayout pt1 + assertBool $ isJust $ ptId pt2 + assertEqual (Just Failed) (ptStatus pt2) + pt3 <- testMP $ fetchPayout $ fromJust $ ptId pt2 + assertEqual (Just BANK_WIRE) (ptPaymentType pt3) + assertEqual (Just "001001") (ptResultCode pt3) + assertEqual (Just "Unsufficient wallet balance") (ptResultMessage pt3) + return $ ptId pt2 + + diff --git a/test/Web/MangoPay/RefundsTest.hs b/test/Web/MangoPay/RefundsTest.hs new file mode 100644 --- /dev/null +++ b/test/Web/MangoPay/RefundsTest.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -F -pgmF htfpp #-} +-- | test refunds +module Web.MangoPay.RefundsTest where + +import Web.MangoPay +import Web.MangoPay.TestUtils + +import Data.Maybe (isJust, fromJust) +import Test.Framework +import Test.HUnit (Assertion) + +-- | test a successful card pay in + full refund +test_SimpleCardRefund :: Assertion +test_SimpleCardRefund = do + usL<-testMP $ listUsers (Just $ Pagination 1 1) + assertEqual 1 (length $ plData usL) + let uid=urId $ head $ plData usL + cr<-testMP $ fullRegistration uid "EUR" testCardInfo1 + assertBool (isJust $ crCardId cr) + let cid=fromJust $ crCardId cr + let w=Wallet Nothing Nothing (Just "custom") [uid] "my wallet" "EUR" Nothing + w2<-testMP $ storeWallet w + assertBool (isJust $ wId w2) + let wid=fromJust $ wId w2 + (Just cp)<-testEventTypes' [PAYIN_NORMAL_CREATED,PAYIN_NORMAL_SUCCEEDED] $ do + let cp=mkCardPayin uid uid wid (Amount "EUR" 333) (Amount "EUR" 1) "http://dummy" cid + cp2<-testMP $ storeCardPayin cp + assertBool (isJust $ cpId cp2) + assertEqual (Just Succeeded) (cpStatus cp2) + w3<-testMP $ fetchWallet wid + assertEqual (Just $ Amount "EUR" 332) (wBalance w3) + return $ cpId cp2 + -- PAYIN_REFUND_CREATED not received ??? + testEventTypes [PAYIN_REFUND_SUCCEEDED] $ do + let rr=RefundRequest uid Nothing Nothing + r<-testMP $ refundPayin cp rr + assertEqual PAYIN (rInitialTransactionType r) + r2<-testMP $ fetchRefund (rId r) + assertEqual cp $ rInitialTransactionId r2 + assertEqual (Amount "EUR" 333) $ rCreditedFunds r2 + return $ Just $ rId r + +-- | test a successful card pay in + partial refund +test_AdvancedCardRefund :: Assertion +test_AdvancedCardRefund = do + usL<-testMP $ listUsers (Just $ Pagination 1 1) + assertEqual 1 (length $ plData usL) + let uid=urId $ head $ plData usL + cr<-testMP $ fullRegistration uid "EUR" testCardInfo1 + assertBool (isJust $ crCardId cr) + let cid=fromJust $ crCardId cr + let w=Wallet Nothing Nothing (Just "custom") [uid] "my wallet" "EUR" Nothing + w2<-testMP $ storeWallet w + assertBool (isJust $ wId w2) + let wid=fromJust $ wId w2 + (Just cp)<-testEventTypes' [PAYIN_NORMAL_CREATED,PAYIN_NORMAL_SUCCEEDED] $ do + let cp=mkCardPayin uid uid wid (Amount "EUR" 333) (Amount "EUR" 1) "http://dummy" cid + cp2<-testMP $ storeCardPayin cp + assertBool (isJust $ cpId cp2) + assertEqual (Just Succeeded) (cpStatus cp2) + w3<-testMP $ fetchWallet wid + assertEqual (Just $ Amount "EUR" 332) (wBalance w3) + return $ cpId cp2 + -- PAYIN_REFUND_CREATED not received ??? + testEventTypes [PAYIN_REFUND_SUCCEEDED] $ do + let rr=RefundRequest uid (Just $ Amount "EUR" 100) (Just $ Amount "EUR" 1) + r<-testMP $ refundPayin cp rr + assertEqual PAYIN (rInitialTransactionType r) + r2<-testMP $ fetchRefund (rId r) + assertEqual cp $ rInitialTransactionId r2 + assertEqual (Amount "EUR" 99) $ rCreditedFunds r2 + return $ Just $ rId r + +-- | test transfer + full refund +test_TransferRefund :: Assertion +test_TransferRefund = do + usL<-testMP $ listUsers (Just $ Pagination 1 2) + assertEqual 2 (length $ plData usL) + let [uid1,uid2] = map urId $ plData usL + assertBool (uid1 /= uid2) + let w1=Wallet Nothing Nothing (Just "custom") [uid1] "my wallet" "EUR" Nothing + w1'<-testMP $ storeWallet w1 + let uw1=fromJust $ wId w1' + let w2=Wallet Nothing Nothing (Just "custom") [uid2] "my wallet" "EUR" Nothing + w2'<-testMP $ storeWallet w2 + let uw2=fromJust $ wId w2' + assertBool (uw1 /= uw2) + + cr<-testMP $ fullRegistration uid1 "EUR" testCardInfo1 + assertBool (isJust $ crCardId cr) + let cid=fromJust $ crCardId cr + testEventTypes [PAYIN_NORMAL_CREATED,PAYIN_NORMAL_SUCCEEDED] $ do + let cp=mkCardPayin uid1 uid1 uw1 (Amount "EUR" 333) (Amount "EUR" 1) "http://dummy" cid + cp2<-testMP $ storeCardPayin cp + assertEqual (Just Succeeded) (cpStatus cp2) + return $ cpId cp2 + + (Just tr)<-testEventTypes' [TRANSFER_NORMAL_CREATED,TRANSFER_NORMAL_SUCCEEDED] $ do + let t1=Transfer Nothing Nothing Nothing uid1 (Just uid2) (Amount "EUR" 100) (Amount "EUR" 1) + uw1 uw2 Nothing Nothing Nothing Nothing Nothing + t1'<-testMP $ createTransfer t1 + assertBool (isJust $ tId t1') + assertEqual (Just $ Amount "EUR" 99) (tCreditedFunds t1') + t2'<-testMP $ fetchTransfer (fromJust $ tId t1') + assertEqual t1' t2' + ts1 <- testMP $ listTransactions uw1 Nothing + assertEqual 1 (length $ filter ((tId t1'==) . txId) $ plData ts1) + ts2 <- testMP $ listTransactions uw2 Nothing + assertEqual 1 (length $ filter ((tId t1'==) . txId) $ plData ts2) + uts1 <- testMP $ listTransactionsForUser uid1 (Just $ Pagination 1 50) + assertEqual 1 (length $ filter ((tId t1'==) . txId) $ plData uts1) + return $ tId t1' + + testEventTypes [TRANSFER_REFUND_CREATED,TRANSFER_REFUND_SUCCEEDED] $ do + r<-testMP $ refundTransfer tr uid1 + assertEqual TRANSFER (rInitialTransactionType r) + r2<-testMP $ fetchRefund (rId r) + assertEqual tr $ rInitialTransactionId r2 + assertEqual (Amount "EUR" 100) $ rCreditedFunds r2 + return $ Just $ rId r diff --git a/test/Web/MangoPay/TestUtils.hs b/test/Web/MangoPay/TestUtils.hs new file mode 100644 --- /dev/null +++ b/test/Web/MangoPay/TestUtils.hs @@ -0,0 +1,234 @@ +{-# LANGUAGE RankNTypes,OverloadedStrings,DeriveDataTypeable #-} +{-# OPTIONS_GHC -F -pgmF htfpp #-} +module Web.MangoPay.TestUtils where + +import Web.MangoPay + +import Data.ByteString.Lazy as BS hiding (map,any,null) +import Network.HTTP.Conduit as H +import Data.Conduit +import Data.Maybe +import Test.Framework + +import Network.Wai as W +import Network.Wai.Handler.Warp +import Network.HTTP.Types (status200) +import Blaze.ByteString.Builder (copyByteString) +import Data.Aeson as A +import Control.Concurrent (forkIO, ThreadId, threadDelay) +import Control.Concurrent.MVar (MVar, newMVar, putMVar, takeMVar) +import Control.Monad (when, void, liftM) +import Control.Monad.IO.Class (liftIO) + +import Data.Text (Text) +import Data.List +import Data.Typeable +import Control.Applicative +import Test.HUnit (Assertion) +import Data.Default (def) +import Data.IORef +import System.IO.Unsafe (unsafePerformIO) + +-- | a test card +testCardInfo1 :: CardInfo +testCardInfo1 = CardInfo "4970100000000154" "1220" "123" + +-- | test MangoPay API call, logging in with the client credentials +-- expects a file called client.test.conf containing the JSON of client credentials +-- in the current directory +testMP :: forall b. + (AccessToken -> MangoPayT (ResourceT IO) b) + -> IO b +testMP f= do + ior<-readIORef testState + let mgr=tsManager ior + let at=tsAccessToken ior + let cred=tsCredentials ior + runResourceT $ runMangoPayT cred mgr Sandbox $ f at + +-- | the test state as a top level global variable +-- +-- since HTF does not let us thread a parameter through tests +testState :: IORef TestState +{-# NOINLINE testState #-} +testState = unsafePerformIO (newIORef $ TestState zero zero zero zero zero) + where zero=error "testState has not been initialized yet" + + +-- | the test state we keep over all tests +data TestState=TestState { + tsAccessToken :: AccessToken -- ^ the access token if we're logged in + ,tsCredentials :: Credentials -- ^ the credentials + ,tsManager :: H.Manager -- ^ the http manager + ,tsHookEndPoint :: HookEndPoint -- ^ the end point for notifications + ,tsReceivedEvents :: ReceivedEvents -- ^ the received events + } + + +-- | read end point information from hook.test.conf in current folder +getHookEndPoint :: IO HookEndPoint +getHookEndPoint = do + js<-BS.readFile "hook.test.conf" + let mhook=decode js + assertBool (isJust mhook) + return $ fromJust mhook + +-- | simple configuration to tell the tests what endpoint to use for notifications +data HookEndPoint = HookEndPoint{ + hepUrl :: Text + ,hepPort :: Int + } deriving (Show,Read,Eq,Ord,Typeable) + +-- | to json +instance ToJSON HookEndPoint where + toJSON h=object ["Url" .= hepUrl h,"Port" .= hepPort h] + +-- | from json +instance FromJSON HookEndPoint where + parseJSON (Object v) =HookEndPoint <$> + v .: "Url" <*> + v .: "Port" + parseJSON _=fail "HookEndPoint" + + +-- | the events received via the notification hook +-- uses a MVar for storing events +data ReceivedEvents=ReceivedEvents{ + events::MVar [Either EventResult Event] + } + +-- | creates the new ReceivedEvents +newReceivedEvents :: IO ReceivedEvents +newReceivedEvents=do + mv<-newMVar [] + return $ ReceivedEvents mv + +-- | test an event, checking the resource id and the event type +testEvent :: Maybe Text -> EventType -> Event -> Bool +testEvent tid et evt= tid == (Just $ eResourceId evt) + && et == eEventType evt + +-- | check that we're receiving events of the given type with the resource id returned by the passed test +testEventTypes :: [EventType] + -> IO (Maybe Text) + -> Assertion +testEventTypes evtTs =void . testEventTypes' evtTs + +-- | check that we're receiving events of the given type with the resource id returned by the passed test +-- returns the result of the inner test +testEventTypes' :: [EventType] + -> IO (Maybe Text) + -> IO (Maybe Text) +testEventTypes' evtTs ops=do + res<-liftM tsReceivedEvents $ readIORef testState + a<-ops + mapM_ (testSearchEvent a) evtTs + er<-waitForEvent res (map (testEvent a) evtTs) 5 + assertEqual EventsOK er + return a + +-- | assert that we find an event for the given resource id and event type +testSearchEvent :: Maybe Text -> EventType -> Assertion +testSearchEvent tid evtT=do + es<-testMP $ searchEvents (def{espEventType=Just evtT}) + assertBool (not $ null es) + assertBool (any ((tid ==) . Just . eResourceId) es) + +-- | create a hook for a given event type +createHook :: EventType -> Assertion +createHook evtT= do + hook<-liftM tsHookEndPoint $ readIORef testState + h<-testMP $ storeHook (Hook Nothing Nothing Nothing (hepUrl hook) Enabled Nothing evtT) + assertBool (isJust $ hId h) + h2<-testMP $ fetchHook (fromJust $ hId h) + assertEqual (hId h) (hId h2) + assertEqual (Just Valid) (hValidity h) + +-- | run a test with the notification server running +testEvents :: IO a -- ^ the test, returning a value + -> [a -> Event -> Bool] -- ^ the test on the events, taking into account the returned value + -> Assertion +testEvents ops tests=do + res<-liftM tsReceivedEvents $ readIORef testState + a<-ops + er<-waitForEvent res (map ($ a) tests) 30 + assertEqual EventsOK er + +-- | result of waiting for event +data EventResult = Timeout -- ^ didn't receive all expected events + | EventsOK -- ^ OK: everything expected received, nothing unexpected + | ExtraEvent Event -- ^ unexpected + | UnhandledNotification String -- ^ notification we couldn't parse + deriving (Show,Eq,Ord,Typeable) + +-- | wait till we receive all the expected events, and none other, for a maximum number of seconds +waitForEvent :: ReceivedEvents + -> [Event -> Bool] -- ^ function on the expected event + -> Integer -- ^ delay in seconds + -> IO EventResult +waitForEvent _ _ del | del<=0=return Timeout +waitForEvent rc fs del=do + mevt<-popReceivedEvent rc + case (mevt,fs) of + (Nothing,[])->return EventsOK -- nothing left to process + (Just (Left er),_)->return er -- some notification we didn't understand + (Just (Right evt),[])->return $ ExtraEvent evt -- an event that doesn't match + (Nothing,_)->do -- no event yet + threadDelay 1000000 + waitForEvent rc fs (del-1) + (Just (Right evt),_)-> -- an event, does it match + case Data.List.foldl' (match1 evt) ([],False) fs of + (_,False)->return $ ExtraEvent evt -- doesn't match + (fs2,_)-> waitForEvent rc fs2 del -- matched, either we have more to do or we need to check no unexpected event was found + + where + -- | match the first event function and return all the non matching function, and a flag indicating if we matched + match1 :: Event -> ([Event -> Bool],Bool) -> (Event -> Bool) -> ([Event -> Bool],Bool) + match1 evt (nfs,False) f + | f evt=(nfs,True) + | otherwise=(f:nfs,False) + match1 _ (nfs,True) f=(f:nfs,True) + +-- | get one received event (and remove it from the underlying storage) +popReceivedEvent :: ReceivedEvents -> IO (Maybe (Either EventResult Event)) +popReceivedEvent (ReceivedEvents mv)=do + evts<-takeMVar mv + case evts of + []->do + putMVar mv [] + return Nothing + (e:es)->do + putMVar mv es + return $ Just e + +-- | get all received events (and remove them from the underlying storage) +popReceivedEvents :: ReceivedEvents -> IO [Either EventResult Event] +popReceivedEvents (ReceivedEvents mv)=do + evts<-takeMVar mv + putMVar mv [] + return evts + +-- | add a new event +pushReceivedEvent :: ReceivedEvents -> Either EventResult Event -> IO () +pushReceivedEvent (ReceivedEvents mv) evt=do + evts' <-takeMVar mv + -- we're getting events in duplicate ??? + let ns = if evt `Prelude.elem` evts' then evts' else evt:evts' + putMVar mv ns + +-- | start a HTTP server listening on the given port +-- if the path info is "mphook", then we'll push the received event +startHTTPServer :: Port -> ReceivedEvents -> IO ThreadId +startHTTPServer p revts= + forkIO $ run p app + where + app req = do + when (pathInfo req == ["mphook"]) $ do + let mevt=eventFromQueryString $ W.queryString req + liftIO $ case mevt of + Just evt->do + pushReceivedEvent revts $ Right evt + print evt + Nothing->pushReceivedEvent revts $ Left $ UnhandledNotification $ show $ W.queryString req + return $ W.responseBuilder status200 [("Content-Type", "text/plain")] $ copyByteString "noop" + diff --git a/test/Web/MangoPay/UsersTest.hs b/test/Web/MangoPay/UsersTest.hs new file mode 100644 --- /dev/null +++ b/test/Web/MangoPay/UsersTest.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -F -pgmF htfpp #-} +module Web.MangoPay.UsersTest where + +import Web.MangoPay +import Web.MangoPay.TestUtils + +import Test.Framework +import Test.HUnit (Assertion) +import Data.Maybe (fromJust, isJust) + +testNaturalUser :: NaturalUser +testNaturalUser=NaturalUser Nothing Nothing "jpmoresmau@gmail.com" "JP" "Moresmau" Nothing 11111 "FR" "FR" + (Just "Haskell contractor") (Just IncomeRange2) Nothing Nothing Nothing + +test_NaturalUser :: Assertion +test_NaturalUser = do + u<-testMP $ storeNaturalUser testNaturalUser + assertBool (isJust $ uId u) + assertBool (isJust $ uCreationDate u) + uf<-testMP $ fetchNaturalUser (fromJust $ uId u) + assertEqual (uEmail testNaturalUser) (uEmail uf) + assertEqual Nothing (uAddress uf) + ue<-testMP $ storeNaturalUser (uf{uAddress=Just "St Guilhem"}) + assertEqual (Just "St Guilhem") (uAddress ue) + assertEqual (Just IncomeRange2) (uIncomeRange ue) + eu<-testMP $ getUser (fromJust $ uId u) + assertEqual (Left ue) eu + usL<-testMP $ listUsers (Just $ Pagination 1 100) + assertEqual 1 (length $ filter (((fromJust $ uId u)==) . urId) $ plData usL) + +testLegalUser :: LegalUser +testLegalUser = LegalUser Nothing Nothing "jpmoresmau@gmail.com" "JP Moresmau" Business Nothing + "JP" "Moresmau" (Just "my house") Nothing 222222 "FR" "FR" Nothing Nothing Nothing Nothing + +test_LegalUser :: Assertion +test_LegalUser = do + l<-testMP $ storeLegalUser testLegalUser + assertBool (isJust $ lId l) + assertBool (isJust $ lCreationDate l) + lf<-testMP $ fetchLegalUser (fromJust $ lId l) + assertEqual (lEmail testLegalUser) (lEmail lf) + assertEqual Nothing (lHeadquartersAddress lf) + le<-testMP $ storeLegalUser (lf{lHeadquartersAddress=Just "St Guilhem"}) + assertEqual (Just "St Guilhem") (lHeadquartersAddress le) + assertEqual "Moresmau" (lLegalRepresentativeLastName le) + assertEqual (Just "my house") (lLegalRepresentativeAddress le) -- this is lost, see https://mangopay.desk.com/customer/portal/questions/5980417-legalrepresentativeaddress-in-legaluser-api + assertEqual Nothing (lProofOfRegistration le) + assertEqual Nothing (lShareholderDeclaration le) + el<-testMP $ getUser (fromJust $ lId l) + assertEqual (Right le) el + usL<-testMP $ listUsers (Just $ Pagination 1 100) + assertEqual 1 (length $ filter (((fromJust $ lId l)==) . urId) $ plData usL) + +test_PaginationUsers :: Assertion +test_PaginationUsers = do + usL<-testMP $ listUsers (Just $ Pagination 1 1) + print usL + assertEqual 1 (length $ plData usL) + assertEqual 2 (plItemCount usL) + assertEqual 2 (plPageCount usL) + usL2<-testMP $ listUsers (Just $ Pagination 1 10) + assertEqual 2 (length $ plData usL2) + assertEqual 2 (plItemCount usL2) + assertEqual 1 (plPageCount usL2) + us<-testMP $ getAll listUsers + assertEqual 2 (length us) diff --git a/test/Web/MangoPay/WalletsTest.hs b/test/Web/MangoPay/WalletsTest.hs new file mode 100644 --- /dev/null +++ b/test/Web/MangoPay/WalletsTest.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -F -pgmF htfpp #-} +-- | test wallets and transfers +module Web.MangoPay.WalletsTest where + +import Web.MangoPay +import Web.MangoPay.TestUtils + +import Test.Framework +import Test.HUnit (Assertion) +import Data.Maybe (isJust, fromJust) + +-- | test wallet API +test_Wallet :: Assertion +test_Wallet = do + usL<-testMP $ listUsers (Just $ Pagination 1 1) + assertEqual 1 (length $ plData usL) + let uid=urId $ head $ plData usL + let w=Wallet Nothing Nothing (Just "custom") [uid] "my wallet" "EUR" Nothing + w2<-testMP $ storeWallet w + assertBool (isJust $ wId w2) + assertBool (isJust $ wCreationDate w2) + w3<-testMP $ storeWallet w2{wTag=Just "custom2"} + assertEqual (Just "custom2") (wTag w3) + assertEqual (wId w2) (wId w3) + w4<-testMP $ fetchWallet (fromJust $ wId w2) + assertEqual (Just "custom2") (wTag w4) + assertEqual (wId w2) (wId w4) + assertEqual (Just $ Amount "EUR" 0) (wBalance w4) + ws<-testMP $ listWallets uid (Just $ Pagination 1 100) + assertBool (not (null $ plData ws)) + assertEqual 1 (length $ filter ((wId w3 ==) . wId) $ plData ws) + +-- | test transfer API + notifications on failure +test_FailedTransfer :: Assertion +test_FailedTransfer = do + usL<-testMP $ listUsers (Just $ Pagination 1 2) + assertEqual 2 (length $ plData usL) + let [uid1,uid2] = map urId $ plData usL + assertBool (uid1 /= uid2) + ws<- testMP $ listWallets uid1 Nothing + assertBool $ not $ null $ plData ws + let uw1=fromJust $ wId $ head $ plData ws + let w2=Wallet Nothing Nothing (Just "custom") [uid2] "my wallet" "EUR" Nothing + w2'<-testMP $ storeWallet w2 + let uw2=fromJust $ wId w2' + assertBool (uw1 /= uw2) + -- transfer will fail since I have no money + testEventTypes [TRANSFER_NORMAL_CREATED,TRANSFER_NORMAL_FAILED] $ do + let t1=Transfer Nothing Nothing Nothing uid1 (Just uid2) (Amount "EUR" 100) (Amount "EUR" 1) + uw1 uw2 Nothing Nothing Nothing Nothing Nothing + t1'<-testMP $ createTransfer t1 + assertBool (isJust $ tId t1') + assertEqual (Just $ Amount "EUR" 99) (tCreditedFunds t1') + t2'<-testMP $ fetchTransfer (fromJust $ tId t1') + assertEqual t1' t2' + ts1 <- testMP $ listTransactions uw1 Nothing + assertEqual 1 (length $ filter ((tId t1'==) . txId) $ plData ts1) + ts2 <- testMP $ listTransactions uw2 Nothing + assertEqual 1 (length $ filter ((tId t1'==) . txId) $ plData ts2) + uts1 <- testMP $ listTransactionsForUser uid1 Nothing + assertEqual 1 (length $ filter ((tId t1'==) . txId) $ plData uts1) + return $ tId t1' + +-- | test transfer API + notifications on success +test_SuccessfulTransfer :: Assertion +test_SuccessfulTransfer = do + usL<-testMP $ listUsers (Just $ Pagination 1 2) + assertEqual 2 (length $ plData usL) + let [uid1,uid2] = map urId $ plData usL + assertBool (uid1 /= uid2) + ws<- testMP $ listWallets uid1 Nothing + assertBool $ not $ null $ plData ws + let uw1=fromJust $ wId $ head $ plData ws + let w2=Wallet Nothing Nothing (Just "custom") [uid2] "my wallet" "EUR" Nothing + w2'<-testMP $ storeWallet w2 + let uw2=fromJust $ wId w2' + assertBool (uw1 /= uw2) + + cr<-testMP $ fullRegistration uid1 "EUR" testCardInfo1 + assertBool (isJust $ crCardId cr) + let cid=fromJust $ crCardId cr + testEventTypes [PAYIN_NORMAL_CREATED,PAYIN_NORMAL_SUCCEEDED] $ do + let cp=mkCardPayin uid1 uid1 uw1 (Amount "EUR" 333) (Amount "EUR" 1) "http://dummy" cid + cp2<-testMP $ storeCardPayin cp + assertEqual (Just Succeeded) (cpStatus cp2) + return $ cpId cp2 + + testEventTypes [TRANSFER_NORMAL_CREATED,TRANSFER_NORMAL_SUCCEEDED] $ do + let t1=Transfer Nothing Nothing Nothing uid1 (Just uid2) (Amount "EUR" 100) (Amount "EUR" 1) + uw1 uw2 Nothing Nothing Nothing Nothing Nothing + t1'<-testMP $ createTransfer t1 + assertBool (isJust $ tId t1') + assertEqual (Just $ Amount "EUR" 99) (tCreditedFunds t1') + t2'<-testMP $ fetchTransfer (fromJust $ tId t1') + assertEqual t1' t2' + ts1 <- testMP $ listTransactions uw1 Nothing + assertEqual 1 (length $ filter ((tId t1'==) . txId) $ plData ts1) + ts2 <- testMP $ listTransactions uw2 Nothing + assertEqual 1 (length $ filter ((tId t1'==) . txId) $ plData ts2) + uts1 <- testMP $ listTransactionsForUser uid1 Nothing + assertEqual 1 (length $ filter ((tId t1'==) . txId) $ plData uts1) + return $ tId t1' diff --git a/test/mangopay-tests.hs b/test/mangopay-tests.hs new file mode 100644 --- /dev/null +++ b/test/mangopay-tests.hs @@ -0,0 +1,49 @@ +{-# OPTIONS_GHC -F -pgmF htfpp #-} +-- | entry module for tests +module Main where + + +import Test.Framework + +import {-@ HTF_TESTS @-} Web.MangoPay.AccessTest +import {-@ HTF_TESTS @-} Web.MangoPay.UsersTest +import {-@ HTF_TESTS @-} Web.MangoPay.WalletsTest +import {-@ HTF_TESTS @-} Web.MangoPay.DocumentsTest +import {-@ HTF_TESTS @-} Web.MangoPay.PayinsTest +import {-@ HTF_TESTS @-} Web.MangoPay.CardsTest +import {-@ HTF_TESTS @-} Web.MangoPay.RefundsTest +import {-@ HTF_TESTS @-} Web.MangoPay.AccountsTest +import {-@ HTF_TESTS @-} Web.MangoPay.PayoutsTest + +import Web.MangoPay.TestUtils + +import Control.Exception (bracket) +import Network.HTTP.Conduit as H +import Control.Concurrent (killThread, threadDelay) +import Control.Monad.IO.Class (liftIO) +import Data.IORef (modifyIORef, readIORef) +import Test.HUnit (Assertion) +import Control.Monad (liftM) + +-- | test entry point +main :: IO() +main = H.withManager (\mgr->liftIO $ do + hook<-getHookEndPoint + res<-newReceivedEvents + -- initial state + modifyIORef testState (\ts->ts{tsManager=mgr,tsHookEndPoint=hook,tsReceivedEvents=res}) + bracket + (startHTTPServer (hepPort hook) res) + killThread + (\_->htfMain $ htf_importedTests ++ [htf_thisModulesTests]) + ) + +-- | test there are no unprocessed events +test_Final :: Assertion +test_Final=do + -- wait in case events still arrive + threadDelay $ 5 * 1000000 + res<-liftM tsReceivedEvents $ readIORef testState + evts<-popReceivedEvents res + assertEqual [] evts +