create endpoint for credit recharge

This commit is contained in:
nek0 2019-11-01 12:22:28 +01:00
parent a98fc96df4
commit 280cddbb70
9 changed files with 133 additions and 17 deletions

View file

@ -28,6 +28,7 @@ executable matebeamter
, Types.Page , Types.Page
, Types.Reader , Types.Reader
, Types.Views , Types.Views
, Types.User
, Types.Orphans , Types.Orphans
, Types.Configuration , Types.Configuration
, Control , Control

View file

@ -38,6 +38,11 @@ type UserAPI =
:> ReqBody '[FormUrlEncoded] [MT.PurchaseDetail] :> ReqBody '[FormUrlEncoded] [MT.PurchaseDetail]
:> QueryParam "force" Bool :> QueryParam "force" Bool
:> Post '[HTML] UserSelectPage :> Post '[HTML] UserSelectPage
:<|> "user" :> Capture "id" Int :> "recharge"
:> Get '[HTML] UserRechargePage
:<|> "user" :> Capture "id" Int :> "recharge"
:> ReqBody '[FormUrlEncoded] UserRecharge
:> Post '[HTML] UserOverviewPage
:<|> "user" :> Capture "id" Int :> "manage" :> Get '[HTML] UserManagePage :<|> "user" :> Capture "id" Int :> "manage" :> Get '[HTML] UserManagePage
:<|> "user" :> Capture "id" Int :> "manage" :<|> "user" :> Capture "id" Int :> "manage"
:> ReqBody '[FormUrlEncoded] MT.UserDetailsSubmit :> ReqBody '[FormUrlEncoded] MT.UserDetailsSubmit
@ -70,6 +75,8 @@ type UserAPI =
userOverviewLink :<|> userOverviewLink :<|>
buyLink :<|> buyLink :<|>
purchaseCompleteLink :<|> purchaseCompleteLink :<|>
userRechargeLink :<|>
userPostRechargeLink :<|>
userManageLink :<|> userManageLink :<|>
userManageDetailsSubmitLink :<|> userManageDetailsSubmitLink :<|>
userManageAuthCreateLink :<|> userManageAuthCreateLink :<|>

View file

@ -13,7 +13,7 @@ import Data.String (fromString)
import qualified Data.Text as T import qualified Data.Text as T
import Data.Text.I18n import Data.Text.I18n
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe, isJust)
import Data.Either.Combinators (leftToMaybe) import Data.Either.Combinators (leftToMaybe)
import Control.Monad (void) import Control.Monad (void)
@ -133,14 +133,52 @@ userOverviewControl mcookie uid mRefine = do
{ errBody = fromString (show uerr) <> " " <> fromString (show perr) { errBody = fromString (show uerr) <> " " <> fromString (show perr)
} }
userRechargeControl
:: Maybe T.Text
-> Int
-> UserHandler UserRechargePage
userRechargeControl mcookie uid = do
l10n <- asks rsL10n
let loc = localeFromCookie mcookie
return $ userRechargePage l10n loc mcookie uid
userPostRechargeControl
:: Maybe T.Text
-> Int
-> UserRecharge
-> UserHandler UserOverviewPage
userPostRechargeControl mcookie uid (UserRecharge amount) = do
(ReadState l10n backend _) <- ask
let loc = localeFromCookie mcookie
(token, mauthuser) = parseTokenAndUser mcookie
eresult <- liftIO $ runClientM
(userRecharge
(mkAuthenticatedRequest token authenticateReq)
(MT.UserRecharge $ floor $ amount * 100)
)
backend
if isJust mauthuser
then
case eresult of
Right _ -> throwError $
(addMessage $ translate l10n loc "Recharge Successful") $
redirect303 (userOverviewLink uid Nothing)
Left err -> throwError $
(addMessage $ translate l10n loc ("An error occured. " <>
fromString (show err))) $
redirect303 (userRechargeLink uid)
else
redirectOverAuth (Just uid) (Just (userRechargeLink uid)) Nothing
where
translate l10n locale = localize l10n locale . gettext
userManageControl userManageControl
:: Maybe T.Text :: Maybe T.Text
-> Int -> Int
-> UserHandler UserManagePage -> UserHandler UserManagePage
userManageControl mcookie uid = do userManageControl mcookie uid = do
(ReadState l10n backend _) <- ask (ReadState l10n backend _) <- ask
let loc = Locale let loc = localeFromCookie mcookie
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
(token, mAuthUser) = parseTokenAndUser mcookie (token, mAuthUser) = parseTokenAndUser mcookie
eUserDetails <- liftIO $ eUserDetails <- liftIO $
runClientM runClientM

View file

@ -72,6 +72,8 @@ userApp initState = serveWithContext userApi EmptyContext $
:<|> userOverviewControl mcookie :<|> userOverviewControl mcookie
:<|> buyControl mcookie :<|> buyControl mcookie
:<|> purchaseControl mcookie :<|> purchaseControl mcookie
:<|> userRechargeControl mcookie
:<|> userPostRechargeControl mcookie
:<|> userManageControl mcookie :<|> userManageControl mcookie
:<|> userManageDetailsSubmitControl mcookie :<|> userManageDetailsSubmitControl mcookie
:<|> userManageAuthCreateControl mcookie :<|> userManageAuthCreateControl mcookie

View file

@ -6,5 +6,6 @@ import Types.Auth as T
import Types.Page as T import Types.Page as T
import Types.Reader as T import Types.Reader as T
import Types.Views as T import Types.Views as T
import Types.User as T
import Types.Orphans as T import Types.Orphans as T
import Types.Configuration as T import Types.Configuration as T

18
src/Types/User.hs Normal file
View file

@ -0,0 +1,18 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Types.User where
import Servant.API
import Servant.HTML.Blaze
import Web.Internal.FormUrlEncoded
import GHC.Generics
newtype UserRecharge = UserRecharge
{ userRechargeAmount :: Float
}
deriving (Show, Generic)
instance MimeUnrender HTML UserRecharge
instance FromForm UserRecharge

View file

@ -8,6 +8,8 @@ type UserNewPage = H.Html
type UserOverviewPage = H.Html type UserOverviewPage = H.Html
type UserRechargePage = H.Html
type UserManagePage = H.Html type UserManagePage = H.Html
type ProductListPage = H.Html type ProductListPage = H.Html

View file

@ -15,6 +15,8 @@ import qualified Text.Blaze.Html5.Attributes as HA
import qualified Data.Text as T import qualified Data.Text as T
import Data.Text.Lazy.Encoding import Data.Text.Lazy.Encoding
import Data.Text.I18n
import Data.ByteString.Builder import Data.ByteString.Builder
import Data.List (intercalate) import Data.List (intercalate)
@ -109,6 +111,12 @@ parseTokenAndUser mcookie =
(lookup "x-auth-user" =<< mParsedCookie) (lookup "x-auth-user" =<< mParsedCookie)
mParsedCookie = fmap parseCookieText mcookie mParsedCookie = fmap parseCookieText mcookie
localeFromCookie
:: Maybe T.Text
-> Locale
localeFromCookie mcookie = Locale
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
handleErrors handleErrors
:: (Traversable t, Show (t (Maybe ClientError))) :: (Traversable t, Show (t (Maybe ClientError)))
=> Maybe Int => Maybe Int

View file

@ -84,15 +84,21 @@ userOverviewPage l10n locale method ud pos mcookie =
MT.PrimaryPass -> MT.PrimaryPass ->
userSettingsPointer l10n locale (MT.userDetailsId ud) userSettingsPointer l10n locale (MT.userDetailsId ud)
MT.SecondaryPass -> MT.SecondaryPass ->
H.form buyForm
H.! HA.method "post"
H.! HA.action ("/" <> (fromString $ show $ linkURI $
buyLink (MT.userDetailsId ud) Nothing)
)
H.! HA.enctype "application/x-www-form-urlencoded" $
buyProductsForm l10n locale pos
MT.ChallengeResponse -> do MT.ChallengeResponse -> do
userSettingsPointer l10n locale (MT.userDetailsId ud) userSettingsPointer l10n locale (MT.userDetailsId ud)
buyForm
where
translate = localize l10n locale . gettext
buyForm = do
H.div $ H.form $
H.button
H.! HA.type_ "submit"
H.! HA.formmethod "get"
H.! HA.formaction ("/" <>
fromString
(show $ linkURI $ userRechargeLink $ MT.userDetailsId ud))
$ H.toHtml $ translate "Recharge Credit"
H.form H.form
H.! HA.method "post" H.! HA.method "post"
H.! HA.action ("/" <> (fromString $ show $ linkURI $ H.! HA.action ("/" <> (fromString $ show $ linkURI $
@ -100,8 +106,6 @@ userOverviewPage l10n locale method ud pos mcookie =
) )
H.! HA.enctype "application/x-www-form-urlencoded" $ H.! HA.enctype "application/x-www-form-urlencoded" $
buyProductsForm l10n locale pos buyProductsForm l10n locale pos
where
translate = localize l10n locale . gettext
userSettingsPointer userSettingsPointer
:: L10n :: L10n
@ -179,6 +183,41 @@ userNewPage l10n locale mcookie = scaffold l10n locale mcookie (initPage $
where where
translate = localize l10n locale . gettext translate = localize l10n locale . gettext
userRechargePage
:: L10n
-> Locale
-> Maybe T.Text
-> Int
-> UserRechargePage
userRechargePage l10n locale mcookie uid =
scaffold l10n locale mcookie (initPage $
translate "Matebeamter" <>
" - " <>
translate "Recharge account"
) $ H.p $ H.form
H.! HA.method "post"
H.! HA.action ("/" <>
fromString (show $ linkURI $ userPostRechargeLink uid))
H.! HA.enctype "aplication/x-www-form-urlencoded" $ do
H.div H.! HA.class_ "form-group required" $ do
H.label H.! HA.for "recharge-amount" $ H.toHtml $ translate "Amount"
H.input
H.! HA.id "recharde-amount"
H.! HA.class_ "form-control"
H.! HA.name "userRechargeAmount"
H.! HA.type_ "number"
H.! HA.min "0"
H.! HA.step "0.01"
H.! HA.value "0"
-- H.toHtml ("€" :: T.Text) -- TODO: ask for currency symbol
H.div H.! HA.class_ "form-group optional" $
H.button
H.! HA.class_ "btn btn-default"
H.! HA.type_ "submit"
$ H.toHtml $ translate "Recharge"
where
translate = localize l10n locale . gettext
userManagePage userManagePage
:: L10n :: L10n
-> Locale -> Locale