{-# LANGUAGE OverloadedStrings, TypeFamilies, FlexibleContexts,TemplateHaskell, RankNTypes, ConstraintKinds, ScopedTypeVariables #-}
-- | typeclasses and helpers to access MangoPay from Yesod
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, pack)
import Data.IORef (IORef, readIORef, writeIORef)
import qualified Data.Map as M
import Control.Monad (void, forM, liftM)
import qualified Control.Exception.Lifted as L
import Database.Persist.TH (derivePersistField)
import Data.Monoid ((<>))
import Data.Maybe (catMaybes)
-- | The 'YesodMangoPay' class for foundation datatypes that
-- support running 'MangoPayT' actions.
class YesodMangoPay site where
-- | The credentials of your app.
mpCredentials :: site -> Credentials
-- | HTTP manager used for contacting MangoPay (may be the same
-- as the one used for @yesod-auth@).
mpHttpManager :: site -> HTTP.Manager
-- | Use MangoPay's sandbox if @True@. The default is @True@ for safety.
mpUseSandbox :: site -> Bool
mpUseSandbox _ = True
-- | store the saved access token if we have one
mpToken :: site -> IORef (Maybe MangoPayToken)
-- | Run a 'MangoPayT' action inside a 'Y.GHandler' using your credentials.
runYesodMPT ::
(Y.MonadHandler m,MPUsableMonad m, Y.HandlerSite m ~ site, YesodMangoPay site) =>
MangoPayT m a -> m a
runYesodMPT act = Y.getYesod >>= (`runMPT` act)
-- | Run a 'MangoPayT', given any instance of YesodMangoPay.
runMPT :: (MPUsableMonad m, YesodMangoPay site) => site ->
MangoPayT m a -> m a
runMPT site act = do
let creds = mpCredentials site
manager = mpHttpManager site
apoint = if mpUseSandbox site then Sandbox else Production
runMangoPayT creds manager apoint act
-- | the MangoPay access token, valid for a certain time only
data MangoPayToken=MangoPayToken {
mptToken :: AccessToken -- ^ opaque token
,mptExpires :: UTCTime -- ^ expiration date
}
-- | is the given token still valid (True) or has it expired (False)?
isTokenValid :: (Y.MonadResource m) => MangoPayToken -> m Bool
isTokenValid mpt=do
ct<-Y.liftIO getCurrentTime
return $ diffUTCTime (mptExpires mpt) ct > 0
-- | get the currently stored token if we have one and it's valid, or Nothing otherwise
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
-- | get a valid token, which could be one we had from before, or a new one
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
-- oaExpires is in second, remove one minute for safety
let expires=addUTCTime (fromIntegral (oaExpires oat - 60)) ct
let at=toAccessToken oat
Y.liftIO $ writeIORef (mpToken site) (Just $ MangoPayToken at expires)
return $ Just at
-- | Same as 'runYesodMPT': runs a MangoPayT computation, but tries to reuse the current token if valid.
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-> runMPT site $ act ac
-- | Same as 'runMPT': runs a MangoPayT computation, but tries to reuse the current token if valid.
runMPTToken ::
(MPUsableMonad m, YesodMangoPay site) => site ->
(AccessToken -> MangoPayT m a) -> m a
runMPTToken site act = do
vt<-getValidToken site
case vt of
Nothing -> fail "runYesodMPTToken: Could not obtain access token."
Just ac-> runMPT site $ act ac
-- | register callbacks for each event type on the same url
-- mango pay does not let register two hooks for the same event, so we replace existing ones
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) $ "Hooks to url:" <> url
site <- Y.getYesod
hs <- registerAllMPCallbacksToURL site url
void $ forM hs ($(Y.logInfo) . ("Hook: " <>) . pack . show)
-- | register callbacks for each event type on the same url
-- mango pay does not let register two hooks for the same event, so we replace existing ones
registerAllMPCallbacksToURL :: (MPUsableMonad m, YesodMangoPay site) =>
site -> Text -> m [Hook]
registerAllMPCallbacksToURL site url =
runMPTToken site $ \at-> do
-- get all hooks at once
hooks<-getAll listHooks at
let existing=foldr (\h s->M.insert (hEventType h) h s) M.empty hooks
liftM catMaybes $ mapM (registerIfAbsent at existing) [minBound..maxBound]
where
registerIfAbsent at existing evt =
case M.lookup evt existing of
Nothing -> do
let h' = Hook Nothing Nothing Nothing url Enabled Nothing evt
liftM Just $ createHook h' at
Just h | (hUrl h /= url) -> do
let h' = h{hUrl = url}
liftM Just $ modifyHook h' at
_ -> return Nothing
-- | register a call back using the given route
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 $ createHook h
-- | parse a event from a notification callback
parseMPNotification :: (Y.MonadHandler m, Y.HandlerSite m ~ 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"
-- | catches any exception that the MangoPay library may throw and deals with it in a error handler
catchMP :: forall (m :: * -> *) a.
Y.MonadBaseControl IO m =>
m a -> (MpException -> m a) -> m a
catchMP=L.catch
-----------------------------------------------------------------------------------------------
-- Instances for MangoPay types that may be useful in a Persistent/Yesod context
$(derivePersistField "KindOfAuthentication")