yesod-mangopay-1.0: app/Handler/Wallet.hs

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))