diff --git a/exe/Main.hs b/exe/Main.hs --- a/exe/Main.hs +++ b/exe/Main.hs @@ -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 () diff --git a/mangopay.cabal b/mangopay.cabal --- a/mangopay.cabal +++ b/mangopay.cabal @@ -1,5 +1,5 @@ name: mangopay -version: 1.0 +version: 1.1 cabal-version: >= 1.8 build-type: Simple author: JP Moresmau @@ -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, diff --git a/src/Web/MangoPay.hs b/src/Web/MangoPay.hs --- a/src/Web/MangoPay.hs +++ b/src/Web/MangoPay.hs @@ -14,6 +14,7 @@ ,OAuthToken(..) ,Pagination(..) ,PagedList(..) + ,MPUsableMonad -- access ,createCredentialsSecret diff --git a/src/Web/MangoPay/Access.hs b/src/Web/MangoPay/Access.hs --- a/src/Web/MangoPay/Access.hs +++ b/src/Web/MangoPay/Access.hs @@ -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 diff --git a/src/Web/MangoPay/Accounts.hs b/src/Web/MangoPay/Accounts.hs --- a/src/Web/MangoPay/Accounts.hs +++ b/src/Web/MangoPay/Accounts.hs @@ -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) diff --git a/src/Web/MangoPay/Cards.hs b/src/Web/MangoPay/Cards.hs --- a/src/Web/MangoPay/Cards.hs +++ b/src/Web/MangoPay/Cards.hs @@ -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) diff --git a/src/Web/MangoPay/Documents.hs b/src/Web/MangoPay/Documents.hs --- a/src/Web/MangoPay/Documents.hs +++ b/src/Web/MangoPay/Documents.hs @@ -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"] diff --git a/src/Web/MangoPay/Events.hs b/src/Web/MangoPay/Events.hs --- a/src/Web/MangoPay/Events.hs +++ b/src/Web/MangoPay/Events.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, OverloadedStrings, FlexibleContexts, FlexibleInstances #-} +{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, OverloadedStrings, FlexibleContexts, FlexibleInstances, ConstraintKinds #-} -- | handle 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) diff --git a/src/Web/MangoPay/Monad.hs b/src/Web/MangoPay/Monad.hs --- a/src/Web/MangoPay/Monad.hs +++ b/src/Web/MangoPay/Monad.hs @@ -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 diff --git a/src/Web/MangoPay/Payins.hs b/src/Web/MangoPay/Payins.hs --- a/src/Web/MangoPay/Payins.hs +++ b/src/Web/MangoPay/Payins.hs @@ -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) diff --git a/src/Web/MangoPay/Payouts.hs b/src/Web/MangoPay/Payouts.hs --- a/src/Web/MangoPay/Payouts.hs +++ b/src/Web/MangoPay/Payouts.hs @@ -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) diff --git a/src/Web/MangoPay/Refunds.hs b/src/Web/MangoPay/Refunds.hs --- a/src/Web/MangoPay/Refunds.hs +++ b/src/Web/MangoPay/Refunds.hs @@ -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) diff --git a/src/Web/MangoPay/Types.hs b/src/Web/MangoPay/Types.hs --- a/src/Web/MangoPay/Types.hs +++ b/src/Web/MangoPay/Types.hs @@ -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) diff --git a/src/Web/MangoPay/Users.hs b/src/Web/MangoPay/Users.hs --- a/src/Web/MangoPay/Users.hs +++ b/src/Web/MangoPay/Users.hs @@ -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) diff --git a/src/Web/MangoPay/Wallets.hs b/src/Web/MangoPay/Wallets.hs --- a/src/Web/MangoPay/Wallets.hs +++ b/src/Web/MangoPay/Wallets.hs @@ -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) diff --git a/test/Web/MangoPay/AccessTest.hs b/test/Web/MangoPay/AccessTest.hs --- a/test/Web/MangoPay/AccessTest.hs +++ b/test/Web/MangoPay/AccessTest.hs @@ -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}) diff --git a/test/Web/MangoPay/TestUtils.hs b/test/Web/MangoPay/TestUtils.hs --- a/test/Web/MangoPay/TestUtils.hs +++ b/test/Web/MangoPay/TestUtils.hs @@ -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 -- diff --git a/test/Web/MangoPay/UsersTest.hs b/test/Web/MangoPay/UsersTest.hs --- a/test/Web/MangoPay/UsersTest.hs +++ b/test/Web/MangoPay/UsersTest.hs @@ -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)