{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, ConstraintKinds #-} {-# LANGUAGE ScopedTypeVariables, GeneralizedNewtypeDeriving, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, TypeFamilies, FlexibleContexts, RankNTypes,CPP,TemplateHaskell, StandaloneDeriving #-} -- | 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) 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 Data.Aeson (json,fromJSON,Result(..),FromJSON, ToJSON,encode) import Data.Conduit.Attoparsec (sinkParser, ParseError) 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, R.MonadResource m, MonadLogger m) -- | 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 ) deriving instance R.MonadResource m => R.MonadResource (MangoPayT m) 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 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. 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 . (MPUsableMonad 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 mpres<-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 $ 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-> 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. (MPUsableMonad 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. (MPUsableMonad 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 :: (MPUsableMonad 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. (MPUsableMonad 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. (MPUsableMonad 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. (MPUsableMonad 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. (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 } -- | post JSON content and ignore the reply postNoReply :: forall (m :: * -> *) p. (MPUsableMonad 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 :: (MPUsableMonad m) => MangoPayT (R.ResourceT m) a -> MangoPayT m a runResourceInMp (Mp inner) = Mp $ ask >>= lift . R.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