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.Monoid ((<>))
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, toJSON, Result(..)
,FromJSON, ToJSON,encode, Object, Value(..))
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.Internal (zipSinks)
import Control.Monad.IO.Class (liftIO)
#endif
type MPUsableMonad m=(MonadBaseControl IO m, R.MonadResource m, MonadLogger m)
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
runMangoPayT :: Credentials
-> H.Manager
-> AccessPoint
-> MangoPayT m a
-> m a
runMangoPayT creds manager ap (Mp act) =
runReaderT act (MpData creds manager ap)
getCreds :: Monad m => MangoPayT m Credentials
getCreds = mpCreds `liftM` Mp ask
getHost :: Monad m => MangoPayT m ByteString
getHost = (getAccessPointURL . mpAccessPoint) `liftM` Mp ask
getPostRequest
:: (Monad m, MonadIO m, HT.QueryLike q)
=> ByteString
-> Maybe AccessToken
-> q
-> MangoPayT m H.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 }
getGetRequest
:: (Monad m, MonadIO m, HT.QueryLike q)
=> ByteString
-> Maybe AccessToken
-> q
-> MangoPayT m H.Request
getGetRequest path mat query=do
let qs = HT.renderQuery True $ HT.toQuery query
getBasicRequest HT.methodGet path $ \r ->
r { H.queryString = qs
, H.requestHeaders = getJSONHeaders mat
}
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 $ 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 req2
getDeleteRequest :: (Monad m,MonadIO m,HT.QueryLike q) => ByteString
-> Maybe AccessToken
-> q
-> MangoPayT m H.Request
getDeleteRequest path mat query=do
get<-getGetRequest path mat query
return $ get {H.method=HT.methodDelete}
getClientURL :: (Monad m)=> ByteString
-> MangoPayT m ByteString
getClientURL path=do
cid<- liftM clientIdBS getCreds
return $ BS.concat ["/v2/",cid,path]
getClientURLMultiple :: (Monad m)=> [T.Text]
-> MangoPayT m ByteString
getClientURLMultiple path=do
cid<- liftM clientIdBS getCreds
return $ BS.concat $ ["/v2/",cid] ++ map TE.encodeUtf8 path
getQueryURL :: (Monad m,HT.QueryLike q) => ByteString
-> q
-> MangoPayT m ByteString
getQueryURL path query=do
host<-getHost
return $ BS.concat ["https://",host,path,HT.renderQuery True $ HT.toQuery query]
mpReq :: forall b (m :: * -> *) wrappedErr c .
(MPUsableMonad m,FromJSON b,FromJSON wrappedErr) =>
H.Request
-> (wrappedErr -> MpError)
-> (HT.ResponseHeaders -> b -> c)
-> MangoPayT m c
mpReq req extractError addHeaders=do
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
liftIO $ BSC.putStrLn ""
liftIO $ print $ show req'
(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
case fromJSON value of
Success ot->return $ Right (value,addHeaders headers ot)
Error jerr->return $ Left $ MpJSONException jerr
else
case fromJSON value of
Success ise-> return $ Left $ MpAppException $ extractError ise
_ -> return $ Left $ MpHttpException err $ Just value
) (\(_::ParseError)->return $ Left $ MpHttpException err Nothing)
let cr=CallRecord req' mpres
$(logCall) cr
recordResult cr
getJSONResponse :: forall (m :: * -> *) v.
(MPUsableMonad m,FromJSON v) =>
H.Request
-> MangoPayT
m v
getJSONResponse req=mpReq req id (const id)
getJSONList:: forall (m :: * -> *) v.
(MPUsableMonad m,FromJSON v) =>
H.Request
-> MangoPayT
m (PagedList v)
getJSONList req=mpReq req id buildList
buildList :: HT.ResponseHeaders -> [b] -> PagedList b
buildList headers items=let
cnt=fromMaybe (fromIntegral $ length items) $ getI "X-Number-Of-Items"
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
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
getJSONHeaders :: Maybe AccessToken -> HT.RequestHeaders
getJSONHeaders mat= ("content-type", "application/json") :
case mat of
Just (AccessToken at) -> [("Authorization", at)]
_ -> []
postExchange :: forall (m :: * -> *) v p.
(MPUsableMonad m,FromJSON v,ToJSON p) =>
ByteString
-> Maybe AccessToken
-> p
-> MangoPayT
m v
postExchange=jsonExchange HT.methodPost
putExchange :: forall (m :: * -> *) v p.
(MPUsableMonad m,FromJSON v,ToJSON p) =>
ByteString
-> Maybe AccessToken
-> p
-> MangoPayT
m v
putExchange=jsonExchange HT.methodPut
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
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
}
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
getManager :: Monad m => MangoPayT m H.Manager
getManager = mpManager `liftM` Mp ask
runResourceInMp :: (MPUsableMonad m) =>
MangoPayT (R.ResourceT m) a
-> MangoPayT m a
runResourceInMp (Mp inner) = Mp $ ask >>= lift . R.runResourceT . runReaderT inner
mapMangoPayT :: (m a -> n b) -> MangoPayT m a -> MangoPayT n b
mapMangoPayT f = Mp . mapReaderT f . unIs
data MpData = MpData {
mpCreds::Credentials
,mpManager::H.Manager
,mpAccessPoint:: AccessPoint
}
deriving (Typeable)
isOkay :: HT.Status -> Bool
isOkay status =
let sc = HT.statusCode status
in 200 <= sc && sc < 300
createGeneric :: (MPUsableMonad m, FromJSON a, ToJSON a) =>
ByteString -> a -> AccessToken -> MangoPayT m a
createGeneric path x at = do
url<-getClientURL path
postExchange url (Just at) x
modifyGeneric :: (MPUsableMonad m, FromJSON a, ToJSON a) =>
T.Text -> a -> (a -> Maybe T.Text) -> AccessToken -> MangoPayT m a
modifyGeneric = modifyGGeneric Nothing
modifyGGeneric :: (MPUsableMonad m, FromJSON a, ToJSON a) =>
Maybe (Object -> Object) -> T.Text -> a -> (a -> Maybe T.Text) ->
AccessToken -> MangoPayT m a
modifyGGeneric mf path x fid at =
case fid x of
Nothing -> error $ show $
"Web.MangoPay.Users.modifyGGeneric : Nothing (" <> path <> ")"
Just i -> do
url<-getClientURLMultiple [path ,i]
case mf of
Nothing -> putExchange url (Just at) x
Just f -> do
let Object o = toJSON x
putExchange url (Just at) $ f o
fetchGeneric :: (MPUsableMonad m, FromJSON a) =>
T.Text -> T.Text -> AccessToken -> MangoPayT m a
fetchGeneric path xid at = do
url<-getClientURLMultiple [path ,xid]
req<-getGetRequest url (Just at) ([]::HT.Query)
getJSONResponse req
genericList :: (MPUsableMonad m, FromJSON a) =>
[T.Text] -> Maybe Pagination -> AccessToken -> MangoPayT m (PagedList a)
genericList path mp at = do
url <- getClientURLMultiple path
req <- getGetRequest url (Just at) (paginationAttributes mp)
getJSONList req