packages feed

mangopay 1.0 → 1.1

raw patch · 18 files changed

+159/−91 lines, 18 filesdep +monad-loggerdep +template-haskelldep +vector

Dependencies added: monad-logger, template-haskell, vector

Files

exe/Main.hs view
@@ -3,6 +3,7 @@  import Web.MangoPay +import Control.Monad.Logger import Data.Aeson import Data.Text import Network.HTTP.Conduit@@ -11,6 +12,7 @@ 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@@ -21,7 +23,7 @@                 [cid,name,email]->do                        let cred=Credentials (pack cid) (pack name) (pack email) Nothing                        cred2<-withManager (\mgr->-                                runMangoPayT cred mgr Sandbox createCredentialsSecret)+                                runStdoutLoggingT $ runMangoPayT cred mgr Sandbox createCredentialsSecret)                        putStrLn $ unpack $ fromJust $ cClientSecret cred2                        BS.writeFile "client.conf" $ encode cred2                        return ()
mangopay.cabal view
@@ -1,5 +1,5 @@ name:           mangopay-version:        1.0+version:        1.1 cabal-version:  >= 1.8 build-type:     Simple author:         JP Moresmau <jpmoresmau@gmail.com>@@ -49,6 +49,9 @@      , utf8-string >=0.3.7 && <0.4      , base64-bytestring >=1.0.0 && <1.1      , case-insensitive >=1.1.0 && <1.2+     , monad-logger                  >= 0.3        && < 0.4+     , vector >=0.10.9 && <0.11+     , template-haskell   ghc-options:      -Wall   other-modules:                     Web.MangoPay.Access,@@ -91,6 +94,9 @@      , base16-bytestring      , utf8-string >=0.3.7 && <0.4      , case-insensitive >=1.1.0 && <1.2+     , monad-logger                  >= 0.3        && < 0.4+     , vector >=0.10.9 && <0.11+     , template-haskell   ghc-options:     -Wall -rtsopts   hs-source-dirs:  exe   main-is:         Main.hs@@ -128,6 +134,9 @@      , wai      , base64-bytestring >=1.0.0 && <1.1      , case-insensitive >=1.1.0 && <1.2+     , monad-logger                  >= 0.3        && < 0.4+     , vector >=0.10.9 && <0.11+     , template-haskell   other-modules:                   Web.MangoPay.UsersTest,                   Web.MangoPay.TestUtils,
src/Web/MangoPay.hs view
@@ -14,6 +14,7 @@         ,OAuthToken(..)         ,Pagination(..)         ,PagedList(..)+        ,MPUsableMonad                  -- access         ,createCredentialsSecret
src/Web/MangoPay/Access.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleContexts, OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts, OverloadedStrings, ConstraintKinds #-} -- | access methods for login, creating clients... module Web.MangoPay.Access  (@@ -10,7 +10,6 @@ import Web.MangoPay.Monad import Web.MangoPay.Types -import Data.Conduit import Data.Text  import Network.HTTP.Conduit (applyBasicAuth)@@ -20,7 +19,7 @@ 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 ::  (MPUsableMonad m) => MangoPayT m Credentials createCredentialsSecret =do         creds<- getCreds          if isNothing $ cClientSecret creds @@ -29,7 +28,7 @@  -- | 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 :: (MPUsableMonad 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
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, OverloadedStrings, FlexibleContexts, FlexibleInstances, PatternGuards #-}+{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, OverloadedStrings, FlexibleContexts, FlexibleInstances, PatternGuards, ConstraintKinds #-} -- | handle bank accounts  module Web.MangoPay.Accounts where @@ -6,7 +6,6 @@ import Web.MangoPay.Types import Web.MangoPay.Users -import Data.Conduit import Data.Text import Data.Typeable (Typeable) import Data.Aeson@@ -16,7 +15,7 @@ import qualified Network.HTTP.Types as HT  -- | create an account-storeAccount ::  (MonadBaseControl IO m, MonadResource m) => BankAccount -> AccessToken -> MangoPayT m BankAccount+storeAccount ::  (MPUsableMonad m) => BankAccount -> AccessToken -> MangoPayT m BankAccount storeAccount ba at   | Just uid<-baUserId ba= do     url<-getClientURLMultiple ["/users/",uid,"/bankaccounts/",typeName $ baDetails ba]@@ -24,14 +23,14 @@   | 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 :: (MPUsableMonad 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 :: (MPUsableMonad 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)
src/Web/MangoPay/Cards.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, OverloadedStrings, FlexibleContexts, FlexibleInstances, PatternGuards #-}+{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, OverloadedStrings, FlexibleContexts, FlexibleInstances, PatternGuards, ConstraintKinds #-} -- | handle cards module Web.MangoPay.Cards where @@ -28,7 +28,7 @@ type CardRegistrationID=Text  -- | perform the full registration of a card-fullRegistration :: (MonadBaseControl IO m, MonadResource m) => AnyUserID -> Currency -> CardInfo -> AccessToken -> MangoPayT m CardRegistration+fullRegistration :: (MPUsableMonad m) => AnyUserID -> Currency -> CardInfo -> AccessToken -> MangoPayT m CardRegistration fullRegistration uid currency cardInfo at=do   -- create registration   let cr1=mkCardRegistration uid currency@@ -40,7 +40,7 @@     -- | create or edit a card registration-storeCardRegistration ::  (MonadBaseControl IO m, MonadResource m) => CardRegistration -> AccessToken -> MangoPayT m CardRegistration+storeCardRegistration ::  (MPUsableMonad m) => CardRegistration -> AccessToken -> MangoPayT m CardRegistration storeCardRegistration cr at=          case crId cr of                 Nothing-> do@@ -59,7 +59,7 @@   } 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 :: (MPUsableMonad m) => CardInfo -> CardRegistration -> MangoPayT m CardRegistration registerCard ci cr |   Just url <- crCardRegistrationURL cr,   Just pre <- crPreregistrationData cr,@@ -136,14 +136,14 @@         parseJSON _=fail "CardRegistration"    -- | fetch a card from its ID-fetchCard :: (MonadBaseControl IO m, MonadResource m) => CardID -> AccessToken -> MangoPayT m Card+fetchCard :: (MPUsableMonad 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 :: (MPUsableMonad 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)
src/Web/MangoPay/Documents.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, OverloadedStrings, FlexibleContexts, FlexibleInstances #-}+{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, OverloadedStrings, FlexibleContexts, FlexibleInstances, ConstraintKinds #-} -- | handle documents and pages module Web.MangoPay.Documents where @@ -7,7 +7,6 @@ import Web.MangoPay.Types import Web.MangoPay.Users -import Data.Conduit import Data.Text import Data.Typeable (Typeable) import Data.Aeson@@ -21,7 +20,7 @@ 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 ::  (MPUsableMonad m) => AnyUserID -> Document -> AccessToken -> MangoPayT m Document storeDocument uid d at=          case dId d of                 Nothing-> do@@ -33,7 +32,7 @@                   -- | fetch a document from its ID-fetchDocument :: (MonadBaseControl IO m, MonadResource m) => AnyUserID -> DocumentID -> AccessToken -> MangoPayT m Document+fetchDocument :: (MPUsableMonad 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)@@ -42,7 +41,7 @@ -- | 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 :: (MPUsableMonad 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"]
src/Web/MangoPay/Events.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, OverloadedStrings, FlexibleContexts, FlexibleInstances #-}+{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, OverloadedStrings, FlexibleContexts, FlexibleInstances, ConstraintKinds #-} -- | handle events -- <http://docs.mangopay.com/api-references/events/> module Web.MangoPay.Events where@@ -6,7 +6,6 @@ import Web.MangoPay.Monad import Web.MangoPay.Types -import Data.Conduit import Data.Text hiding (filter) import Data.Typeable (Typeable) import Data.Aeson@@ -21,14 +20,14 @@ 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 ::  (MPUsableMonad 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 ::  (MPUsableMonad m) => Hook -> AccessToken -> MangoPayT m Hook storeHook h at=          case hId h of                 Nothing-> do@@ -40,14 +39,14 @@                         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 :: (MPUsableMonad 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 :: (MPUsableMonad m) =>  Maybe Pagination -> AccessToken -> MangoPayT m (PagedList Hook) listHooks mp at=do         url<-getClientURL "/hooks"         req<-getGetRequest url (Just at) (paginationAttributes mp)
src/Web/MangoPay/Monad.hs view
@@ -1,7 +1,7 @@-{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, ConstraintKinds #-} {-# LANGUAGE ScopedTypeVariables, GeneralizedNewtypeDeriving, FlexibleInstances,   MultiParamTypeClasses, UndecidableInstances, TypeFamilies,-  FlexibleContexts, RankNTypes,CPP #-}+  FlexibleContexts, RankNTypes,CPP,TemplateHaskell #-} -- | the utility monad and related functions, taking care of the HTTP, JSON, etc. module Web.MangoPay.Monad where @@ -31,18 +31,21 @@ 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) +import Control.Monad.Logger+ #if DEBUG import Data.Conduit.Binary (sinkHandle) import System.IO (stdout) import Data.Conduit.Util (zipSinks) #endif +-- | put our constraints in one synonym+type MPUsableMonad m=(MonadBaseControl IO m, C.MonadResource m, MonadLogger m)  -- | the mangopay monad transformer -- this encapsulates the data necessary to pass the app credentials, etc@@ -63,6 +66,9 @@     newtype StM (MangoPayT m) a = StMT {unStMT :: ComposeSt MangoPayT m a}     liftBaseWith = defaultLiftBaseWith StMT     restoreM = defaultRestoreM unStMT++instance (MonadLogger m) => MonadLogger (MangoPayT m) where+    monadLoggerLog loc src lvl msg=lift $ monadLoggerLog loc src lvl msg      -- | Run a computation in the 'MangoPayT' monad transformer with -- your credentials.@@ -166,7 +172,7 @@ -- 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) =>+                    (MPUsableMonad m,FromJSON b,FromJSON wrappedErr) =>                     H.Request                     -> (wrappedErr -> MpError) -- ^ extract the error from the JSON                     -> (HT.ResponseHeaders -> b -> c)@@ -181,7 +187,7 @@       cookies = H.responseCookieJar res       ok=isOkay status       err=H.StatusCodeException status headers cookies-  L.catch (do    +  mpres<-L.catch (do     #if DEBUG     (value,_)<-H.responseBody res C.$$+- zipSinks (sinkParser json) (sinkHandle stdout)     liftIO $ BSC.putStrLn ""@@ -193,19 +199,23 @@       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+            Success ot->return $ Right (value,addHeaders headers ot)+            Error jerr->return $ Left $ 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   +            Success ise-> return $ Left $ MpAppException $ extractError ise+            _ -> return $ Left $  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)->return $ Left $  MpHttpException err Nothing) -- the error body wasn't even json, throw the HTTP error inside our error type   +  let cr=CallRecord req' mpres+  -- log call+  $(logCall) cr+  return $ recordResult cr   -- | 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) =>+                                 (MPUsableMonad m,FromJSON v) =>                                  H.Request                                  -> MangoPayT                                       m v@@ -213,7 +223,7 @@  -- | get a PagedList from the JSON items getJSONList:: forall (m :: * -> *) v.-                                 (MonadBaseControl IO m, C.MonadResource m,FromJSON v) =>+                                 (MPUsableMonad m,FromJSON v) =>                                  H.Request                                  -> MangoPayT                                       m (PagedList v)@@ -230,7 +240,7 @@       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) => +getAll ::  (MPUsableMonad m,FromJSON v) =>    (Maybe Pagination -> AccessToken -> MangoPayT m (PagedList v)) -> AccessToken ->    MangoPayT m [v] getAll f at=readAll 1 []@@ -252,7 +262,7 @@  -- | send JSON via post, get JSON back                 postExchange :: forall (m :: * -> *) v p.-                 (MonadBaseControl IO m, C.MonadResource m,FromJSON v,ToJSON p) =>+                 (MPUsableMonad m,FromJSON v,ToJSON p) =>                  ByteString                  -> Maybe AccessToken                  -> p@@ -262,7 +272,7 @@  -- | send JSON via post, get JSON back                 putExchange :: forall (m :: * -> *) v p.-                 (MonadBaseControl IO m, C.MonadResource m,FromJSON v,ToJSON p) =>+                 (MPUsableMonad m,FromJSON v,ToJSON p) =>                  ByteString                  -> Maybe AccessToken                  -> p@@ -272,7 +282,7 @@     -- | send JSON, get JSON back                 jsonExchange :: forall (m :: * -> *) v p.-                 (MonadBaseControl IO m, C.MonadResource m,FromJSON v,ToJSON p) =>+                 (MPUsableMonad m,FromJSON v,ToJSON p) =>                  HT.Method                  -> ByteString                  -> Maybe AccessToken@@ -283,7 +293,7 @@    -- | get JSON request                 getJSONRequest :: forall (m :: * -> *) p.-                 (MonadBaseControl IO m, C.MonadResource m,ToJSON p) =>+                 (MPUsableMonad m,ToJSON p) =>                  HT.Method                  -> ByteString                  -> Maybe AccessToken@@ -307,7 +317,7 @@                           -- | post JSON content and ignore the reply                 postNoReply :: forall (m :: * -> *) p.-                 (MonadBaseControl IO m, C.MonadResource m,ToJSON p) =>+                 (MPUsableMonad m,ToJSON p) =>                   ByteString                  -> Maybe AccessToken                  -> p@@ -323,7 +333,7 @@ getManager = mpManager `liftM` Mp ask  -- | Run a 'ResourceT' inside a 'MangoPayT'.-runResourceInMp :: (C.MonadResource m, MonadBaseControl IO m) =>+runResourceInMp :: (MPUsableMonad m) =>                    MangoPayT (C.ResourceT m) a                 -> MangoPayT m a runResourceInMp (Mp inner) = Mp $ ask >>= lift . C.runResourceT . runReaderT inner
src/Web/MangoPay/Payins.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, OverloadedStrings, FlexibleContexts, FlexibleInstances #-}+{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, OverloadedStrings, FlexibleContexts, FlexibleInstances, ConstraintKinds #-} -- | handle payins module Web.MangoPay.Payins where @@ -8,7 +8,6 @@ import Web.MangoPay.Users import Web.MangoPay.Wallets -import Data.Conduit import Data.Text import Data.Typeable (Typeable) import Data.Aeson@@ -17,26 +16,26 @@ import qualified Network.HTTP.Types as HT  -- | create or edit a bankwire-storeBankWire ::  (MonadBaseControl IO m, MonadResource m) => BankWire -> AccessToken -> MangoPayT m BankWire+storeBankWire ::  (MPUsableMonad 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 :: (MPUsableMonad 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 ::  (MPUsableMonad 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 :: (MPUsableMonad m) => CardPayinID -> AccessToken -> MangoPayT m CardPayin fetchCardPayin cpid at=do         url<-getClientURLMultiple ["/payins/",cpid]         req<-getGetRequest url (Just at) ([]::HT.Query)
src/Web/MangoPay/Payouts.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, OverloadedStrings, FlexibleContexts, FlexibleInstances #-}+{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, OverloadedStrings, FlexibleContexts, FlexibleInstances, ConstraintKinds #-} -- | handle payouts module Web.MangoPay.Payouts where @@ -8,7 +8,6 @@ import Web.MangoPay.Users import Web.MangoPay.Wallets -import Data.Conduit import Data.Text import Data.Typeable (Typeable) import Data.Aeson@@ -17,13 +16,13 @@ import qualified Network.HTTP.Types as HT  -- | create a payout-storePayout ::  (MonadBaseControl IO m, MonadResource m) => Payout -> AccessToken -> MangoPayT m Payout+storePayout ::  (MPUsableMonad 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 :: (MPUsableMonad m) => PayoutID -> AccessToken -> MangoPayT m Payout fetchPayout ptid at=do         url<-getClientURLMultiple ["/payouts/",ptid]         req<-getGetRequest url (Just at) ([]::HT.Query)
src/Web/MangoPay/Refunds.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, FlexibleContexts #-}+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, FlexibleContexts, ConstraintKinds #-} -- | refunds on payins and transfers module Web.MangoPay.Refunds where @@ -8,7 +8,6 @@ import Web.MangoPay.Users import Web.MangoPay.Wallets -import Data.Conduit import Data.Text import Data.Typeable (Typeable) import Data.Aeson@@ -17,19 +16,19 @@ import qualified Network.HTTP.Types as HT  -- | refund a transfer-refundTransfer ::  (MonadBaseControl IO m, MonadResource m) => TransferID -> AnyUserID -> AccessToken -> MangoPayT m Refund+refundTransfer ::  (MPUsableMonad 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 ::  (MPUsableMonad 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 :: (MPUsableMonad m) => RefundID -> AccessToken -> MangoPayT m Refund fetchRefund rid at=do         url<-getClientURLMultiple ["/refunds/",rid]         req<-getGetRequest url (Just at) ([]::HT.Query)
src/Web/MangoPay/Types.hs view
@@ -1,13 +1,13 @@-{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, ScopedTypeVariables, TypeSynonymInstances, FlexibleInstances #-}+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, ScopedTypeVariables, TypeSynonymInstances, FlexibleInstances, TemplateHaskell #-} -- | 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 Control.Exception.Base (Exception,throw)+import Data.Text as T hiding (singleton) import Data.Typeable (Typeable)-import Data.ByteString (ByteString)+import Data.ByteString  as BS (ByteString,null) import Data.Time.Clock.POSIX (POSIXTime) import Data.Aeson import Data.Default@@ -15,7 +15,17 @@ import qualified Data.Text.Encoding as TE import qualified Data.ByteString.UTF8 as UTF8 import Data.Maybe (listToMaybe)-import Network.HTTP.Conduit (HttpException)+import qualified Network.HTTP.Conduit as H+import qualified Network.HTTP.Types as HT+import Control.Monad.Logger+import Data.Aeson.Encode (encodeToTextBuilder)+import Data.Text.Lazy.Builder (fromText, toLazyText, singleton)+import Data.Monoid ((<>))+import Data.Text.Lazy (toStrict)+import Data.String (fromString)+import qualified Data.Vector as V (length)+import Language.Haskell.TH+import Language.Haskell.TH.Syntax (qLocation)  -- | the MangoPay access point data AccessPoint = Sandbox | Production | Custom ByteString@@ -86,7 +96,7 @@ -- | 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+  | MpHttpException H.HttpException (Maybe Value) -- ^ HTTP level exception, maybe with some JSON payload   deriving (Show,Typeable)  -- | make our exception type a normal exception  @@ -150,7 +160,50 @@ -- | alias for Currency type Currency=Text --- | simple class used to hide the serialization of parameters ansd simplify the calling code  +-- | a structure holding the information of an API call+data CallRecord a = CallRecord {+    crReq :: H.Request -- ^ the request to MangoPay+    ,crResult :: Either MpException (Value,a) -- ^ the error or the JSON value and parsed result+  }++-- | which level should we log the call+recordLogLevel :: CallRecord a-> LogLevel+recordLogLevel cr+  | HT.methodGet == H.method (crReq cr)=LevelDebug+  | otherwise = LevelInfo++-- | the log message from a call+recordLogMessage :: CallRecord a-> Text+recordLogMessage (CallRecord req res)=let+  -- we log the method+  methB=fromString $ show $ H.method req+  -- we log the uri path+  pathB=fromText $ TE.decodeUtf8 $ H.path req+  -- log the query string if any+  qsB=fromText $ TE.decodeUtf8 $ H.queryString req+  resB=case res of+    -- log error+    Left e->fromString $ show e+    Right (v,_)->case v of+      -- we have a list, just log the number of results to avoid polluting the log with too much info+      Array arr->fromString (show $ V.length arr) <> " values"+      -- we have a simple value we can log it+      _->encodeToTextBuilder v+  in toStrict . toLazyText $ methB <> singleton ' ' <> pathB <> qsB <> ": " <> resB++-- | the result+-- if we have a proper result we return it+-- if we have an error we throw it+recordResult :: CallRecord a-> a+recordResult (CallRecord _ (Left err))=throw err+recordResult (CallRecord _ (Right (_,a)))=a++-- | log a CallRecord  +-- MonadLogger doesn't expose a function with a dynamic log level...+logCall :: Q Exp+logCall = [|\a -> monadLoggerLog $(qLocation >>= liftLoc) "mangopay" (recordLogLevel a) (recordLogMessage a)|]++-- | simple class used to hide the serialization of parameters and simplify the calling code   class ToHtQuery a where   (?+) :: ByteString -> a -> (ByteString,Maybe ByteString)
src/Web/MangoPay/Users.hs view
@@ -1,11 +1,10 @@-{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, OverloadedStrings, FlexibleContexts, FlexibleInstances #-}+{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, OverloadedStrings, FlexibleContexts, FlexibleInstances, ConstraintKinds #-} -- | 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@@ -14,7 +13,7 @@ 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 ::  (MPUsableMonad m) => NaturalUser -> AccessToken -> MangoPayT m NaturalUser storeNaturalUser u at=          case uId u of                 Nothing-> do@@ -26,14 +25,14 @@                   -- | fetch a natural user from her ID-fetchNaturalUser :: (MonadBaseControl IO m, MonadResource m) => NaturalUserID -> AccessToken -> MangoPayT m NaturalUser+fetchNaturalUser :: (MPUsableMonad 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 ::  (MPUsableMonad m) => LegalUser -> AccessToken -> MangoPayT m LegalUser storeLegalUser u at=          case lId u of                 Nothing-> do@@ -45,21 +44,21 @@                   -- | fetch a natural user from her ID-fetchLegalUser :: (MonadBaseControl IO m, MonadResource m) => LegalUserID -> AccessToken -> MangoPayT m LegalUser+fetchLegalUser :: (MPUsableMonad 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 :: (MPUsableMonad 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 :: (MPUsableMonad m) => Maybe Pagination -> AccessToken -> MangoPayT m (PagedList UserRef) listUsers mp at=do         url<-getClientURL "/users/"         req<-getGetRequest url (Just at) (paginationAttributes mp)
src/Web/MangoPay/Wallets.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, OverloadedStrings, FlexibleContexts, FlexibleInstances, PatternGuards #-}+{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, OverloadedStrings, FlexibleContexts, FlexibleInstances, PatternGuards, ConstraintKinds #-} -- | handle wallets module Web.MangoPay.Wallets where @@ -7,7 +7,6 @@ import Web.MangoPay.Types import Web.MangoPay.Users -import Data.Conduit import Data.Text import Data.Typeable (Typeable) import Data.Aeson@@ -17,7 +16,7 @@ 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 ::  (MPUsableMonad m) => Wallet -> AccessToken -> MangoPayT m Wallet storeWallet w at=          case wId w of                 Nothing-> do@@ -30,41 +29,41 @@                   -- | fetch a wallet from its ID-fetchWallet :: (MonadBaseControl IO m, MonadResource m) => WalletID -> AccessToken -> MangoPayT m Wallet+fetchWallet :: (MPUsableMonad 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 :: (MPUsableMonad 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 :: (MPUsableMonad 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 :: (MPUsableMonad 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 ::  (MPUsableMonad 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 ::  (MPUsableMonad 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)
test/Web/MangoPay/AccessTest.hs view
@@ -17,6 +17,7 @@ import Data.IORef (modifyIORef,readIORef) import Control.Monad (liftM) import Data.Conduit (runResourceT)+import Control.Monad.Logger  -- | Take the name/email from client.conf in the current directory -- (this file can be generated by mangopay-passphrase)@@ -35,11 +36,11 @@                 cClientID=T.append (cClientID creds) suff,                 cName=T.append (cName creds) suff}        mgr<-liftM tsManager $ readIORef testState         -       creds2<-runResourceT $ runMangoPayT newCreds mgr Sandbox createCredentialsSecret+       creds2<-runResourceT $ runStdoutLoggingT $ 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 $+       oat<-runResourceT $ runStdoutLoggingT $ runMangoPayT creds2 mgr Sandbox $                 oauthLogin (cClientID creds2) s            -- store access token and credentials                 modifyIORef testState (\ts->ts{tsAccessToken=toAccessToken oat,tsCredentials=creds2})
test/Web/MangoPay/TestUtils.hs view
@@ -28,6 +28,7 @@ import Data.Default (def) import Data.IORef  import System.IO.Unsafe (unsafePerformIO)+import Control.Monad.Logger  -- | a test card testCardInfo1 :: CardInfo@@ -37,14 +38,14 @@ -- 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)+            (AccessToken -> MangoPayT (LoggingT (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+        runResourceT $ runStdoutLoggingT $ runMangoPayT cred mgr Sandbox $ f at  -- | the test state as a top level global variable -- <http://www.haskell.org/haskellwiki/Top_level_mutable_state>
test/Web/MangoPay/UsersTest.hs view
@@ -55,7 +55,7 @@ test_PaginationUsers :: Assertion test_PaginationUsers = do   usL<-testMP $ listUsers (Just $ Pagination 1 1)-  print usL+  --print usL   assertEqual 1 (length $ plData usL)   assertEqual 2 (plItemCount usL)   assertEqual 2 (plPageCount usL)