mangopay 1.8.0 → 1.8.1
raw patch · 3 files changed
+104/−88 lines, 3 files
Files
- mangopay.cabal +1/−1
- src/Web/MangoPay/Access.hs +25/−24
- src/Web/MangoPay/Monad.hs +78/−63
mangopay.cabal view
@@ -1,5 +1,5 @@ name: mangopay-version: 1.8.0+version: 1.8.1 cabal-version: >= 1.8 build-type: Simple author: JP Moresmau <jpmoresmau@gmail.com>
src/Web/MangoPay/Access.hs view
@@ -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
src/Web/MangoPay/Monad.hs view
@@ -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 ++ " <Builder>"+ H.RequestBodyStream s _ -> "RequestBodyStream " ++ show s ++ " <GivesPopper ()>"+ H.RequestBodyStreamChunked _ -> "RequestBodyStreamChunked <GivesPopper ()>" #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.