From 96304fe665571c8528b8fe24f78b011c134552b9 Mon Sep 17 00:00:00 2001 From: nek0 Date: Thu, 24 Oct 2019 18:05:22 +0200 Subject: [PATCH] one trainride later --- src/API.hs | 2 + src/Control/Auth.hs | 2 +- src/Control/Buy.hs | 69 ++++++++++-------- src/Control/User.hs | 9 +-- src/Util.hs | 24 +++++++ src/View/Auth.hs | 4 +- src/View/Buy.hs | 168 ++++++++++++++++++++++++------------------- src/View/Scaffold.hs | 20 ++++-- src/View/User.hs | 118 ++++++++++++++++-------------- 9 files changed, 247 insertions(+), 169 deletions(-) diff --git a/src/API.hs b/src/API.hs index 336cdaf..09e9ffb 100644 --- a/src/API.hs +++ b/src/API.hs @@ -32,9 +32,11 @@ type UserAPI = :> Get '[HTML] UserOverviewPage :<|> "user" :> Capture "id" Int :> "buy" :> ReqBody '[FormUrlEncoded] [MT.PurchaseDetail] + :> QueryParam "force" Bool :> Post '[HTML] BuyConfirmPage :<|> "user" :> Capture "id" Int :> "purchasecomplete" :> ReqBody '[FormUrlEncoded] [MT.PurchaseDetail] + :> QueryParam "force" Bool :> Post '[HTML] UserSelectPage :<|> "user" :> Capture "id" Int :> "manage" :> Get '[HTML] UserManagePage :<|> "user" :> Capture "id" Int :> "manage" diff --git a/src/Control/Auth.hs b/src/Control/Auth.hs index c68f46b..a46616e 100644 --- a/src/Control/Auth.hs +++ b/src/Control/Auth.hs @@ -110,7 +110,7 @@ authControl mcookie mDestination = do return $ addHeader (head ticketHeaders) $ addHeader (ticketHeaders !! 1) $ - authPage l10n loc mDestination + authPage l10n loc mDestination mcookie authPostControl :: Maybe T.Text diff --git a/src/Control/Buy.hs b/src/Control/Buy.hs index f3643ee..3aecaae 100644 --- a/src/Control/Buy.hs +++ b/src/Control/Buy.hs @@ -40,8 +40,9 @@ buyControl :: Maybe T.Text -> Int -> [MT.PurchaseDetail] + -> Maybe Bool -> UserHandler BuyConfirmPage -buyControl mcookie uid pds = +buyControl mcookie uid pds forceBuy = if not (null pds) then do (ReadState l10n backend _) <- ask @@ -69,7 +70,7 @@ buyControl mcookie uid pds = ) 0 ziptup - return (buyConfirmPage l10n loc uid ziptup total) + return (buyConfirmPage l10n loc uid ziptup total forceBuy mcookie) else throwError (redirect303 $ userOverviewLink uid Nothing) @@ -77,8 +78,12 @@ purchaseControl :: Maybe T.Text -> Int -> [MT.PurchaseDetail] + -> Maybe Bool -> UserHandler UserSelectPage -purchaseControl mcookie uid pds = +purchaseControl mcookie uid pds forceBuy = do + l10n <- asks rsL10n + let loc = Locale + (fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie) if not (null pds) then do backend <- asks rsBackend @@ -92,46 +97,48 @@ purchaseControl mcookie uid pds = case eresult of Right result -> case result of (MT.PurchaseResult MT.PurchaseOK []) -> - logoutAndRedirectHome backend token + logoutAndRedirectHome + (translate l10n loc "Purchase successful") + backend + token (MT.PurchaseResult MT.PurchaseDebtful []) -> - logoutAndRedirectHome backend token + logoutAndRedirectHome + (translate l10n loc "Purchase successful") + backend + token (MT.PurchaseResult (MT.PayAmount price) []) -> - throwError $ err500 - { errBody = - "No messaging system implemented. " - <> "Purchase was processed, though. " - <> "Please pay " <> (fromString $ T.unpack $ formatMoney price) - <> " in cash." - } + logoutAndRedirectHome + (translate l10n loc "Please Pay" <> ": " <> formatMoney price) + backend + token (MT.PurchaseResult (MT.PayAmount price) miss) -> - throwError $ err500 - { errBody = - "No messaging system implemented. " - <> "Purchase was processed, though. " - <> "Please pay " <> (fromString $ T.unpack $ formatMoney price) - <> " in cash. " - <> "Stock is lacking following items: " - <> fromString (show miss) - } + throwError + $ addMessage (translate l10n loc "Please Pay" <> ": " + <> formatMoney price + <> "\n" + <> translate l10n loc ("But there seems to be something missing.") + ) + $ redirect307 (buyLink uid (Just True)) (MT.PurchaseResult _ miss) -> - throwError $ err500 - { errBody = - "No messaging system implemented. " - <> "Purchase was processed, though. " - <> "Stock is lacking following items: " - <> fromString (show miss) - } + throwError + $ addMessage (translate l10n loc "Purchase partly successful.") + $ redirect307 (buyLink uid (Just True)) Left err -> throwError $ err500 { errBody = fromString (show err) } else - throwError (redirect303 $ userOverviewLink uid Nothing) + throwError + $ addMessage (translate l10n loc "Please choose your product(s)") + $ (redirect303 $ userOverviewLink uid Nothing) where - logoutAndRedirectHome backend token = do + logoutAndRedirectHome message backend token = do void $ liftIO $ runClientM (authLogout (mkAuthenticatedRequest token authenticateReq) ) backend - throwError $ redirect303 userSelectLink + throwError + $ addMessage message + $ redirect303 userSelectLink + translate l10n locale = localize l10n locale . gettext diff --git a/src/Control/User.hs b/src/Control/User.hs index 862a158..7b80ba9 100644 --- a/src/Control/User.hs +++ b/src/Control/User.hs @@ -46,7 +46,7 @@ userSelectControl mcookie = do backend case euser of Right uss -> - return $ userSelectPage l10n loc uss + return $ userSelectPage l10n loc uss mcookie Left err -> error $ show err @@ -55,7 +55,7 @@ userNewControl mcookie = do (ReadState l10n _ _) <- ask let loc = Locale (fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie) - return $ userNewPage l10n loc + return $ userNewPage l10n loc mcookie userNewPostControl :: Maybe T.Text @@ -102,7 +102,8 @@ userOverviewControl mcookie uid mRefine = do Just method -> if fmap read mAuthUser == Just uid then - return $ userOverviewPage l10n loc (toEnum $ read method) ud prods + return $ + userOverviewPage l10n loc (toEnum $ read method) ud prods mcookie else redirectOverAuth (Just uid) @@ -153,7 +154,7 @@ userManageControl mcookie uid = do (Right userDetails, Right authOverviews) -> if Just uid == fmap read mAuthUser then - return $ userManagePage l10n loc userDetails authOverviews + return $ userManagePage l10n loc userDetails authOverviews mcookie else redirectOverAuth (Just uid) (Just $ userManageLink uid) Nothing err -> handleErrors diff --git a/src/Util.hs b/src/Util.hs index 48bc32c..6f2b179 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -66,6 +66,30 @@ redirect303 link = ] } +redirect307 + :: Link + -> ServerError +redirect307 link = + err307 + { errHeaders = + [ ("Location", "/" <> fromString (show $ linkURI link)) + ] + } + +addMessage + :: T.Text + -> ServerError + -> ServerError +addMessage message err = + err + { errHeaders = + ( "Set-Cookie" + , "message=" <> + fromString (T.unpack message) <> + "; Path=/; Max-Age=5" + ) : errHeaders err + } + parseCookieText :: T.Text -> [(T.Text, T.Text)] diff --git a/src/View/Auth.hs b/src/View/Auth.hs index 8b7667c..2fbce7a 100644 --- a/src/View/Auth.hs +++ b/src/View/Auth.hs @@ -27,10 +27,12 @@ authPage :: L10n -> Locale -> Maybe T.Text + -> Maybe T.Text -> AuthPage -authPage l10n locale mDestination = scaffold +authPage l10n locale mDestination mcookie = scaffold l10n locale + mcookie (initPage $ translate "Matebeamter" <> " - " <> diff --git a/src/View/Buy.hs b/src/View/Buy.hs index 091cec4..e000d47 100644 --- a/src/View/Buy.hs +++ b/src/View/Buy.hs @@ -13,7 +13,9 @@ import Data.String (fromString) import Data.Text.I18n -import Data.Maybe (isJust, fromJust) +import Data.Maybe (isJust, fromJust, fromMaybe) + +import Control.Monad (when) -- imports from mateamt @@ -32,80 +34,100 @@ buyConfirmPage -> Int -> [(MT.PurchaseDetail, MT.ProductShortOverview)] -> Int + -> Maybe Bool + -> Maybe T.Text -> H.Html -buyConfirmPage l10n locale uid ziptups total = scaffold l10n locale (initPage $ - translate "Matebeamter" <> - " - " <> - translate "Home" - ) $ do - H.p $ H.toHtml $ translate "You are about to buy the following items:" - H.form - H.! HA.method "post" - H.! HA.action - ("/" <> fromString (show $ linkURI $ purchaseCompleteLink uid)) - H.! HA.enctype "application/x-www-form-urlencoded" - $ do - mapM_ - (\( MT.PurchaseDetail pdid amount - , MT.ProductShortOverview pid ident price _ _ mava) -> - H.div H.! HA.class_ "form-group required" $ do - H.input - H.! HA.id ("product-select-" <> fromString (show pid)) - H.! HA.class_ "form-control" - H.! HA.name ("productSelect-" <> fromString (show pid)) - H.! HA.type_ "hidden" - H.! HA.value "true" - H.label - H.! HA.for ("product-amount-" <> fromString (show pid)) - $ do - H.img - H.!? - ( isJust mava - , HA.src - (fromString $ show $ fromJust mava) -- TODO: ask for avatar - ) - H.toHtml ident - H.input - H.! HA.id ("product-amount-" <> (fromString (show pid))) - H.! HA.class_ "form-control" - H.! HA.name ("productAmount-" <> fromString (show pid)) - H.! HA.type_ "number" - H.! HA.min "0" - H.! HA.step "1" - H.! HA.value (fromString $ show amount) - -- H.! HA.disabled "" - H.label - H.! HA.for ("product-total-" <> fromString (show pid)) - $ H.toHtml $ - " @ " <> formatMoney price <> "€" -- TODO: ask for currency symbol - H.input - H.! HA.id ("product-total-" <> (fromString (show pid))) - H.! HA.class_ "form-control" - H.! HA.name ("productTotal-" <> fromString (show pid)) - H.! HA.type_ "text" - H.! HA.value - (fromString $ T.unpack $ formatMoney $ amount * price) - H.! HA.disabled "" - H.toHtml ("€" :: T.Text) -- TODO: ask for currency symbol +buyConfirmPage l10n locale uid ziptups total forceBuy mcookie = + scaffold l10n locale mcookie (initPage $ + translate "Matebeamter" <> + " - " <> + translate "Home" + ) $ do + if not (fromMaybe False forceBuy) + then + H.p $ H.toHtml $ translate "You are about to buy the following items:" + else + H.p $ H.toHtml $ translate "The following Items seem out of stock:" + H.form + H.! HA.method "post" + H.! HA.action + ("/" <> fromString + (show $ linkURI $ purchaseCompleteLink uid forceBuy) ) - ziptups - H.div H.! HA.class_ "form-group required" $ do - H.label - H.! HA.for "total-price" - $ H.toHtml ("Total price: " :: T.Text) - H.input - H.! HA.id "total-price" - H.! HA.class_ "form-control" - H.! HA.name "totalPrice" - H.! HA.type_ "text" - H.! HA.value (fromString $ T.unpack $ formatMoney total) - H.! HA.disabled "" - 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 "Buy" + H.! HA.enctype "application/x-www-form-urlencoded" + $ do + mapM_ + (\( MT.PurchaseDetail pdid amount + , MT.ProductShortOverview pid ident price _ _ mava) -> + H.div H.! HA.class_ "form-group required" $ do + H.input + H.! HA.id ("product-select-" <> fromString (show pid)) + H.! HA.class_ "form-control" + H.! HA.name ("productSelect-" <> fromString (show pid)) + H.! HA.type_ "hidden" + H.! HA.value "true" + H.label + H.! HA.for ("product-amount-" <> fromString (show pid)) + $ do + H.img + H.!? + ( isJust mava + , HA.src + (fromString $ show $ fromJust mava) -- TODO: ask for avatar + ) + H.toHtml ident + H.input + H.! HA.id ("product-amount-" <> (fromString (show pid))) + H.! HA.class_ "form-control" + H.! HA.name ("productAmount-" <> fromString (show pid)) + H.! HA.type_ "number" + H.! HA.min "0" + H.! HA.step "1" + H.! HA.value (fromString $ show amount) + -- H.! HA.disabled "" + H.label + H.! HA.for ("product-total-" <> fromString (show pid)) + $ H.toHtml $ + " @ " <> formatMoney price <> "€" -- TODO: ask for currency symbol + H.input + H.! HA.id ("product-total-" <> (fromString (show pid))) + H.! HA.class_ "form-control" + H.! HA.name ("productTotal-" <> fromString (show pid)) + H.! HA.type_ "text" + H.! HA.value + (fromString $ T.unpack $ formatMoney $ amount * price) + H.! HA.disabled "" + H.toHtml ("€" :: T.Text) -- TODO: ask for currency symbol + ) + ziptups + H.div H.! HA.class_ "form-group required" $ do + H.label + H.! HA.for "total-price" + $ H.toHtml ("Total price: " :: T.Text) + H.input + H.! HA.id "total-price" + H.! HA.class_ "form-control" + H.! HA.name "totalPrice" + H.! HA.type_ "text" + H.! HA.value (fromString $ T.unpack $ formatMoney total) + H.! HA.disabled "" + 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 $ if (fromMaybe False forceBuy) + then translate "Buy anyway" + else translate "Buy" + when (fromMaybe False forceBuy) $ + H.button + H.! HA.formnovalidate "formnovalidate" + H.! HA.formmethod "get" + H.! HA.formaction + ("/" <> fromString + (show $ linkURI $ userOverviewLink uid Nothing) + ) + $ H.toHtml $ translate "Cancel" where translate = localize l10n locale . gettext diff --git a/src/View/Scaffold.hs b/src/View/Scaffold.hs index e0fc054..518e2ec 100644 --- a/src/View/Scaffold.hs +++ b/src/View/Scaffold.hs @@ -4,7 +4,7 @@ module View.Scaffold where import Servant.Links import qualified Text.Blaze.Html5 as H -import qualified Text.Blaze.Html5.Attributes as H +import qualified Text.Blaze.Html5.Attributes as HA import qualified Data.Text as T @@ -12,21 +12,33 @@ import Data.String (fromString) import Data.Text.I18n +import Data.Maybe (fromJust, isJust) + +import Control.Monad (when) + -- internal imports import Types.Page import API +import Util scaffold :: L10n -> Locale + -> Maybe T.Text -> Page H.Html T.Text -> H.Html -> H.Html -scaffold l10n locale page content = template page $ do +scaffold l10n locale mcookie page content = template page $ do H.header $ H.nav $ H.ul $ - H.li $ H.a H.! H.href ("/" <> fromString (show $ linkURI userSelectLink)) $ + H.li $ H.a H.! HA.href ("/" <> fromString (show $ linkURI userSelectLink)) $ H.toHtml $ localize l10n locale $ gettext "Home" H.hr - H.div H.! H.id "main" H.! H.role "main" $ + when (isJust message) + (H.div H.! HA.id "message" H.! HA.class_ "message" $ + H.toHtml (fromJust message) + ) + H.div H.! HA.id "main" H.! HA.role "main" $ content + where + message = lookup "message" =<< fmap parseCookieText mcookie diff --git a/src/View/User.hs b/src/View/User.hs index b62db93..735fdd2 100644 --- a/src/View/User.hs +++ b/src/View/User.hs @@ -31,19 +31,21 @@ userSelectPage :: L10n -> Locale -> [MT.UserSummary] + -> Maybe T.Text -> UserSelectPage -userSelectPage l10n locale uss = scaffold l10n locale (initPage $ - translate "Matebeamter" <> - " - " <> - translate "Home" - ) $ do - mapM_ (\(MT.UserSummary uid ident _) -> - H.a H.! HA.href ("/" <> fromString (show $ linkURI $ - userOverviewLink uid Nothing)) $ - H.toHtml ident - ) uss - H.a H.! HA.href ("/" <> fromString (show $ linkURI userNewLink)) $ - H.toHtml $ translate "New user" +userSelectPage l10n locale uss mcookie = + scaffold l10n locale mcookie (initPage $ + translate "Matebeamter" <> + " - " <> + translate "Home" + ) $ do + mapM_ (\(MT.UserSummary uid ident _) -> + H.a H.! HA.href ("/" <> fromString (show $ linkURI $ + userOverviewLink uid Nothing)) $ + H.toHtml ident + ) uss + H.a H.! HA.href ("/" <> fromString (show $ linkURI userNewLink)) $ + H.toHtml $ translate "New user" where translate = localize l10n locale . gettext @@ -53,47 +55,51 @@ userOverviewPage -> MT.AuthMethod -> MT.UserDetails -> [MT.ProductShortOverview] + -> Maybe T.Text -> UserOverviewPage -userOverviewPage l10n locale method ud pos = scaffold l10n locale (initPage $ - localize l10n locale (gettext "Matebeamter") <> - " - " <> - localize l10n locale (gettext "User Menu for ") <> - MT.userDetailsIdent ud - ) $ do - H.p $ H.toHtml $ translate "Welcome back, " <> MT.userDetailsIdent ud - <> "!" - H.p H.!? (MT.userDetailsBalance ud < 0, HA.class_ "debt") $ H.toHtml $ - translate "Your current balance is" <> - ": " <> - formatMoney (MT.userDetailsBalance ud) - -- TODO: Add currency symbol - H.p $ H.form - H.! HA.method "post" - H.! HA.action ("/" <> fromString (show $ linkURI authLogoutLink)) - H.! HA.enctype "application/x-www-form-urlencoded" $ - H.div H.! HA.class_ "form-group optional" $ - H.button - H.! HA.class_ "btn btn-default" - H.! HA.type_ "submit" - $ H.toHtml $ translate "Logout" - case method of - 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))) - H.! HA.enctype "application/x-www-form-urlencoded" $ - buyProductsForm l10n locale pos - 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))) - H.! HA.enctype "application/x-www-form-urlencoded" $ - buyProductsForm l10n locale pos +userOverviewPage l10n locale method ud pos mcookie = + scaffold l10n locale mcookie (initPage $ + localize l10n locale (gettext "Matebeamter") <> + " - " <> + localize l10n locale (gettext "User Menu for ") <> + MT.userDetailsIdent ud + ) $ do + H.p $ H.toHtml $ translate "Welcome back, " <> MT.userDetailsIdent ud + <> "!" + H.p H.!? (MT.userDetailsBalance ud < 0, HA.class_ "debt") $ H.toHtml $ + translate "Your current balance is" <> + ": " <> + formatMoney (MT.userDetailsBalance ud) + -- TODO: Add currency symbol + H.p $ H.form + H.! HA.method "post" + H.! HA.action ("/" <> fromString (show $ linkURI authLogoutLink)) + H.! HA.enctype "application/x-www-form-urlencoded" $ + H.div H.! HA.class_ "form-group optional" $ + H.button + H.! HA.class_ "btn btn-default" + H.! HA.type_ "submit" + $ H.toHtml $ translate "Logout" + case method of + 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 + 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 where translate = localize l10n locale . gettext @@ -128,8 +134,9 @@ productList pos = userNewPage :: L10n -> Locale + -> Maybe T.Text -> UserNewPage -userNewPage l10n locale = scaffold l10n locale (initPage $ +userNewPage l10n locale mcookie = scaffold l10n locale mcookie (initPage $ translate "Matebeamter" <> " - " <> translate "Create new user" @@ -177,9 +184,10 @@ userManagePage -> Locale -> MT.UserDetails -> [MT.AuthOverview] + -> Maybe T.Text -> UserManagePage -userManagePage l10n locale userDetails authOverviews = - scaffold l10n locale (initPage $ +userManagePage l10n locale userDetails authOverviews mcookie = + scaffold l10n locale mcookie (initPage $ translate "Matebeamter" <> " - " <> translate "Manage user data"