packages feed

mangopay (empty) → 1.0

raw patch · 28 files changed

+3413/−0 lines, 28 filesdep +HTFdep +HUnitdep +aesonsetup-changed

Dependencies added: HTF, HUnit, aeson, attoparsec, attoparsec-conduit, base, base16-bytestring, base64-bytestring, blaze-builder, bytestring, case-insensitive, conduit, data-default, http-conduit, http-types, lifted-base, mangopay, monad-control, resourcet, text, time, transformers, transformers-base, unordered-containers, utf8-string, wai, warp

Files

+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ exe/Main.hs view
@@ -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"
+ mangopay.cabal view
@@ -0,0 +1,146 @@+name:           mangopay+version:        1.0+cabal-version:  >= 1.8+build-type:     Simple+author:         JP Moresmau <jpmoresmau@gmail.com>+license:        BSD3+license-file:   LICENSE+copyright:      (c) 2014 Prowdsponsor+category:       Web+homepage:       https://github.com/prowdsponsor/mangopay+maintainer:     Prowdsponsor <opensource@prowdsponsor.com>+synopsis:       Bindings to the MangoPay API++description:+  This package provides Haskell bindings to the+  <http://www.mangopay.com/ MangoPay> 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
+ src/Web/MangoPay.hs view
@@ -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
+ src/Web/MangoPay/Access.hs view
@@ -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
+ src/Web/MangoPay/Accounts.hs view
@@ -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"
+ src/Web/MangoPay/Cards.hs view
@@ -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"  +
+ src/Web/MangoPay/Documents.hs view
@@ -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"+        +        +        +
+ src/Web/MangoPay/Events.hs view
@@ -0,0 +1,213 @@+{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, OverloadedStrings, FlexibleContexts, FlexibleInstances #-}+-- | handle events+-- <http://docs.mangopay.com/api-references/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 <http://docs.mangopay.com/v1-api-references/notifications/>+-- 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 <http://docs.mangopay.com/v1-api-references/notifications/>+-- 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"
+ src/Web/MangoPay/Monad.hs view
@@ -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++
+ src/Web/MangoPay/Payins.hs view
@@ -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"   +
+ src/Web/MangoPay/Payouts.hs view
@@ -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"   +  +
+ src/Web/MangoPay/Refunds.hs view
@@ -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"
+ src/Web/MangoPay/Types.hs view
@@ -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+-- <http://docs.mangopay.com/api-references/pagination/>+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
+ src/Web/MangoPay/Users.hs view
@@ -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+-- <http://docs.mangopay.com/api-references/users/natural-users/>+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+-- <http://docs.mangopay.com/api-references/users/legal-users/>    +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"+
+ src/Web/MangoPay/Wallets.hs view
@@ -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"
+ test/Web/MangoPay/AccessTest.hs view
@@ -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]
+ test/Web/MangoPay/AccountsTest.hs view
@@ -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)+
+ test/Web/MangoPay/CardsTest.hs view
@@ -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+  + +  +
+ test/Web/MangoPay/DocumentsTest.hs view
@@ -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)+  +
+ test/Web/MangoPay/PayinsTest.hs view
@@ -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 <http://docs.mangopay.com/api-references/test-payment/>+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+
+ test/Web/MangoPay/PayoutsTest.hs view
@@ -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+    +
+ test/Web/MangoPay/RefundsTest.hs view
@@ -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
+ test/Web/MangoPay/TestUtils.hs view
@@ -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+-- <http://www.haskell.org/haskellwiki/Top_level_mutable_state>+-- 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"+
+ test/Web/MangoPay/UsersTest.hs view
@@ -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)
+ test/Web/MangoPay/WalletsTest.hs view
@@ -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'
+ test/mangopay-tests.hs view
@@ -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+