module Yesod.MangoPay where
import Web.MangoPay
import qualified Yesod.Core as Y
import qualified Network.HTTP.Conduit as HTTP
import Data.Time.Clock (UTCTime, getCurrentTime, diffUTCTime, addUTCTime)
import Data.Text (Text)
import Data.IORef (IORef, readIORef, writeIORef)
import qualified Data.Map as M
import Control.Monad (void)
import qualified Control.Exception.Lifted as L
class Y.Yesod site => YesodMangoPay site where
mpCredentials :: site -> Credentials
mpHttpManager :: site -> HTTP.Manager
mpUseSandbox :: site -> Bool
mpUseSandbox _ = True
mpToken :: site -> IORef (Maybe MangoPayToken)
runYesodMPT ::
(Y.MonadHandler m,MPUsableMonad m, Y.HandlerSite m ~ site, YesodMangoPay site) =>
MangoPayT m a -> m a
runYesodMPT act = do
site <- Y.getYesod
let creds = mpCredentials site
manager = mpHttpManager site
apoint = if mpUseSandbox site then Sandbox else Production
runMangoPayT creds manager apoint act
data MangoPayToken=MangoPayToken {
mptToken :: AccessToken
,mptExpires :: UTCTime
}
isTokenValid :: (Y.MonadResource m) => MangoPayToken -> m Bool
isTokenValid mpt=do
ct<-Y.liftIO getCurrentTime
return $ diffUTCTime (mptExpires mpt) ct > 0
getTokenIfValid :: (YesodMangoPay site,Y.MonadResource m) => site -> m (Maybe MangoPayToken)
getTokenIfValid site=do
mt<-Y.liftIO $ readIORef $ mpToken site
case mt of
Nothing-> return Nothing
Just t->do
v<-isTokenValid t
return $ if v then Just t else Nothing
getValidToken :: (YesodMangoPay site,MPUsableMonad m) => site -> m (Maybe AccessToken)
getValidToken site=do
mt<-getTokenIfValid site
case mt of
Just t-> return $ Just $ mptToken t
Nothing->do
let creds = mpCredentials site
msecret = cClientSecret creds
manager = mpHttpManager site
apoint = if mpUseSandbox site then Sandbox else Production
case msecret of
Nothing -> fail "getValidToken: You need to provide the cClientSecret on the mpCredentials."
Just secret-> do
oat<-runMangoPayT creds manager apoint $
oauthLogin (cClientID creds) secret
ct<-Y.liftIO getCurrentTime
let expires=addUTCTime (fromIntegral (oaExpires oat 60)) ct
let at=toAccessToken oat
Y.liftIO $ writeIORef (mpToken site) (Just $ MangoPayToken at expires)
return $ Just at
runYesodMPTToken ::
(Y.MonadHandler m,MPUsableMonad m, Y.HandlerSite m ~ site, YesodMangoPay site) =>
(AccessToken -> MangoPayT m a) -> m a
runYesodMPTToken act = do
site <- Y.getYesod
vt<-getValidToken site
case vt of
Nothing -> fail "runYesodMPTToken: Could not obtain access token."
Just ac-> runYesodMPT $ act ac
registerAllMPCallbacks :: (Y.MonadHandler m,MPUsableMonad m, Y.HandlerSite m ~ site, YesodMangoPay site) =>
Y.Route (Y.HandlerSite m)-> m ()
registerAllMPCallbacks rt=do
render<-Y.getUrlRender
let url=render rt
$(Y.logInfo) url
runYesodMPTToken $ \at-> do
hooks<-getAll listHooks at
let existing=foldr (\h s->M.insert (hEventType h) h s) M.empty hooks
mapM_ (registerIfAbsent url at existing) [minBound..maxBound]
where
registerIfAbsent url at existing evt=do
let mh=case M.lookup evt existing of
Nothing->Just $ Hook Nothing Nothing Nothing url Enabled Nothing evt
Just h2->if hUrl h2 /= url then Just h2{hUrl = url} else Nothing
case mh of
Just h->do
Y.liftIO $ print h
void $ storeHook h at
_-> return ()
registerMPCallback :: (Y.MonadHandler m,MPUsableMonad m, Y.HandlerSite m ~ site, YesodMangoPay site) =>
Y.Route (Y.HandlerSite m)-> EventType -> Maybe Text -> m (AccessToken -> MangoPayT m Hook)
registerMPCallback rt et mtag=do
render<-Y.getUrlRender
let h=Hook Nothing Nothing mtag (render rt) Enabled Nothing et
return $ storeHook h
parseMPNotification :: (Y.MonadHandler m, Y.HandlerSite m ~ site, YesodMangoPay site) => m Event
parseMPNotification = do
req<-Y.getRequest
let mevt=eventFromQueryStringT $ Y.reqGetParams req
case mevt of
Just evt->return evt
Nothing->fail "parseMPNotification: could not parse Event"
catchMP :: forall (m :: * -> *) a.
Y.MonadBaseControl IO m =>
m a -> (MpException -> m a) -> m a
catchMP func =L.catch func