From 280cddbb70695abfd140724d76cd40b3c2608d4c Mon Sep 17 00:00:00 2001 From: nek0 Date: Fri, 1 Nov 2019 12:22:28 +0100 Subject: [PATCH] create endpoint for credit recharge --- matebeamter.cabal | 1 + src/API.hs | 7 +++++ src/Control/User.hs | 44 +++++++++++++++++++++++++++-- src/Main.hs | 2 ++ src/Types.hs | 1 + src/Types/User.hs | 18 ++++++++++++ src/Types/Views.hs | 2 ++ src/Util.hs | 8 ++++++ src/View/User.hs | 67 +++++++++++++++++++++++++++++++++++---------- 9 files changed, 133 insertions(+), 17 deletions(-) create mode 100644 src/Types/User.hs diff --git a/matebeamter.cabal b/matebeamter.cabal index 40044b2..d317b9c 100644 --- a/matebeamter.cabal +++ b/matebeamter.cabal @@ -28,6 +28,7 @@ executable matebeamter , Types.Page , Types.Reader , Types.Views + , Types.User , Types.Orphans , Types.Configuration , Control diff --git a/src/API.hs b/src/API.hs index 09e9ffb..fbc4f27 100644 --- a/src/API.hs +++ b/src/API.hs @@ -38,6 +38,11 @@ type UserAPI = :> ReqBody '[FormUrlEncoded] [MT.PurchaseDetail] :> QueryParam "force" Bool :> 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" :> ReqBody '[FormUrlEncoded] MT.UserDetailsSubmit @@ -70,6 +75,8 @@ type UserAPI = userOverviewLink :<|> buyLink :<|> purchaseCompleteLink :<|> + userRechargeLink :<|> + userPostRechargeLink :<|> userManageLink :<|> userManageDetailsSubmitLink :<|> userManageAuthCreateLink :<|> diff --git a/src/Control/User.hs b/src/Control/User.hs index 7b80ba9..33eae08 100644 --- a/src/Control/User.hs +++ b/src/Control/User.hs @@ -13,7 +13,7 @@ import Data.String (fromString) import qualified Data.Text as T import Data.Text.I18n -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, isJust) import Data.Either.Combinators (leftToMaybe) import Control.Monad (void) @@ -133,14 +133,52 @@ userOverviewControl mcookie uid mRefine = do { 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 :: Maybe T.Text -> Int -> UserHandler UserManagePage userManageControl mcookie uid = do (ReadState l10n backend _) <- ask - let loc = Locale - (fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie) + let loc = localeFromCookie mcookie (token, mAuthUser) = parseTokenAndUser mcookie eUserDetails <- liftIO $ runClientM diff --git a/src/Main.hs b/src/Main.hs index f486023..be993ed 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -72,6 +72,8 @@ userApp initState = serveWithContext userApi EmptyContext $ :<|> userOverviewControl mcookie :<|> buyControl mcookie :<|> purchaseControl mcookie + :<|> userRechargeControl mcookie + :<|> userPostRechargeControl mcookie :<|> userManageControl mcookie :<|> userManageDetailsSubmitControl mcookie :<|> userManageAuthCreateControl mcookie diff --git a/src/Types.hs b/src/Types.hs index 4c5992c..63b738c 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -6,5 +6,6 @@ import Types.Auth as T import Types.Page as T import Types.Reader as T import Types.Views as T +import Types.User as T import Types.Orphans as T import Types.Configuration as T diff --git a/src/Types/User.hs b/src/Types/User.hs new file mode 100644 index 0000000..cf101ff --- /dev/null +++ b/src/Types/User.hs @@ -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 diff --git a/src/Types/Views.hs b/src/Types/Views.hs index 8df87c3..51a7ef8 100644 --- a/src/Types/Views.hs +++ b/src/Types/Views.hs @@ -8,6 +8,8 @@ type UserNewPage = H.Html type UserOverviewPage = H.Html +type UserRechargePage = H.Html + type UserManagePage = H.Html type ProductListPage = H.Html diff --git a/src/Util.hs b/src/Util.hs index 6f2b179..23955b5 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -15,6 +15,8 @@ import qualified Text.Blaze.Html5.Attributes as HA import qualified Data.Text as T import Data.Text.Lazy.Encoding +import Data.Text.I18n + import Data.ByteString.Builder import Data.List (intercalate) @@ -109,6 +111,12 @@ parseTokenAndUser mcookie = (lookup "x-auth-user" =<< mParsedCookie) mParsedCookie = fmap parseCookieText mcookie +localeFromCookie + :: Maybe T.Text + -> Locale +localeFromCookie mcookie = Locale + (fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie) + handleErrors :: (Traversable t, Show (t (Maybe ClientError))) => Maybe Int diff --git a/src/View/User.hs b/src/View/User.hs index 735fdd2..1e707a3 100644 --- a/src/View/User.hs +++ b/src/View/User.hs @@ -84,24 +84,28 @@ userOverviewPage l10n locale method ud pos mcookie = MT.PrimaryPass -> userSettingsPointer l10n locale (MT.userDetailsId ud) MT.SecondaryPass -> - H.form - 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 + buyForm MT.ChallengeResponse -> do userSettingsPointer l10n locale (MT.userDetailsId ud) - H.form - 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 + 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.! 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 userSettingsPointer :: L10n @@ -179,6 +183,41 @@ userNewPage l10n locale mcookie = scaffold l10n locale mcookie (initPage $ where 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 :: L10n -> Locale