yesod-mangopay (empty) → 1.0
raw patch · 20 files changed
+1456/−0 lines, 20 filesdep +aesondep +basedep +bytestringsetup-changed
Dependencies added: aeson, base, bytestring, conduit, containers, data-default, directory, fast-logger, hamlet, hjsmin, http-conduit, http-types, lifted-base, mangopay, monad-control, monad-logger, persistent, persistent-postgresql, persistent-template, shakespeare, shakespeare-css, shakespeare-js, shakespeare-text, template-haskell, text, time, wai, wai-extra, wai-logger, warp, yaml, yesod, yesod-auth, yesod-core, yesod-form, yesod-mangopay, yesod-persistent, yesod-static
Files
- LICENSE +27/−0
- Setup.hs +2/−0
- app/Application.hs +106/−0
- app/Base/Util.hs +68/−0
- app/Foundation.hs +155/−0
- app/Handler/Account.hs +74/−0
- app/Handler/Card.hs +58/−0
- app/Handler/Doc.hs +58/−0
- app/Handler/Home.hs +42/−0
- app/Handler/Transaction.hs +191/−0
- app/Handler/User.hs +150/−0
- app/Handler/Wallet.hs +67/−0
- app/Import.hs +29/−0
- app/Settings.hs +82/−0
- app/Settings/Development.hs +14/−0
- app/Settings/StaticFiles.hs +35/−0
- app/main.hs +8/−0
- src/Yesod/MangoPay.hs +149/−0
- src/Yesod/MangoPay/Util.hs +14/−0
- yesod-mangopay.cabal +127/−0
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2014, Prowdsponsor+All rights reserved.++Redistribution and use in source and binary forms, with or without modification,+are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice, this+ list of conditions and the following disclaimer in the documentation and/or+ other materials provided with the distribution.++* Neither the name of the Prowdsponsor nor the names of its+ contributors may be used to endorse or promote products derived from+ this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON+ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Application.hs view
@@ -0,0 +1,106 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Application+ ( makeApplication+ , getApplicationDev+ , makeFoundation+ ) where++import Import+import Yesod.Default.Config+import Yesod.Default.Main+import Yesod.Default.Handlers+import Network.Wai.Middleware.RequestLogger+ ( mkRequestLogger, outputFormat, OutputFormat (..), IPAddrSource (..), destination+ )+import qualified Network.Wai.Middleware.RequestLogger as RequestLogger+import Network.HTTP.Conduit (newManager, conduitManagerSettings)+import Control.Concurrent (forkIO, threadDelay)+import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize)+import Network.Wai.Logger (clockDateCacher)+import Data.Default (def)+import Yesod.Core.Types (loggerSet, Logger (Logger))++-- Import all relevant handler modules here.+-- Don't forget to add new modules to your cabal file!+import Handler.Home+import Handler.User+import Handler.Doc+import Handler.Wallet+import Handler.Card+import Handler.Account+import Handler.Transaction++import Data.IORef (newIORef)++import Yesod.MangoPay++import qualified Data.Map as M+import System.IO (stdout, hFlush)++-- This line actually creates our YesodDispatch instance. It is the second half+-- of the call to mkYesodData which occurs in Foundation.hs. Please see the+-- comments there for more details.+mkYesodDispatch "App" resourcesApp++-- This function allocates resources (such as a database connection pool),+-- performs initialization and creates a WAI application. This is also the+-- place to put your migrate statements to have automatic database+-- migrations handled by Yesod.+makeApplication :: AppConfig DefaultEnv Extra -> IO Application+makeApplication conf = do+ foundation <- makeFoundation conf++ -- Initialize the logging middleware+ logWare <- mkRequestLogger def+ { outputFormat =+ if development+ then Detailed True+ 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+ -- we don't need anything from the request, nor do we change anything in our state+ err<-runFakeHandler M.empty appLogger foundation (registerAllMPCallbacks MPHookR)+ print err+ hFlush stdout+ + -- Create the WAI application and apply middlewares+ app <- toWaiAppPlain foundation+ return $ logWare app++-- | Loads up any necessary settings, creates your foundation datatype, and+-- performs some initialization.+makeFoundation :: AppConfig DefaultEnv Extra -> IO App+makeFoundation conf = do+ manager <- newManager conduitManagerSettings+ s <- staticSite+ loggerSet' <- newStdoutLoggerSet defaultBufSize+ (getter, updater) <- clockDateCacher+ 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+ -- thread and use "(updater >> getter)" in place of "getter" below. That+ -- would update the cache every time it is used, instead of every second.+ let updateLoop = do+ threadDelay 1000000+ updater+ updateLoop+ _ <- forkIO updateLoop++ let logger = Yesod.Core.Types.Logger loggerSet' getter+ foundation = App conf s manager logger iorToken iorEvents++ return foundation++-- for yesod devel+getApplicationDev :: IO (Int, Application)+getApplicationDev =+ defaultDevelApp loader makeApplication+ where+ loader = Yesod.Default.Config.loadConfig (configSettings Development)+ { csParseExtra = parseExtra+ }
+ app/Base/Util.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE RankNTypes #-}+-- | utility functions for Yesod, that are used in the site but are not really generic enough to be put in the library+module Base.Util where++import Yesod+import Prelude+import Foundation++import Data.Text hiding (map)+import Control.Arrow ((&&&))+import Data.Maybe (fromMaybe)+import Control.Monad (liftM)+import Data.Text.Read (decimal)++import Web.MangoPay++-- | localized field+localizedFS :: forall master msg.+ RenderMessage master msg =>+ msg -> FieldSettings master+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 +ranges :: forall a. (Bounded a, Enum a, Show a) => [(Text, a)]+ranges=map (pack . show &&& id) [minBound..maxBound] ++-- | the type of an html form+type HtmlForm a= Maybe a -> Html -> MForm Handler (FormResult a, Widget)++-- | supported currencies+supportedCurrencies :: [Currency]+supportedCurrencies=["EUR","USD","GBP","PLN","CHF"]++-- | extract pagination info from parameters+getPagination :: forall (m :: * -> *).+ MonadHandler m =>+ m (Maybe Pagination)+getPagination = do+ -- poor man's parameter handling...+ 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)+getPaginationNav (Just (Pagination i _)) l=let+ next=if plPageCount l > i+ then Just (i+1)+ else Nothing+ previous=if i>1+ then Just (i-1)+ else Nothing+ in (previous,next)+getPaginationNav _ _= (Nothing,Nothing) +
+ app/Foundation.hs view
@@ -0,0 +1,155 @@+module Foundation where++import Prelude+import Yesod+import Yesod.Static+import Yesod.Default.Config+import Yesod.Default.Util (addStaticContentExternal)+import Network.HTTP.Conduit (Manager)+import qualified Settings+import Settings.Development (development)+import Settings.StaticFiles+import Settings (widgetFile, Extra (..))+import Text.Jasmine (minifym)+import Text.Hamlet (hamletFile)+import Yesod.Core.Types (Logger)++import Yesod.MangoPay+import Web.MangoPay+import Data.IORef (IORef)+import Yesod.Form.Jquery (YesodJquery)+import Network.Wai (pathInfo,Request)+import Data.Text (Text)++-- | The site argument for your application. This can be a good place to+-- keep settings and values requiring initialization before your application+-- starts running, such as database connections. Every handler will have+-- access to the data present here.+data App = App+ { settings :: AppConfig DefaultEnv Extra+ , getStatic :: Static -- ^ Settings for static file serving.+ , httpManager :: Manager+ , appLogger :: Logger+ , appToken :: IORef (Maybe MangoPayToken) -- ^ the currently valid access token, if any+ , appEvents :: IORef [Event] -- ^ the received events, for the moment stored into a list+ }++-- Set up i18n messages. See the message folder.+mkMessage "App" "messages" "en"++-- This is where we define all of the routes in our application. For a full+-- explanation of the syntax, please see:+-- http://www.yesodweb.com/book/handler+--+-- This function does three things:+--+-- * Creates the route datatype AppRoute. Every valid URL in your+-- application can be represented as a value of this type.+-- * Creates the associated type:+-- type instance Route App = AppRoute+-- * Creates the value resourcesApp which contains information on the+-- resources declared below. This is used in Handler.hs by the call to+-- mkYesodDispatch+--+-- What this function does *not* do is create a YesodSite instance for+-- App. Creating that instance requires all of the handler functions+-- for our application to be in scope. However, the handler functions+-- usually require access to the AppRoute datatype. Therefore, we+-- split these actions into two functions and place them in separate files.+mkYesodData "App" $(parseRoutesFile "config/routes")++type Form x = Html -> MForm (HandlerT App IO) (FormResult x, Widget)++-- | use relative links unless if to register hook+-- this is useful when developing since the external address may not be the local address+approotRequest :: App -> Request -> Text+approotRequest master request+ | pathInfo request==["runFakeHandler", "pathInfo"] = appRoot $ settings master+ | otherwise= ""++-- Please see the documentation for the Yesod typeclass. There are a number+-- of settings which can be configured by overriding methods here.+instance Yesod App where+ approot = ApprootRequest approotRequest++ -- Store session data on the client in encrypted cookies,+ -- default session idle timeout is 120 minutes+ makeSessionBackend _ = fmap Just $ defaultClientSessionBackend+ (120 * 60) -- 120 minutes+ "config/client_session_key.aes"++ defaultLayout widget = do+ master <- getYesod+ mmsg <- getMessage++ -- We break up the default layout into two components:+ -- default-layout is the contents of the body tag, and+ -- default-layout-wrapper is the entire page. Since the final+ -- value passed to hamletToRepHtml cannot be a widget, this allows+ -- you to use normal widget features in default-layout.++ pc <- widgetToPageContent $ do+ $(combineStylesheets 'StaticR+ [ css_normalize_css+ , css_bootstrap_css+ ])+ $(widgetFile "default-layout")+ giveUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")++ -- This is done to provide an optimization for serving static files from+ -- a separate domain. Please see the staticRoot setting in Settings.hs+ urlRenderOverride y (StaticR s) =+ Just $ uncurry (joinPath y (Settings.staticRoot $ settings y)) $ renderRoute s+ urlRenderOverride _ _ = Nothing++ -- This function creates static content files in the static folder+ -- and names them based on a hash of their content. This allows+ -- expiration dates to be set far in the future without worry of+ -- users receiving stale content.+ addStaticContent =+ addStaticContentExternal minifym genFileName Settings.staticDir (StaticR . flip StaticRoute [])+ where+ -- Generate a unique filename based on the content itself+ genFileName lbs+ | development = "autogen-" ++ base64md5 lbs+ | otherwise = base64md5 lbs++ -- Place Javascript at bottom of the body tag so the rest of the page loads first+ jsLoader _ = BottomOfBody++ -- What messages should be logged. The following includes all messages when+ -- in development, and warnings and errors in production.+ shouldLog _ _source level =+ development || level == LevelWarn || level == LevelError++ makeLogger = return . appLogger++-- This instance is required to use forms. You can modify renderMessage to+-- achieve customized and internationalized form validation messages.+instance RenderMessage App FormMessage where+ renderMessage _ _ = defaultFormMessage++-- | Get the 'Extra' value, used to hold data from the settings.yml file.+getExtra :: Handler Extra+getExtra = fmap (appExtra . settings) getYesod++-- Note: previous versions of the scaffolding included a deliver function to+-- send emails. Unfortunately, there are too many different options for us to+-- give a reasonable default. Instead, the information is available on the+-- wiki:+--+-- https://github.com/yesodweb/yesod/wiki/Sending-email++-- | use JQuery form widgets+instance YesodJquery App++-- | MangoPay support+instance YesodMangoPay App where+ mpCredentials app=let+ extra=appExtra $ settings app+ in Credentials (mpID extra) (mpName extra) (mpEmail extra) (Just $ mpSecret extra)+ mpHttpManager=httpManager+ mpUseSandbox=mpSandbox . appExtra . settings+ mpToken=appToken++
+ app/Handler/Account.hs view
@@ -0,0 +1,74 @@+-- | account handling+module Handler.Account where++import Import+import Web.MangoPay+import Yesod.MangoPay+++-- | get account list+getAccountsR :: AnyUserID -> Handler Html+getAccountsR uid=do+ -- no paging, should be reasonable+ accounts<-runYesodMPTToken $ getAll $ listAccounts uid+ defaultLayout $ do+ aDomId <- newIdent+ setTitleI MsgTitleAccounts+ $(widgetFile "accounts")++-- | get account registration form+getAccountR :: AnyUserID -> Handler Html+getAccountR uid=do+ (widget, enctype) <- generateFormPost accountForm+ defaultLayout $ do+ aDomId <- newIdent+ setTitleI MsgTitleAccount+ $(widgetFile "account")++-- | register account+postAccountR :: AnyUserID -> Handler Html+postAccountR uid=do+ ((result, widget), enctype) <- runFormPost accountForm+ case result of+ FormSuccess bap->+ catchMP (do+ _<-runYesodMPTToken $ storeAccount (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")++-- | partial data for account+data BankAccountPartial=BankAccountPartial {+ bapTag :: Maybe Text+ ,bapIBAN :: Text+ ,bapBIC :: Text+ ,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) ++-- | form for bank account+accountForm :: Html -> MForm Handler (FormResult BankAccountPartial, Widget)+accountForm = renderDivs $ BankAccountPartial+ <$> 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
+ app/Handler/Card.hs view
@@ -0,0 +1,58 @@+-- | cards handling+module Handler.Card where++import Import+import Web.MangoPay+import Yesod.MangoPay+import Control.Arrow ((&&&))++-- | get card list+getCardsR :: AnyUserID -> Handler Html+getCardsR uid=do+ -- no paging, should be reasonable+ cards<-runYesodMPTToken $ getAll $ listCards uid+ defaultLayout $ do+ aDomId <- newIdent+ setTitleI MsgTitleCards+ $(widgetFile "cards")+ +-- | get card registration form+getCardR :: AnyUserID -> Handler Html+getCardR uid=do+ (widget, enctype) <- generateFormPost cardInfoForm+ defaultLayout $ do+ aDomId <- newIdent+ setTitleI MsgTitleCard+ $(widgetFile "card")++-- | register card+postCardR :: AnyUserID -> Handler Html+postCardR uid=do+ ((result, widget), enctype) <- runFormPost cardInfoForm+ case result of+ FormSuccess (c,ci)->+ catchMP (do+ _<-runYesodMPTToken $ fullRegistration uid c ci+ setMessageI MsgCardDone+ redirect $ CardsR uid+ )+ (\e->do+ setMessage $ toHtml $ show e+ defaultLayout $ do+ aDomId <- newIdent+ setTitleI MsgTitleCard+ $(widgetFile "card")+ )+ _ -> do+ setMessageI MsgErrorData+ defaultLayout $ do+ aDomId <- newIdent+ setTitleI MsgTitleCard+ $(widgetFile "card")+ +cardInfoForm :: Html -> MForm Handler (FormResult (Currency,CardInfo), Widget)+cardInfoForm = renderDivs $ (\a b c d-> (a,CardInfo b c d))+ <$> areq (selectFieldList (map (id &&& id) supportedCurrencies)) (localizedFS MsgCardCurrency) Nothing+ <*> areq textField (localizedFS MsgCardNumber) Nothing+ <*> areq textField (localizedFS MsgCardExpire) Nothing+ <*> areq textField (localizedFS MsgCardCSC) Nothing
+ app/Handler/Doc.hs view
@@ -0,0 +1,58 @@+-- | documents+module Handler.Doc where++import Import+import Yesod.Core.Types+import Web.MangoPay+import Yesod.MangoPay+import Data.Maybe (fromJust)+import Data.Conduit (($$), runResourceT)+import Data.Conduit.Binary (sinkLbs)+import Data.ByteString.Lazy (toStrict)++-- | get the upload form+getDocR :: AnyUserID -> Handler Html+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+ 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+ bs<-liftIO $ runResourceT $ fileSourceRaw fi $$ sinkLbs+ runYesodMPTToken $ storePage uid (fromJust $ dId docWritten0) $ toStrict bs+ -- setting to validated causes internal server error...+ docWritten<-runYesodMPTToken $ storeDocument uid (docWritten0{dStatus=Just VALIDATION_ASKED})+ defaultLayout $ do+ aDomId <- newIdent+ setTitleI MsgDocDone+ $(widgetFile "doc")+ )+ (\e->do+ setMessage $ toHtml $ show e+ redirect $ DocR uid+ )+ _ -> do+ setMessageI MsgErrorDoc+ redirect $ DocR uid++-- | the upload data type+data DocUpload=DocUpload FileInfo (Maybe Text) DocumentType++-- | the upload form+uploadForm :: Html -> MForm Handler (FormResult DocUpload, Widget)+uploadForm= renderDivs $ DocUpload+ <$> fileAFormReq (localizedFS MsgDocFile)+ <*> aopt textField (localizedFS MsgDocCustomData) Nothing+ <*> areq (selectFieldList ranges) (localizedFS MsgDocType) Nothing+ -- <*> pure (Just CREATED) -- aopt (selectFieldList ranges) (fs MsgDocStatus) Nothing+
+ app/Handler/Home.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE TupleSections, OverloadedStrings #-}+-- | home and events pages+module Handler.Home where++import Import++import Yesod.MangoPay+import Web.MangoPay+import Data.IORef (modifyIORef, readIORef)++-- | Home page+getHomeR :: Handler Html+getHomeR = do+ pg<-getPagination+ usersL<-runYesodMPTToken $ listUsers pg+ -- pagination links+ let (previous,next)=getPaginationNav pg usersL+ let users=plData usersL+ defaultLayout $ do+ aDomId <- newIdent+ setTitleI MsgHello+ $(widgetFile "homepage")++-- | notification callback page+getMPHookR :: Handler Text+getMPHookR = do+ evt<-parseMPNotification+ site <- getYesod+ -- prepend event to list+ liftIO $ modifyIORef (appEvents site) (evt :)+ -- send simple response+ sendResponse ("ok"::Text)++-- | list received events+getMPEventsR :: Handler Html+getMPEventsR = do+ site <- getYesod+ events<-liftIO $ readIORef (appEvents site)+ defaultLayout $ do+ aDomId <- newIdent+ setTitleI MsgTitleEvents+ $(widgetFile "events")
+ app/Handler/Transaction.hs view
@@ -0,0 +1,191 @@+-- | transactions: pay-in, transfer, pay-out+module Handler.Transaction where++import Import++import Yesod.MangoPay+import Web.MangoPay+import Data.Maybe (fromJust)+import Control.Arrow ((&&&))+import Data.Text (pack)++-- | transaction list+getTransactionsR :: AnyUserID -> Handler Html+getTransactionsR uid= do+ pg<-getPagination+ txsL<-runYesodMPTToken $ listTransactionsForUser uid pg+ -- pagination links+ 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+ cards<-runYesodMPTToken $ getAll $ listCards uid+ wallets<-runYesodMPTToken $ getAll $ listWallets uid+ (widget, enctype) <- generateFormPost $ payinInForm cards wallets+ defaultLayout $ do+ aDomId <- newIdent+ setTitleI MsgTitlePayIn+ $(widgetFile "payin")++-- | payin+postPayinR :: AnyUserID -> Handler Html+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+ 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")++-- | get first transfer page: choose the target user+getTransfer1R :: AnyUserID -> Handler Html+getTransfer1R uid=do+ users<-runYesodMPTToken $ getAll listUsers+ defaultLayout $ do+ aDomId <- newIdent+ setTitleI MsgTitleTransfer+ $(widgetFile "transfer1")++-- | get second transfer page: choose between wallets+getTransfer2R :: AnyUserID -> AnyUserID -> Handler Html+getTransfer2R uid touid=do+ fromWallets<-runYesodMPTToken $ getAll $ listWallets uid+ toWallets<-runYesodMPTToken $ getAll $ listWallets touid+ (widget, enctype) <- generateFormPost $ transferForm fromWallets toWallets+ defaultLayout $ do+ aDomId <- newIdent+ setTitleI MsgTitleTransfer+ $(widgetFile "transfer2")++-- | perfrm transfer+postTransfer2R :: AnyUserID -> AnyUserID -> Handler Html+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+ let t1=Web.MangoPay.Transfer Nothing Nothing Nothing uid (Just touid) (Amount cur am) (Amount cur 0)+ from to Nothing Nothing Nothing Nothing Nothing+ catchMP (do+ _<-runYesodMPTToken $ createTransfer t1+ setMessageI MsgTransferDone+ redirect $ TransactionsR uid+ )+ (\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")++-- | get payout form+getPayoutR :: AnyUserID -> Handler Html+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")++-- | payout+postPayoutR :: AnyUserID -> Handler Html+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+ 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")++++-- | data necessary for payin+data PayIn = PayIn CardID WalletID Integer Currency++-- | payin form+payinInForm :: [Card] -> [Wallet] -> Html -> MForm Handler (FormResult PayIn, Widget)+payinInForm cards wallets= renderDivs $ PayIn+ <$> areq (selectFieldList (map (cAlias &&& cId) cards)) (localizedFS MsgPayInCard) Nothing+ <*> areq (selectFieldList (map (wDescription &&& (fromJust . wId)) wallets)) (localizedFS MsgPayInWallet) Nothing+ <*> areq intField (localizedFS MsgPayInAmount) Nothing+ <*> areq (selectFieldList (map (id &&& id) supportedCurrencies)) (localizedFS MsgPayInCurrency) Nothing++-- | 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+ <$> areq (selectFieldList (map (wDescription &&& (fromJust . wId)) fromWallets)) (localizedFS MsgTransferFromWallet) Nothing+ <*> areq (selectFieldList (map (wDescription &&& (fromJust . wId)) toWallets)) (localizedFS MsgTransferToWallet) Nothing+ <*> areq intField (localizedFS MsgTransferAmount) Nothing+ <*> areq (selectFieldList (map (id &&& id) supportedCurrencies)) (localizedFS MsgTransferCurrency) Nothing++-- | data necessary for payout+data PayOut = PayOut WalletID BankAccountID Integer Currency++-- | payin form+payoutForm :: [Wallet] -> [BankAccount] -> Html -> MForm Handler (FormResult PayOut, Widget)+payoutForm wallets accounts= renderDivs $ PayOut+ <$> areq (selectFieldList (map (wDescription &&& (fromJust . wId)) wallets)) (localizedFS MsgPayOutWallet) Nothing+ <*> 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
@@ -0,0 +1,150 @@+{-# LANGUAGE ScopedTypeVariables #-}+-- | user handling+module Handler.User where++import Import+import Yesod.MangoPay+import Yesod.MangoPay.Util+import Web.MangoPay+import Yesod.Form.Jquery+import Control.Monad (join, liftM)++-- | get the form to edit any type of user+getUserR :: AnyUserID -> Handler Html+getUserR uid=do+ eu <- runYesodMPTToken $ getUser uid+ case eu of+ (Left nu)->do+ let muser=Just nu+ (widget, enctype) <- generateFormPost $ naturalUserForm muser+ defaultLayout $ do+ aDomId <- newIdent+ setTitleI MsgTitleNUser+ $(widgetFile "nuser") + (Right lu)->do+ let muser=Just lu+ (widget, enctype) <- generateFormPost $ legalUserForm muser+ defaultLayout $ do+ aDomId <- newIdent+ setTitleI MsgTitleLUser+ $(widgetFile "luser") ++-- | get a natural user form+getNUserR :: Handler Html+getNUserR =do+ (muser,widget,enctype)<- userGet naturalUserForm fetchNaturalUser + defaultLayout $ do+ aDomId <- newIdent+ setTitleI MsgTitleNUser+ $(widgetFile "nuser")++-- | post a natural user form+postNUserR :: Handler Html+postNUserR = do+ (muser,widget,enctype)<- userPost naturalUserForm storeNaturalUser + defaultLayout $ do+ aDomId <- newIdent+ setTitleI MsgTitleNUser+ $(widgetFile "nuser")++-- | get a legal user form+getLUserR :: Handler Html+getLUserR = do+ (muser,widget,enctype)<- userGet legalUserForm fetchLegalUser + defaultLayout $ do+ aDomId <- newIdent+ setTitleI MsgTitleLUser+ $(widgetFile "luser")++-- | post a legal user form+postLUserR :: Handler Html+postLUserR = do+ (muser,widget,enctype)<- userPost legalUserForm storeLegalUser+ defaultLayout $ do+ aDomId <- newIdent+ setTitleI MsgTitleLUser+ $(widgetFile "luser")++-- | common code for retrieval and form building +userGet :: HtmlForm a+ -> (Text -> AccessToken -> MangoPayT Handler a)+ -> Handler (Maybe a, Widget, Enctype)+userGet form fetch =do+ muid<-lookupGetParam "id"+ muser<-case muid of+ Just uid->liftM Just $ runYesodMPTToken $ fetch uid+ _->return Nothing+ (widget, enctype) <- generateFormPost $ form muser+ return (muser,widget,enctype)++-- | common code for storing, retrieving update and form building+userPost :: HtmlForm a+ -> (a -> AccessToken -> MangoPayT Handler a)+ -> Handler (Maybe a, Widget, Enctype)+userPost form store = do+ ((result, _), _) <- runFormPost $ form Nothing+ muser<-case result of+ FormSuccess u -> do+ catchMP (do+ user<-runYesodMPTToken $ store u+ setMessageI MsgUserDone+ return (Just user)+ )+ (\e->do+ setMessage $ toHtml $ show e+ return (Just u)+ ) + _ -> do+ setMessageI MsgErrorData+ return Nothing+ (widget, enctype) <- generateFormPost $ form muser+ return (muser,widget,enctype)+++-- | form for natural user +naturalUserForm :: HtmlForm 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 MsgUserLast) (uLastName <$> 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+ }) (localizedFS MsgUserBirthday) (posix2Day <$> uBirthday <$> muser))+ <*> areq textField (localizedFS MsgUserNationality) (uNationality <$> muser)+ <*> areq textField (localizedFS MsgUserCountry) (uCountryOfResidence <$> muser)+ <*> aopt textField (localizedFS MsgUserOccupation) (uOccupation <$> muser)+ <*> aopt (selectFieldList ranges) (localizedFS MsgUserIncome) (uIncomeRange <$> muser)+ <*> 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 ++-- | form for legal user+legalUserForm :: HtmlForm 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 (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) + <*> (day2Posix <$> areq (jqueryDayField def+ { jdsChangeYear = True -- give a year dropdown+ , jdsYearRange = "1900:-5" -- 1900 till five years ago+ }) (localizedFS MsgUserRepBirthday) (posix2Day <$> lLegalRepresentativeBirthday <$> muser)) + <*> areq textField (localizedFS MsgUserRepNationality) (lLegalRepresentativeNationality <$> muser) + <*> areq textField (localizedFS MsgUserRepCountry) (lLegalRepresentativeCountryOfResidence <$> muser)+ <*> pure Nothing -- value comes from Documents uploaded (I think)+ <*> aopt textField (localizedFS MsgUserCustomData) (lTag <$> muser) + <*> pure Nothing -- value comes from Documents uploaded+ <*> pure Nothing -- value comes from Documents uploaded++
+ app/Handler/Wallet.hs view
@@ -0,0 +1,67 @@+module Handler.Wallet where++import Import+import Web.MangoPay+import Yesod.MangoPay+import Control.Monad (join, liftM)+import Control.Arrow ((&&&))++-- | get wallet list+getWalletsR :: AnyUserID -> Handler Html+getWalletsR uid=do+ -- no paging, should be reasonable+ wallets<-runYesodMPTToken $ getAll $ listWallets uid+ defaultLayout $ do+ aDomId <- newIdent+ setTitleI MsgTitleWallets+ $(widgetFile "wallets")++-- | get wallet creation/edition 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+ setTitleI MsgTitleWallet+ $(widgetFile "wallet")++-- | edit/create wallet+postWalletR :: AnyUserID -> Handler Html+postWalletR uid=do+ ((result, widget), enctype) <- runFormPost $ walletForm Nothing+ mwallet<-case result of+ FormSuccess w->do+ -- set the owner to current user+ let wo= w{wOwners=[uid]}+ catchMP (do+ wallet<-runYesodMPTToken $ storeWallet wo+ setMessageI MsgWalletDone+ return (Just wallet)+ )+ (\e->do+ setMessage $ toHtml $ show e+ return (Just wo)+ ) + _ -> do+ setMessageI MsgErrorData+ return Nothing+ defaultLayout $ do+ aDomId <- newIdent+ setTitleI MsgTitleWallet+ $(widgetFile "wallet")+ +-- | form for wallet +walletForm :: HtmlForm Wallet+walletForm mwallet= renderDivs $ Wallet+ <$> aopt hiddenField "" (wId <$> 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)+ -- 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
@@ -0,0 +1,29 @@+module Import+ ( module Import+ ) where++import Prelude as Import hiding (head, init, last,+ readFile, tail, writeFile)+import Yesod as Import hiding (Route (..))++import Control.Applicative as Import (pure, (<$>), (<*>))+import Data.Text as Import (Text)++import Foundation as Import+import Settings as Import+import Settings.Development as Import+import Settings.StaticFiles as Import+import Base.Util as Import++#if __GLASGOW_HASKELL__ >= 704+import Data.Monoid as Import+ (Monoid (mappend, mempty, mconcat),+ (<>))+#else+import Data.Monoid as Import+ (Monoid (mappend, mempty, mconcat))++infixr 5 <>+(<>) :: Monoid m => m -> m -> m+(<>) = mappend+#endif
+ app/Settings.hs view
@@ -0,0 +1,82 @@+-- | Settings are centralized, as much as possible, into this file. This+-- includes database connection settings, static file locations, etc.+-- In addition, you can configure a number of different aspects of Yesod+-- by overriding methods in the Yesod typeclass. That instance is+-- declared in the Foundation.hs file.+module Settings where++import Prelude+import Text.Shakespeare.Text (st)+import Language.Haskell.TH.Syntax+import Yesod.Default.Config+import Yesod.Default.Util+import Data.Text (Text)+import Data.Yaml+import Control.Applicative+import Settings.Development+import Data.Default (def)+import Text.Hamlet++-- Static setting below. Changing these requires a recompile++-- | The location of static files on your system. This is a file system+-- path. The default value works properly with your scaffolded site.+staticDir :: FilePath+staticDir = "static"++-- | The base URL for your static files. As you can see by the default+-- value, this can simply be "static" appended to your application root.+-- A powerful optimization can be serving static files from a separate+-- domain name. This allows you to use a web server optimized for static+-- files, more easily set expires and cache values, and avoid possibly+-- costly transference of cookies on static files. For more information,+-- please see:+-- http://code.google.com/speed/page-speed/docs/request.html#ServeFromCookielessDomain+--+-- If you change the resource pattern for StaticR in Foundation.hs, you will+-- have to make a corresponding change here.+--+-- To see how this value is used, see urlRenderOverride in Foundation.hs+staticRoot :: AppConfig DefaultEnv x -> Text+staticRoot conf = [st|#{appRoot conf}/static|]++-- | Settings for 'widgetFile', such as which template languages to support and+-- default Hamlet settings.+--+-- For more information on modifying behavior, see:+--+-- https://github.com/yesodweb/yesod/wiki/Overriding-widgetFile+widgetFileSettings :: WidgetFileSettings+widgetFileSettings = def+ { wfsHamletSettings = defaultHamletSettings+ { hamletNewlines = AlwaysNewlines+ }+ }++-- The rest of this file contains settings which rarely need changing by a+-- user.++widgetFile :: String -> Q Exp+widgetFile = (if development then widgetFileReload+ else widgetFileNoReload)+ widgetFileSettings++data Extra = Extra+ { extraCopyright :: Text+ , extraAnalytics :: Maybe Text -- ^ Google Analytics+ , mpID :: Text -- ^ MangoPay client id+ , mpName :: Text -- ^ MangoPay client name+ , mpEmail :: Text -- ^ MangoPay client email+ , mpSecret :: Text -- ^ MangoPay client secret+ , mpSandbox:: Bool -- ^ are we using the MangoPay sandbox?+ } deriving Show++parseExtra :: DefaultEnv -> Object -> Parser Extra+parseExtra _ o = Extra+ <$> o .: "copyright"+ <*> o .:? "analytics"+ <*> o .: "mangopayClientID"+ <*> o .: "mangopayName"+ <*> o .: "mangopayEmail"+ <*> o .: "mangopaySecret"+ <*> o .: "mangopaySandbox"
+ app/Settings/Development.hs view
@@ -0,0 +1,14 @@+module Settings.Development where++import Prelude++development :: Bool+development =+#if DEVELOPMENT+ True+#else+ False+#endif++production :: Bool+production = not development
+ app/Settings/StaticFiles.hs view
@@ -0,0 +1,35 @@+module Settings.StaticFiles where++import Prelude (IO)+import Yesod.Static+import qualified Yesod.Static as Static+import Settings (staticDir)+import Settings.Development+import Language.Haskell.TH (Q, Exp, Name)+import Data.Default (def)++-- | use this to create your static file serving site+staticSite :: IO Static.Static+staticSite = if development then Static.staticDevel staticDir+ else Static.static staticDir++-- | This generates easy references to files in the static directory at compile time,+-- giving you compile-time verification that referenced files exist.+-- Warning: any files added to your static directory during run-time can't be+-- accessed this way. You'll have to use their FilePath or URL to access them.+$(staticFiles Settings.staticDir)++combineSettings :: CombineSettings+combineSettings = def++-- The following two functions can be used to combine multiple CSS or JS files+-- at compile time to decrease the number of http requests.+-- Sample usage (inside a Widget):+--+-- > $(combineStylesheets 'StaticR [style1_css, style2_css])++combineStylesheets :: Name -> [Route Static] -> Q Exp+combineStylesheets = combineStylesheets' development combineSettings++combineScripts :: Name -> [Route Static] -> Q Exp+combineScripts = combineScripts' development combineSettings
+ app/main.hs view
@@ -0,0 +1,8 @@+import Prelude (IO)+import Yesod.Default.Config (fromArgs)+import Yesod.Default.Main (defaultMain)+import Settings (parseExtra)+import Application (makeApplication)++main :: IO ()+main = defaultMain (fromArgs parseExtra) makeApplication
+ src/Yesod/MangoPay.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE OverloadedStrings, TypeFamilies, FlexibleContexts,TemplateHaskell, RankNTypes #-}+-- | 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.Set as S+import qualified Data.Map as M+import Control.Monad (void)+import qualified Control.Exception.Lifted as L++-- | The 'YesodMangoPay' class for foundation datatypes that+-- support running 'MangoPayT' actions.+class Y.Yesod site => 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,Y.MonadBaseControl IO 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++-- | 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,Y.MonadBaseControl IO m,Y.MonadResource 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,Y.MonadBaseControl IO 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+++-- | 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,Y.MonadBaseControl IO m,Y.MonadLogger 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+ -- 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]+ 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 ()++-- | register a call back using the given route+registerMPCallback :: (Y.MonadHandler m,Y.MonadBaseControl IO 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+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 func =L.catch func
+ src/Yesod/MangoPay/Util.hs view
@@ -0,0 +1,14 @@+-- | utilities functions that could be useful+module Yesod.MangoPay.Util where++import Data.Time.Clock.POSIX+import Data.Time.Clock+import Data.Time.Calendar++-- | day to posix time+day2Posix :: Day -> POSIXTime+day2Posix d=utcTimeToPOSIXSeconds $ UTCTime d 0++-- | posix time to Day+posix2Day :: POSIXTime -> Day+posix2Day =utctDay . posixSecondsToUTCTime
+ yesod-mangopay.cabal view
@@ -0,0 +1,127 @@+name: yesod-mangopay+version: 1.0+cabal-version: >= 1.8+build-type: Simple+author: JP Moresmau <jpmoresmau@gmail.com>+license: BSD3+license-file: LICENSE+copyright: (c) 2014 Prowdsponsor+category: Web+homepage: https://github.com/prowdsponsor/mangopay+maintainer: Prowdsponsor <opensource@prowdsponsor.com>+synopsis: Yesod library for MangoPay API access++description:+ This package provides convenince functions when using both+ @yesod@ and @mangopay@ packages. It also includes a test+ application that is built when the library-only flag is set to+ @False@.++source-repository head+ type: git+ location: git://github.com/prowdsponsor/mangopay.git++Flag dev+ Description: Turn on development settings, like auto-reload templates.+ Default: False++Flag library-only+ Description: Only build the library and not the test application+ Default: True++library+ ghc-options: -Wall+ hs-source-dirs: src+ build-depends:+ base >= 4 && < 5+ , yesod >= 1.2.5 && < 1.3+ , yesod-core >= 1.2 && < 1.3+ , mangopay == 0.1+ , http-conduit >= 2.0 && < 2.1+ , time >=1.4.0 && <1.5+ , http-types >=0.8.2 && <0.9+ , text >=0.11.3 && <0.12+ , containers >=0.5.0 && <0.6,+ lifted-base >=0.2.1 && <0.3+ exposed-modules:+ Yesod.MangoPay,+ Yesod.MangoPay.Util+++executable yesod-mangopay+ if flag(library-only)+ Buildable: False++ main-is: main.hs+ hs-source-dirs: app+ other-modules:+ Application,+ Foundation,+ Import,+ Settings,+ Settings.StaticFiles,+ Settings.Development,+ Handler.Home,+ Handler.User,+ Base.Util,+ Handler.Doc,+ Handler.Wallet,+ Handler.Card,+ Handler.Account,+ Handler.Transaction+ if flag(dev)+ cpp-options: -DDEVELOPMENT+ ghc-options: -Wall -O0+ else+ ghc-options: -Wall -O2+ extensions: TemplateHaskell+ QuasiQuotes+ OverloadedStrings+ NoImplicitPrelude+ CPP+ MultiParamTypeClasses+ TypeFamilies+ GADTs+ GeneralizedNewtypeDeriving+ FlexibleContexts+ EmptyDataDecls+ NoMonomorphismRestriction+ DeriveDataTypeable+ build-depends:+ yesod-mangopay+ , mangopay == 0.1+ , base >= 4 && < 5+ , yesod >= 1.2.5 && < 1.3+ , yesod-core >= 1.2 && < 1.3+ , yesod-auth >= 1.2.6 && < 1.3+ , yesod-static >= 1.2 && < 1.3+ , yesod-form >= 1.3.0 && < 1.4+ , yesod-persistent+ , bytestring >= 0.9 && < 0.11+ , text >= 0.11 && < 2.0+ , persistent >= 1.3 && < 1.4+ , persistent-postgresql >= 1.3 && < 1.4+ , persistent-template >= 1.3 && < 1.4+ , template-haskell+ , shakespeare+ , hamlet >= 1.1 && < 1.2+ , shakespeare-css >= 1.0 && < 1.1+ , shakespeare-js >= 1.2 && < 1.3+ , shakespeare-text >= 1.0 && < 1.1+ , hjsmin >= 0.1 && < 0.2+ , monad-control >= 0.3 && < 0.4+ , wai-extra >= 2.0 && < 2.1+ , yaml >= 0.8 && < 0.9+ , http-conduit >= 2.0 && < 2.1+ , directory >= 1.1 && < 1.3+ , warp >= 2.0 && < 2.1+ , data-default+ , aeson >= 0.6 && < 0.8+ , conduit >= 1.0 && < 2.0+ , monad-logger >= 0.3 && < 0.4+ , fast-logger >= 2.1.4 && < 2.2+ , wai-logger >= 2.1 && < 2.2+ , time >=1.4.0 && <1.5+ , containers >=0.5.0 && <0.6+ , wai >=2.0 && <2.1+ ghc-options: -threaded -O2