diff --git a/mangopay.cabal b/mangopay.cabal --- a/mangopay.cabal +++ b/mangopay.cabal @@ -1,5 +1,5 @@ name: mangopay -version: 1.8.0 +version: 1.8.1 cabal-version: >= 1.8 build-type: Simple author: JP Moresmau 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,34 +1,35 @@ {-# LANGUAGE FlexibleContexts, OverloadedStrings, ConstraintKinds #-} --- | access methods for login, creating clients... +-- | Obtaining credentials and access tokens. module Web.MangoPay.Access -( -createCredentialsSecret -,oauthLogin -) -where + ( createCredentialsSecret + , oauthLogin + ) where +import Control.Applicative ((<$>)) +import Data.Maybe (isNothing) +import Data.Text +import Network.HTTP.Conduit (applyBasicAuth) import Web.MangoPay.Monad import Web.MangoPay.Types -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) +import qualified Network.HTTP.Types as HT --- | populate the passphrase for our clientId IFF we don't have one -createCredentialsSecret :: (MPUsableMonad 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 :: (MPUsableMonad m) => Text -> Text -> MangoPayT m OAuthToken +-- | Populate the passphrase for our clientId IFF we don't have one. +createCredentialsSecret :: MPUsableMonad 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 :: 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 + let query = [("grant_type", Just "client_credentials")] :: HT.Query + req <- applyBasicAuth (TE.encodeUtf8 user) (TE.encodeUtf8 pass) <$> + getPostRequest "/v2/oauth/token" Nothing query + getJSONResponse req 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 @@ -43,7 +43,6 @@ import Data.Conduit.Binary (sinkHandle) import System.IO (stdout) import Data.Conduit.Internal (zipSinks) -import qualified Data.ByteString.Lazy.Char8 as BSLC import Control.Monad.IO.Class (liftIO) #endif @@ -93,52 +92,76 @@ 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 + +-- | 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 - } + -> q + -- ^ The query parameters. + -> MangoPayT m H.Request + -- ^ The properly configured request. +getPostRequest path mat query = do + let b = HT.renderQuery False $ HT.toQuery query + getBasicRequest HT.methodPost path $ \r -> + r { H.requestHeaders = + ("Content-Type", "application/x-www-form-urlencoded") : + [("Authorization", at) | Just (AccessToken at) <- [mat]] + , H.requestBody = H.RequestBodyBS b } --- | build a get request to MangoPay -getGetRequest :: (Monad m,MonadIO m,HT.QueryLike q) => ByteString -- ^ the url path + +-- | 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 + -> 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 + let qs = HT.renderQuery True $ HT.toQuery query + getBasicRequest HT.methodGet path $ \r -> + r { H.queryString = qs + , H.requestHeaders = getJSONHeaders mat + } + + +-- | (Internal) Build a basic request. +getBasicRequest + :: MonadIO m + => HT.Method + -> ByteString + -> (H.Request -> H.Request) + -> MangoPayT m H.Request +getBasicRequest method path addRest = do + host <- getHost + let req1 = + def + { H.secure = True + , H.host = host + , H.port = 443 + , H.path = path + , H.method = method + } + req2 = addRest req1 #if DEBUG - liftIO $ BSC.putStrLn $ BS.append path qs + liftIO $ do + print req2 + putStrLn $ "^--> " ++ + case H.requestBody req2 of + H.RequestBodyLBS lbs -> "RequestBodyLBS " ++ show lbs + H.RequestBodyBS bs -> "RequestBodyBS " ++ show bs + H.RequestBodyBuilder s _ -> "RequestBodyBuilder " ++ show s ++ " " + H.RequestBodyStream s _ -> "RequestBodyStream " ++ show s ++ " " + H.RequestBodyStreamChunked _ -> "RequestBodyStreamChunked " #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 - } + return req2 + -- | build a delete request to MangoPay getDeleteRequest :: (Monad m,MonadIO m,HT.QueryLike q) => ByteString -- ^ the url path -> Maybe AccessToken @@ -298,29 +321,21 @@ m v jsonExchange meth path mat p= getJSONRequest meth path mat p >>= getJSONResponse --- | get JSON request -getJSONRequest :: forall (m :: * -> *) p. - (MPUsableMonad 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 - } + +-- | Get JSON request. +getJSONRequest + :: (MPUsableMonad m, ToJSON p) + => HT.Method + -> ByteString + -> Maybe AccessToken + -> p + -> MangoPayT m H.Request +getJSONRequest method path mat p = do + getBasicRequest method path $ \r -> + r { H.requestHeaders = getJSONHeaders mat + , H.requestBody = H.RequestBodyLBS $ encode p + } + -- | post JSON content and ignore the reply postNoReply :: forall (m :: * -> *) p.