yesod-mangopay 1.6 → 1.7.0
raw patch · 13 files changed
+212/−160 lines, 13 filesdep ~mangopaydep ~waidep ~warp
Dependency ranges changed: mangopay, wai, warp
Files
- app/Application.hs +7/−4
- app/Base/Util.hs +6/−15
- app/Foundation.hs +2/−2
- app/Handler/Account.hs +5/−9
- app/Handler/Card.hs +9/−11
- app/Handler/Doc.hs +4/−6
- app/Handler/Home.hs +1/−3
- app/Handler/Transaction.hs +12/−23
- app/Handler/User.hs +52/−27
- app/Handler/Wallet.hs +46/−25
- app/Import.hs +1/−0
- src/Yesod/MangoPay.hs +63/−31
- yesod-mangopay.cabal +4/−4
app/Application.hs view
@@ -19,6 +19,7 @@ import Network.Wai.Logger (clockDateCacher) import Data.Default (def) import Yesod.Core.Types (loggerSet, Logger (Logger))+import Network.Wai.Middleware.MethodOverride (methodOverride) -- Import all relevant handler modules here. -- Don't forget to add new modules to your cabal file!@@ -58,7 +59,7 @@ else Apache FromSocket , destination = RequestLogger.Logger $ loggerSet $ appLogger foundation }- + -- register all notification callbacks -- we need a handler to resolve the Route URL -- so we use runFakeHandler, because all the caveats the doc outlines don't apply to us@@ -66,10 +67,12 @@ err<-runFakeHandler M.empty appLogger foundation (registerAllMPCallbacks MPHookR) print err hFlush stdout- + -- Create the WAI application and apply middlewares+ -- Using MethodOverride middleware to allow PUT forms see:+ -- http://stackoverflow.com/questions/22902419 app <- toWaiAppPlain foundation- return $ logWare app+ return $ logWare $ methodOverride app -- | Loads up any necessary settings, creates your foundation datatype, and -- performs some initialization.@@ -79,7 +82,7 @@ s <- staticSite loggerSet' <- newStdoutLoggerSet defaultBufSize (getter, updater) <- clockDateCacher- iorToken<-newIORef Nothing + iorToken<-newIORef Nothing iorEvents<-newIORef [] -- If the Yesod logger (as opposed to the request logger middleware) is -- used less than once a second on average, you may prefer to omit this
app/Base/Util.hs view
@@ -16,29 +16,20 @@ import Web.MangoPay -- -- | localized field localizedFS :: forall master msg. RenderMessage master msg => msg -> FieldSettings master-localizedFS n=FieldSettings (SomeMessage n) Nothing Nothing Nothing [] +localizedFS n=FieldSettings (SomeMessage n) Nothing Nothing Nothing [] -- | disabled field disabled :: forall master. FieldSettings master -> FieldSettings master disabled fs= fs{fsAttrs= ("disabled",""):fsAttrs fs} ---- | disable field if the maybe is just (for fields you can set when creating but not when editing)-disabledIfJust :: forall t master.- Maybe t -> FieldSettings master -> FieldSettings master-disabledIfJust (Just _)=disabled-disabledIfJust _=id---- | show text and identifier for all values of an enum +-- | show text and identifier for all values of an enum ranges :: forall a. (Bounded a, Enum a, Show a) => [(Text, a)]-ranges=map (pack . show &&& id) [minBound..maxBound] +ranges=map (pack . show &&& id) [minBound..maxBound] -- | the type of an html form type HtmlForm a= Maybe a -> Html -> MForm Handler (FormResult a, Widget)@@ -56,7 +47,7 @@ pg<-liftM (fromMaybe "1") $ lookupGetParam "page" let Right (i,_)=decimal pg return $ Just $ Pagination i 10- + -- | previous and next page number getPaginationNav :: forall a. Maybe Pagination -> PagedList a -> (Maybe Integer, Maybe Integer)@@ -68,9 +59,9 @@ then Just (i-1) else Nothing in (previous,next)-getPaginationNav _ _= (Nothing,Nothing) +getPaginationNav _ _= (Nothing,Nothing) - + -- | country field countryField :: RenderMessage site FormMessage => Field (HandlerT site IO) CountryCode
app/Foundation.hs view
@@ -66,7 +66,7 @@ approotRequest :: App -> Request -> Text approotRequest master request | pathInfo request==["runFakeHandler", "pathInfo"] = appRoot $ settings master- | (not $ null $ pathInfo request) && (head (pathInfo request) == "card") = appRoot $ settings master + | (not $ null $ pathInfo request) && (head (pathInfo request) == "card") = appRoot $ settings master | otherwise= "" -- Please see the documentation for the Yesod typeclass. There are a number@@ -161,4 +161,4 @@ let exception=show e setTitleI MsgRequestFail $(widgetFile "request_fail"))- +
app/Handler/Account.hs view
@@ -12,7 +12,6 @@ -- no paging, should be reasonable accounts<-runYesodMPTToken $ getAll $ listAccounts uid defaultLayout $ do- aDomId <- newIdent setTitleI MsgTitleAccounts $(widgetFile "accounts") @@ -21,7 +20,6 @@ getAccountR uid=do (widget, enctype) <- generateFormPost accountForm defaultLayout $ do- aDomId <- newIdent setTitleI MsgTitleAccount $(widgetFile "account") @@ -32,21 +30,19 @@ case result of FormSuccess bap-> catchMP (do- _<-runYesodMPTToken $ storeAccount (toBankAccount uid bap)+ _<-runYesodMPTToken $ createAccount (toBankAccount uid bap) setMessageI MsgAccountDone redirect $ AccountsR uid ) (\e->do setMessage $ toHtml $ show e defaultLayout $ do- aDomId <- newIdent setTitleI MsgTitleAccount $(widgetFile "account") ) _ -> do setMessageI MsgErrorData defaultLayout $ do- aDomId <- newIdent setTitleI MsgTitleAccount $(widgetFile "account") @@ -58,11 +54,11 @@ ,bapOwnerName :: Text ,bapOwnerAddress :: Maybe Text }- + -- | get the proper BankAccount structure toBankAccount :: AnyUserID -> BankAccountPartial -> BankAccount toBankAccount uid bap=BankAccount Nothing Nothing (Just uid) (bapTag bap) (IBAN (bapIBAN bap) (bapBIC bap))- (bapOwnerName bap) (bapOwnerAddress bap) + (bapOwnerName bap) (bapOwnerAddress bap) -- | form for bank account accountForm :: Html -> MForm Handler (FormResult BankAccountPartial, Widget)@@ -70,5 +66,5 @@ <$> aopt textField (localizedFS MsgAccountCustomData) Nothing <*> areq textField (localizedFS MsgAccountIBAN) Nothing <*> areq textField (localizedFS MsgAccountBIC) Nothing- <*> areq textField (localizedFS MsgAccountOwnerName) Nothing - <*> aopt textField (localizedFS MsgAccountOwnerAddress) Nothing + <*> areq textField (localizedFS MsgAccountOwnerName) Nothing+ <*> aopt textField (localizedFS MsgAccountOwnerAddress) Nothing
app/Handler/Card.hs view
@@ -22,10 +22,9 @@ cards<-runYesodMPTToken $ getAll $ listCards uid ((_,widget), enctype) <- generateFormGet currencyForm defaultLayout $ do- aDomId <- newIdent setTitleI MsgTitleCards $(widgetFile "cards")- + -- | get card registration form -- this form will not be sent to this server, but to the validation server! -- we have an iframe in that page@@ -46,8 +45,8 @@ case result of FormSuccess curr->catchW $ do let cr1=mkCardRegistration uid curr- -- step 1: store pending registration- cr2<-runYesodMPTToken $ storeCardRegistration cr1+ -- step 1: create pending registration+ cr2<-runYesodMPTToken $ createCardRegistration cr1 let Just url = crCardRegistrationURL cr2 -- the url of the validation server Just pre = crPreregistrationData cr2 Just ak = crAccessKey cr2@@ -55,9 +54,8 @@ setSession "cardReg" $ toStrict $ toLazyText $ encodeToTextBuilder $ toJSON cr2 -- generate hidden form (widget, enctype) <- generateFormPost cardTokenForm- + defaultLayout $ do- aDomId <- newIdent -- JQuery is useful! addScriptRemote "https://ajax.googleapis.com/ajax/libs/jquery/1.9.0/jquery.min.js" setTitleI MsgTitleCard@@ -75,8 +73,8 @@ getCard2R =do qs<-liftM rawQueryString waiRequest respond typePlain qs- --- | this gets the token via JavaScript submission ++-- | this gets the token via JavaScript submission postCardR :: AnyUserID -> Handler Html postCardR uid=do ((result, _), _) <- runFormPost cardTokenForm@@ -93,7 +91,7 @@ let ecr=eitherDecode $ fromChunks [TE.encodeUtf8 jcr] case ecr of Right cr->do- _<-runYesodMPTToken $ storeCardRegistration cr{crRegistrationData=Just dat}+ _<-runYesodMPTToken $ modifyCardRegistration cr{crRegistrationData=Just dat} setMessageI MsgCardDone redirect $ CardsR uid Left err->do@@ -108,7 +106,7 @@ -- | token for card registration data Token=Token Text deriving Show- + -- | simple form for card registration -- the field is hidden and populated via JavaScript (card.julius) cardTokenForm :: Html -> MForm Handler (FormResult Token, Widget)@@ -119,4 +117,4 @@ currencyForm :: Html -> MForm Handler (FormResult Currency, Widget) currencyForm = renderDivs $ id <$> areq (selectFieldList (map (id &&& id) supportedCurrencies)) (localizedFS MsgCardCurrency) (Just "EUR")- +
app/Handler/Doc.hs view
@@ -16,25 +16,23 @@ getDocR uid= do (widget, enctype) <- generateFormPost uploadForm defaultLayout $ do- aDomId <- newIdent setTitleI MsgTitleDocument $(widgetFile "docupload") -- | upload doc and file and show result postDocR :: AnyUserID -> Handler Html postDocR uid=do- ((result, widget), enctype) <- runFormPost uploadForm+ ((result, _), _) <- runFormPost uploadForm case result of FormSuccess (DocUpload fi tag typ)-> catchMP (do let doc=Document Nothing Nothing tag typ (Just CREATED) Nothing Nothing- docWritten0<-runYesodMPTToken $ storeDocument uid doc+ docWritten0<-runYesodMPTToken $ createDocument uid doc bs<-liftIO $ runResourceT $ fileSourceRaw fi $$ sinkLbs- runYesodMPTToken $ storePage uid (fromJust $ dId docWritten0) $ toStrict bs+ runYesodMPTToken $ createPage uid (fromJust $ dId docWritten0) $ toStrict bs -- setting to validated causes internal server error...- docWritten<-runYesodMPTToken $ storeDocument uid (docWritten0{dStatus=Just VALIDATION_ASKED})+ docWritten<-runYesodMPTToken $ modifyDocument uid (docWritten0{dStatus=Just VALIDATION_ASKED}) defaultLayout $ do- aDomId <- newIdent setTitleI MsgDocDone $(widgetFile "doc") )
app/Handler/Home.hs view
@@ -18,7 +18,6 @@ let (previous,next)=getPaginationNav pg usersL let users=plData usersL defaultLayout $ do- aDomId <- newIdent setTitleI MsgHello $(widgetFile "homepage") @@ -28,7 +27,7 @@ evt<-parseMPNotification site <- getYesod ok <- runYesodMPTToken $ checkEvent evt- when ok $ + when ok $ -- prepend event to list liftIO $ modifyIORef (appEvents site) (evt :) -- send simple response@@ -40,6 +39,5 @@ site <- getYesod events<-liftIO $ readIORef (appEvents site) defaultLayout $ do- aDomId <- newIdent setTitleI MsgTitleEvents $(widgetFile "events")
app/Handler/Transaction.hs view
@@ -18,11 +18,10 @@ let (previous,next)=getPaginationNav pg txsL let txs=plData txsL defaultLayout $ do- aDomId <- newIdent setTitleI MsgTitleTransactions $(widgetFile "transactions")- + -- | get payin form getPayinR :: AnyUserID -> Handler Html getPayinR uid=do@@ -30,7 +29,6 @@ wallets<-runYesodMPTToken $ getAll $ listWallets uid (widget, enctype) <- generateFormPost $ payinInForm cards wallets defaultLayout $ do- aDomId <- newIdent setTitleI MsgTitlePayIn $(widgetFile "payin") @@ -39,27 +37,25 @@ postPayinR uid=do cards<-runYesodMPTToken $ getAll $ listCards uid wallets<-runYesodMPTToken $ getAll $ listWallets uid- + ((result, widget), enctype) <- runFormPost $ payinInForm cards wallets case result of FormSuccess (PayIn cid wid am cur)->do let cpi=mkCardPayin uid uid wid (Amount cur am) (Amount cur 0) "http://dummy" cid catchMP (do- _<-runYesodMPTToken $ storeCardPayin cpi+ _<-runYesodMPTToken $ createCardPayin cpi setMessageI MsgPayInDone redirect $ TransactionsR uid ) (\e->do setMessage $ toHtml $ show e defaultLayout $ do- aDomId <- newIdent setTitleI MsgTitlePayIn $(widgetFile "payin")- ) + ) _ -> do setMessageI MsgErrorData defaultLayout $ do- aDomId <- newIdent setTitleI MsgTitlePayIn $(widgetFile "payin") @@ -68,7 +64,6 @@ getTransfer1R uid=do users<-runYesodMPTToken $ getAll listUsers defaultLayout $ do- aDomId <- newIdent setTitleI MsgTitleTransfer $(widgetFile "transfer1") @@ -79,7 +74,6 @@ toWallets<-runYesodMPTToken $ getAll $ listWallets touid (widget, enctype) <- generateFormPost $ transferForm fromWallets toWallets defaultLayout $ do- aDomId <- newIdent setTitleI MsgTitleTransfer $(widgetFile "transfer2") @@ -88,7 +82,7 @@ postTransfer2R uid touid=do fromWallets<-runYesodMPTToken $ getAll $ listWallets uid toWallets<-runYesodMPTToken $ getAll $ listWallets touid- + ((result, widget), enctype) <- runFormPost $ transferForm fromWallets toWallets case result of FormSuccess (MPTransfer from to am cur)->do@@ -102,14 +96,12 @@ (\e->do setMessage $ toHtml $ show e defaultLayout $ do- aDomId <- newIdent setTitleI MsgTitleTransfer $(widgetFile "transfer2")- ) + ) _ -> do setMessageI MsgErrorData defaultLayout $ do- aDomId <- newIdent setTitleI MsgTitleTransfer $(widgetFile "transfer2") @@ -118,10 +110,9 @@ getPayoutR uid=do wallets<-runYesodMPTToken $ getAll $ listWallets uid accounts<-runYesodMPTToken $ getAll $ listAccounts uid- + (widget, enctype) <- generateFormPost $ payoutForm wallets accounts defaultLayout $ do- aDomId <- newIdent setTitleI MsgTitlePayOut $(widgetFile "payout") @@ -130,27 +121,25 @@ postPayoutR uid=do wallets<-runYesodMPTToken $ getAll $ listWallets uid accounts<-runYesodMPTToken $ getAll $ listAccounts uid- + ((result, widget), enctype) <- runFormPost $ payoutForm wallets accounts case result of FormSuccess (PayOut wid aid am cur)->do let po=mkPayout uid wid (Amount cur am) (Amount cur 0) aid catchMP (do- _<-runYesodMPTToken $ storePayout po+ _<-runYesodMPTToken $ createPayout po setMessageI MsgPayOutDone redirect $ TransactionsR uid ) (\e->do setMessage $ toHtml $ show e defaultLayout $ do- aDomId <- newIdent setTitleI MsgTitlePayOut $(widgetFile "payout")- ) + ) _ -> do setMessageI MsgErrorData defaultLayout $ do- aDomId <- newIdent setTitleI MsgTitlePayOut $(widgetFile "payout") @@ -169,7 +158,7 @@ -- | data necessary for transfer data MPTransfer= MPTransfer WalletID WalletID Integer Currency- + -- | transfer form transferForm :: [Wallet] -> [Wallet] -> Html -> MForm Handler (FormResult MPTransfer, Widget) transferForm fromWallets toWallets=renderDivs $ MPTransfer@@ -188,4 +177,4 @@ <*> areq (selectFieldList (map ((pack . show . baDetails) &&& (fromJust . baId)) accounts)) (localizedFS MsgPayOutAccount) Nothing <*> areq intField (localizedFS MsgPayOutAmount) Nothing <*> areq (selectFieldList (map (id &&& id) supportedCurrencies)) (localizedFS MsgPayOutCurrency) Nothing- +
app/Handler/User.hs view
@@ -18,54 +18,73 @@ let muser=Just nu (widget, enctype) <- generateFormPost $ naturalUserForm muser defaultLayout $ do- aDomId <- newIdent setTitleI MsgTitleNUser- $(widgetFile "nuser") + let (formMethod, msgFormTitle) = formVariables $ Left muser+ $(widgetFile "nuser") (Right lu)->do let muser=Just lu (widget, enctype) <- generateFormPost $ legalUserForm muser defaultLayout $ do- aDomId <- newIdent+ let (formMethod, msgFormTitle) = formVariables $ Right muser setTitleI MsgTitleLUser- $(widgetFile "luser") + $(widgetFile "luser") -- | get a natural user form getNUserR :: Handler Html getNUserR =do- (muser,widget,enctype)<- userGet naturalUserForm fetchNaturalUser + (muser,widget,enctype)<- userGet naturalUserForm fetchNaturalUser defaultLayout $ do- aDomId <- newIdent+ let (formMethod, msgFormTitle) = formVariables $ Left muser setTitleI MsgTitleNUser $(widgetFile "nuser") -- | post a natural user form postNUserR :: Handler Html postNUserR = do- (muser,widget,enctype)<- userPost naturalUserForm storeNaturalUser + (muser,widget,enctype)<- userPost naturalUserForm createNaturalUser defaultLayout $ do- aDomId <- newIdent+ let (formMethod, msgFormTitle) = formVariables $ Left muser setTitleI MsgTitleNUser $(widgetFile "nuser") +-- | put a natural user form, to modify an existing natural user+putNUserR :: Handler Html+putNUserR = do+ (muser,widget,enctype)<- userPost naturalUserForm modifyNaturalUser+ defaultLayout $ do+ setTitleI MsgTitleNUser+ let (formMethod, msgFormTitle) = formVariables $ Left muser+ $(widgetFile "nuser")+ -- | get a legal user form getLUserR :: Handler Html getLUserR = do- (muser,widget,enctype)<- userGet legalUserForm fetchLegalUser + (muser,widget,enctype)<- userGet legalUserForm fetchLegalUser defaultLayout $ do- aDomId <- newIdent+ let (formMethod, msgFormTitle) = formVariables $ Right muser setTitleI MsgTitleLUser $(widgetFile "luser") -- | post a legal user form postLUserR :: Handler Html postLUserR = do- (muser,widget,enctype)<- userPost legalUserForm storeLegalUser+ (muser,widget,enctype)<- userPost legalUserForm createLegalUser defaultLayout $ do- aDomId <- newIdent+ let (formMethod, msgFormTitle) = formVariables $ Right muser setTitleI MsgTitleLUser $(widgetFile "luser") --- | common code for retrieval and form building ++-- | post a legal user form+putLUserR :: Handler Html+putLUserR = do+ (muser,widget,enctype)<- userPost legalUserForm modifyLegalUser+ defaultLayout $ do+ let (formMethod, msgFormTitle) = formVariables $ Right muser+ setTitleI MsgTitleLUser+ $(widgetFile "luser")++-- | common code for retrieval and form building userGet :: HtmlForm a -> (Text -> AccessToken -> MangoPayT Handler a) -> Handler (Maybe a, Widget, Enctype)@@ -93,7 +112,7 @@ (\e->do setMessage $ toHtml $ show e return (Just u)- ) + ) _ -> do setMessageI MsgErrorData return Nothing@@ -101,15 +120,15 @@ return (muser,widget,enctype) --- | form for natural user +-- | form for natural user naturalUserForm :: HtmlForm NaturalUser-naturalUserForm muser= renderDivs $ NaturalUser +naturalUserForm muser= renderDivs $ NaturalUser <$> aopt hiddenField "" (uId <$> muser) <*> pure (join $ uCreationDate <$> muser) <*> areq textField (localizedFS MsgUserEmail) (uEmail <$> muser)- <*> areq textField (localizedFS MsgUserFirst) (uFirstName <$> muser) + <*> areq textField (localizedFS MsgUserFirst) (uFirstName <$> muser) <*> areq textField (localizedFS MsgUserLast) (uLastName <$> muser)- <*> aopt textField (localizedFS MsgUserAddress) (uAddress <$> muser) + <*> aopt textField (localizedFS MsgUserAddress) (uAddress <$> muser) <*> (day2Posix <$> areq (jqueryDayField def { jdsChangeYear = True -- give a year dropdown , jdsYearRange = "1900:-5" -- 1900 till five years ago@@ -121,30 +140,36 @@ <*> aopt textField (localizedFS MsgUserCustomData) (uTag <$> muser) <*> aopt textField (disabled $ localizedFS MsgUserProofIdentity) (uProofOfIdentity <$> muser) -- value comes from Documents uploaded <*> aopt textField (disabled $ localizedFS MsgUserProofAddress) (uProofOfAddress <$> muser) -- value comes from Documents uploaded- where + where -- | form for legal user legalUserForm :: HtmlForm LegalUser-legalUserForm muser= renderDivs $ LegalUser +legalUserForm muser= renderDivs $ LegalUser <$> aopt hiddenField "" (lId <$> muser) <*> pure (join $ lCreationDate <$> muser) <*> areq textField (localizedFS MsgUserEmail) (lEmail <$> muser)- <*> areq textField (localizedFS MsgUserName) (lName <$> muser) + <*> areq textField (localizedFS MsgUserName) (lName <$> muser) <*> areq (selectFieldList ranges) (localizedFS MsgUserPersonType) (lLegalPersonType <$> muser) <*> aopt textField (localizedFS MsgUserHQAddress) (lHeadquartersAddress <$> muser) <*> areq textField (localizedFS MsgUserRepFirst) (lLegalRepresentativeFirstName <$> muser) <*> areq textField (localizedFS MsgUserRepLast) (lLegalRepresentativeLastName <$> muser)- <*> aopt textField (localizedFS MsgUserRepAddress) (lLegalRepresentativeAddress <$> muser) - <*> aopt textField (localizedFS MsgUserRepEmail) (lLegalRepresentativeEmail <$> muser) + <*> aopt textField (localizedFS MsgUserRepAddress) (lLegalRepresentativeAddress <$> muser)+ <*> aopt textField (localizedFS MsgUserRepEmail) (lLegalRepresentativeEmail <$> muser) <*> (day2Posix <$> areq (jqueryDayField def { jdsChangeYear = True -- give a year dropdown , jdsYearRange = "1900:-5" -- 1900 till five years ago- }) (localizedFS MsgUserRepBirthday) (posix2Day <$> lLegalRepresentativeBirthday <$> muser)) - <*> areq countryField (localizedFS MsgUserRepNationality) (lLegalRepresentativeNationality <$> muser) + }) (localizedFS MsgUserRepBirthday) (posix2Day <$> lLegalRepresentativeBirthday <$> muser))+ <*> areq countryField (localizedFS MsgUserRepNationality) (lLegalRepresentativeNationality <$> muser) <*> areq countryField (localizedFS MsgUserRepCountry) (lLegalRepresentativeCountryOfResidence <$> muser) <*> pure Nothing -- value comes from Documents uploaded (I think)- <*> aopt textField (localizedFS MsgUserCustomData) (lTag <$> muser) + <*> aopt textField (localizedFS MsgUserCustomData) (lTag <$> muser) <*> pure Nothing -- value comes from Documents uploaded <*> pure Nothing -- value comes from Documents uploaded - ++formVariables :: Either (Maybe NaturalUser) (Maybe LegalUser) -> (Text, AppMessage)+formVariables = either (\n -> process $ mid uId n) (\l -> process $ mid lId l)+ where mid getId mu = do+ u <- mu+ getId u+ process = maybe ("", MsgUserCreate) (\i -> ("?_method=PUT", MsgUserModify $ i))
app/Handler/Wallet.hs view
@@ -1,10 +1,12 @@+{-# LANGUAGE ConstraintKinds #-} module Handler.Wallet where import Import import Web.MangoPay import Yesod.MangoPay-import Control.Monad (join, liftM)+import Control.Monad (join) import Control.Arrow ((&&&))+import Data.Text (pack) -- | get wallet list getWalletsR :: AnyUserID -> Handler Html@@ -12,56 +14,75 @@ -- no paging, should be reasonable wallets<-runYesodMPTToken $ getAll $ listWallets uid defaultLayout $ do- aDomId <- newIdent setTitleI MsgTitleWallets $(widgetFile "wallets") --- | get wallet creation/edition form+-- | get wallet creation form getWalletR :: AnyUserID -> Handler Html-getWalletR uid=do- mwid<-lookupGetParam "id"- mwallet<-case mwid of- Just wid->liftM Just $ runYesodMPTToken $ fetchWallet wid- _->return Nothing- (widget, enctype) <- generateFormPost $ walletForm mwallet- defaultLayout $ do- aDomId <- newIdent+getWalletR uid = readerWallet uid Nothing++-- | get wallet edition form+getWalletEditR :: AnyUserID -> WalletID -> Handler Html+getWalletEditR uid wid = do+ wallet <- runYesodMPTToken $ fetchWallet wid+ readerWallet uid $ Just wallet+++-- | helper to generate the proper form given maybe an existing wallet+readerWallet :: AnyUserID -> Maybe Wallet -> Handler Html+readerWallet uid mwallet = do+ (widget, enctype) <- generateFormPost $ walletForm mwallet+ let mwid = join $ wId <$> mwallet+ defaultLayout $ do setTitleI MsgTitleWallet $(widgetFile "wallet") --- | edit/create wallet-postWalletR :: AnyUserID -> Handler Html-postWalletR uid=do- ((result, widget), enctype) <- runFormPost $ walletForm Nothing++-- | helper to create or modify a wallet+helperWallet :: (Wallet -> AccessToken -> MangoPayT Handler Wallet) ->+ Maybe Wallet -> AnyUserID -> Handler Html+helperWallet fn mw uid=do+ ((result, _), _) <- runFormPost $ walletForm mw mwallet<-case result of FormSuccess w->do -- set the owner to current user let wo= w{wOwners=[uid]} catchMP (do- wallet<-runYesodMPTToken $ storeWallet wo+ wallet<-runYesodMPTToken $ fn wo setMessageI MsgWalletDone return (Just wallet) ) (\e->do+ $(logError) $ pack $ show e setMessage $ toHtml $ show e return (Just wo)- ) + ) _ -> do setMessageI MsgErrorData return Nothing- defaultLayout $ do- aDomId <- newIdent- setTitleI MsgTitleWallet- $(widgetFile "wallet")- --- | form for wallet + readerWallet uid mwallet+++postWalletR :: AnyUserID -> Handler Html+postWalletR = helperWallet createWallet Nothing+++putWalletEditR :: AnyUserID -> WalletID -> Handler Html+putWalletEditR uid wid = do+ wallet <- runYesodMPTToken $ fetchWallet wid+ helperWallet modifyWallet (Just wallet) uid+++-- | form for wallet walletForm :: HtmlForm Wallet walletForm mwallet= renderDivs $ Wallet <$> aopt hiddenField "" (wId <$> mwallet)- <*> pure (join $ wCreationDate <$> mwallet) + <*> pure (join $ wCreationDate <$> mwallet) <*> aopt textField (localizedFS MsgWalletCustomData) (wTag <$> mwallet) <*> pure [] <*> areq textField (localizedFS MsgWalletDescription) (wDescription <$> mwallet)- <*> areq (selectFieldList (map (id &&& id) supportedCurrencies)) (disabledIfJust mwallet $ localizedFS MsgWalletCurrency) (wCurrency <$> mwallet)+ <*> areq (selectFieldList (map (id &&& id) $ maybe supportedCurrencies (\mw -> [wCurrency mw]) mwallet))+ (localizedFS MsgWalletCurrency) (wCurrency <$> mwallet) -- we can't edit the amount anyway, so we show it as disabled and return a const 0 value <*> (fmap (const $ Amount "EUR" 0) <$> aopt intField (disabled $ localizedFS MsgWalletBalance) (fmap aAmount <$> wBalance <$> mwallet))+
app/Import.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} module Import ( module Import ) where
src/Yesod/MangoPay.hs view
@@ -7,17 +7,19 @@ 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.Text (Text, pack) import Data.IORef (IORef, readIORef, writeIORef) import qualified Data.Map as M-import Control.Monad (void)+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 Y.Yesod site => YesodMangoPay site where+class YesodMangoPay site where -- | The credentials of your app. mpCredentials :: site -> Credentials @@ -28,34 +30,40 @@ -- | 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 = do- site <- Y.getYesod+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)? +-- | 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@@ -81,15 +89,16 @@ Nothing -> fail "getValidToken: You need to provide the cClientSecret on the mpCredentials." Just secret-> do oat<-runMangoPayT creds manager apoint $- oauthLogin (cClientID creds) secret + 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+++-- | 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@@ -98,9 +107,20 @@ vt<-getValidToken site case vt of Nothing -> fail "runYesodMPTToken: Could not obtain access token."- Just ac-> runYesodMPT $ act ac+ 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) =>@@ -108,40 +128,52 @@ registerAllMPCallbacks rt=do render<-Y.getUrlRender let url=render rt- $(Y.logInfo) url- runYesodMPTToken $ \at-> do+ $(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- mapM_ (registerIfAbsent url at existing) [minBound..maxBound]+ liftM catMaybes $ mapM (registerIfAbsent 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 ()+ 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 $ storeHook h- --- | parse a event from a notification callback -parseMPNotification :: (Y.MonadHandler m, Y.HandlerSite m ~ site, YesodMangoPay site) => m Event+ 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 =>
yesod-mangopay.cabal view
@@ -1,5 +1,5 @@ name: yesod-mangopay-version: 1.6+version: 1.7.0 cabal-version: >= 1.8 build-type: Simple author: JP Moresmau <jpmoresmau@gmail.com>@@ -37,7 +37,7 @@ hs-source-dirs: src build-depends: base >= 4 && < 5- , mangopay == 1.6.*+ , mangopay == 1.8.* , containers >= 0.5 && < 0.6 , http-conduit >= 2.0 && < 2.2 , http-types >= 0.8.2 && < 0.9@@ -113,10 +113,10 @@ , shakespeare-js , shakespeare-text , template-haskell- , wai+ , wai >= 2.1 && < 3.1 , wai-extra , wai-logger >= 2.1 && < 2.2- , warp+ , warp >= 2.1 && < 3.1 , yaml >= 0.8 && < 0.9 , yesod-auth >= 1.2.6 , yesod-form >= 1.3.0 && < 1.4