From f41aab662a155e387ab1fd5115516bbbdbf93249 Mon Sep 17 00:00:00 2001 From: nek0 Date: Thu, 24 Oct 2019 07:39:46 +0200 Subject: [PATCH] process purchases without missing items --- src/API.hs | 2 +- src/Control/Buy.hs | 68 +++++++++++++++++++++++++++++++- src/Main.hs | 1 + src/View/Buy.hs | 97 ++++++++++++++++++++++++++++++++-------------- 4 files changed, 136 insertions(+), 32 deletions(-) diff --git a/src/API.hs b/src/API.hs index 900d4fc..336cdaf 100644 --- a/src/API.hs +++ b/src/API.hs @@ -33,7 +33,7 @@ type UserAPI = :<|> "user" :> Capture "id" Int :> "buy" :> ReqBody '[FormUrlEncoded] [MT.PurchaseDetail] :> Post '[HTML] BuyConfirmPage - :<|> "purchasecomplete" + :<|> "user" :> Capture "id" Int :> "purchasecomplete" :> ReqBody '[FormUrlEncoded] [MT.PurchaseDetail] :> Post '[HTML] UserSelectPage :<|> "user" :> Capture "id" Int :> "manage" :> Get '[HTML] UserManagePage diff --git a/src/Control/Buy.hs b/src/Control/Buy.hs index 699bb9c..f3643ee 100644 --- a/src/Control/Buy.hs +++ b/src/Control/Buy.hs @@ -19,7 +19,8 @@ import Data.Maybe (fromMaybe) import Data.List (sortOn) -import Control.Monad.Reader (ask) +import Control.Monad (void) +import Control.Monad.Reader (ask, asks) import Control.Monad.IO.Class (liftIO) -- imports from "mateamt" @@ -68,6 +69,69 @@ buyControl mcookie uid pds = ) 0 ziptup - return (buyConfirmPage l10n loc ziptup total) + return (buyConfirmPage l10n loc uid ziptup total) else throwError (redirect303 $ userOverviewLink uid Nothing) + +purchaseControl + :: Maybe T.Text + -> Int + -> [MT.PurchaseDetail] + -> UserHandler UserSelectPage +purchaseControl mcookie uid pds = + if not (null pds) + then do + backend <- asks rsBackend + let (token, _) = parseTokenAndUser mcookie + eresult <- liftIO $ runClientM + (buy + (mkAuthenticatedRequest token authenticateReq) + pds + ) + backend + case eresult of + Right result -> case result of + (MT.PurchaseResult MT.PurchaseOK []) -> + logoutAndRedirectHome backend token + (MT.PurchaseResult MT.PurchaseDebtful []) -> + logoutAndRedirectHome 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." + } + (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) + } + (MT.PurchaseResult _ miss) -> + throwError $ err500 + { errBody = + "No messaging system implemented. " + <> "Purchase was processed, though. " + <> "Stock is lacking following items: " + <> fromString (show miss) + } + Left err -> + throwError $ err500 + { errBody = fromString (show err) + } + else + throwError (redirect303 $ userOverviewLink uid Nothing) + where + logoutAndRedirectHome backend token = do + void $ liftIO $ runClientM + (authLogout + (mkAuthenticatedRequest token authenticateReq) + ) + backend + throwError $ redirect303 userSelectLink diff --git a/src/Main.hs b/src/Main.hs index ab832be..463e8cc 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -44,6 +44,7 @@ userApp initState = serveWithContext userApi EmptyContext $ (\mcookie -> userSelectControl mcookie :<|> userOverviewControl mcookie :<|> buyControl mcookie + :<|> purchaseControl mcookie :<|> userManageControl mcookie :<|> userManageDetailsSubmitControl mcookie :<|> userManageAuthCreateControl mcookie diff --git a/src/View/Buy.hs b/src/View/Buy.hs index 5821eec..091cec4 100644 --- a/src/View/Buy.hs +++ b/src/View/Buy.hs @@ -29,44 +29,83 @@ import API buyConfirmPage :: L10n -> Locale + -> Int -> [(MT.PurchaseDetail, MT.ProductShortOverview)] -> Int -> H.Html -buyConfirmPage l10n locale ziptups total = scaffold l10n locale (initPage $ +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.ul $ - mapM_ - (\( MT.PurchaseDetail pdid amount - , MT.ProductShortOverview pid ident price _ _ mava) -> - H.li $ do - H.img - H.!? - ( isJust mava - , HA.src (fromString $ show $ fromJust mava) -- TODO: ask for avatar - ) - H.toHtml - (fromString (show $ max 0 amount) - <> " " - <> ident - <> " @ " - <> formatMoney price - <> " " - -- <> "€" -- TODO: ask for currency symbol - <> " : " - <> formatMoney ((max 0 amount) * price) - ) - ) - ziptups - H.p $ H.toHtml $ - (translate "Total price") - <> ": " - <> formatMoney total - -- <> "€" -- TODO: ask for currency symbol 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 + ) + 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" where translate = localize l10n locale . gettext