From 9cbc638a6222b9a068697a67f322844d8f5127c9 Mon Sep 17 00:00:00 2001 From: nek0 Date: Sun, 15 Dec 2019 00:05:12 +0100 Subject: [PATCH] refill kinda does things --- src/API.hs | 7 +++ src/Control/Buy.hs | 8 +++- src/Control/Journal.hs | 27 ++++++------ src/Control/Product.hs | 20 +++++++++ src/Main.hs | 2 + src/Types/Orphans.hs | 21 +++++++++ src/Types/Views.hs | 2 + src/Util.hs | 16 +++++++ src/View/Product.hs | 97 ++++++++++++++++++++++++++++++++++++++++++ 9 files changed, 186 insertions(+), 14 deletions(-) diff --git a/src/API.hs b/src/API.hs index 0dda5e1..edb4432 100644 --- a/src/API.hs +++ b/src/API.hs @@ -72,6 +72,11 @@ type UserAPI = :> Post '[HTML] JournalPage :<|> "product" :> "list" :> Get '[HTML] ProductPriceListPage + :<|> "product" :> "refill" + :> Get '[HTML] ProductRefillPage + :<|> "product" :> "refill" + :> ReqBody '[FormUrlEncoded] [MT.AmountRefill] + :> Post '[HTML] ProductRefillPage :<|> "auth" :> QueryParam "destination" T.Text :> Get '[HTML] @@ -105,6 +110,8 @@ type UserAPI = journalGetCheckLink :<|> journalPostCheckLink :<|> productGetPriceListLink :<|> + productGetRefillLink :<|> + productPostRefillLink :<|> authLink :<|> authPostLink :<|> authLogoutLink diff --git a/src/Control/Buy.hs b/src/Control/Buy.hs index 205a722..924c950 100644 --- a/src/Control/Buy.hs +++ b/src/Control/Buy.hs @@ -71,6 +71,10 @@ buyControl mcookie uid pds forceBuy = 0 ziptup return (buyConfirmPage l10n loc uid ziptup total forceBuy mcookie) + Left err -> + throwError $ + addMessage (fromString $ show err) $ + redirect303 userSelectLink else throwError (redirect303 $ userOverviewLink uid Nothing) @@ -91,7 +95,7 @@ purchaseControl mcookie uid pds forceBuy = do erefres <- if forceBuy then do let refills = map - (\(MT.PurchaseDetail pid amount) -> MT.AmountRefill pid amount) + (\(MT.PurchaseDetail pid amount) -> MT.AmountRefill pid amount 0) pds liftIO $ runClientM (productStockRefill @@ -256,6 +260,8 @@ cashBuyPurchaseControl mcookie {-forceBuy-} pds = do throwError $ err500 { errBody = fromString (show err) } + Left err -> + handleClientErr err (Just userSelectLink) else throwError $ addMessage (translate l10n loc "Please choose your product(s)") diff --git a/src/Control/Journal.hs b/src/Control/Journal.hs index 4c1fc8e..2afe22b 100644 --- a/src/Control/Journal.hs +++ b/src/Control/Journal.hs @@ -93,19 +93,20 @@ journalPostCheckControl mcookie (CashCheck floatAmount) = do addMessage (translate l10n loc "Cash check received and processed") $ redirect303 (journalLink Nothing) Left err -> - case err of - FailureResponse _ resp -> - if statusCode (responseStatusCode resp) == 401 - then - redirectOverAuth Nothing (Just journalGetCheckLink) Nothing - else - throwError $ - addMessage (fromString $ show err) $ - redirect303 userSelectLink - otherErr -> - throwError $ - addMessage (fromString $ show otherErr) $ - redirect303 userSelectLink + handleClientErr err (Just journalGetCheckLink) + -- case err of + -- FailureResponse _ resp -> + -- if statusCode (responseStatusCode resp) == 401 + -- then + -- redirectOverAuth Nothing (Just journalGetCheckLink) Nothing + -- else + -- throwError $ + -- addMessage (fromString $ show err) $ + -- redirect303 userSelectLink + -- otherErr -> + -- throwError $ + -- addMessage (fromString $ show otherErr) $ + -- redirect303 userSelectLink Nothing -> redirectOverAuth Nothing (Just $ journalLink Nothing) Nothing where diff --git a/src/Control/Product.hs b/src/Control/Product.hs index f1f59e7..09178c3 100644 --- a/src/Control/Product.hs +++ b/src/Control/Product.hs @@ -42,3 +42,23 @@ productGetPriceList mcookie = do throwError $ addMessage (fromString $ show err) $ redirect303 userSelectLink + +productGetRefill + :: Maybe T.Text + -> UserHandler ProductRefillPage +productGetRefill mcookie = do + (token, muser, loc, l10n, backend) <- controlInit mcookie + case muser of + Just _ -> do + elist <- liftIO $ runClientM + (productShortList (Just MT.AllProducts)) + backend + case elist of + Right list -> do + return $ productRefillPage l10n loc mcookie list + Left err -> + throwError $ + addMessage (fromString $ show err) $ + redirect303 userSelectLink + Nothing -> + redirectOverAuth Nothing (Just productGetRefillLink) Nothing diff --git a/src/Main.hs b/src/Main.hs index 4ff7b9c..b595e93 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -86,6 +86,8 @@ userApp initState = serveWithContext userApi EmptyContext $ :<|> journalGetCheckControl mcookie :<|> journalPostCheckControl mcookie :<|> productGetPriceList mcookie + :<|> productGetRefill mcookie + :<|> (\_ _ -> error "not yet implemented") mcookie :<|> authControl mcookie :<|> authPostControl mcookie :<|> authLogoutControl mcookie diff --git a/src/Types/Orphans.hs b/src/Types/Orphans.hs index 830dfd5..866fd97 100644 --- a/src/Types/Orphans.hs +++ b/src/Types/Orphans.hs @@ -39,3 +39,24 @@ instance FromForm [MT.PurchaseDetail] where res = map digestForm kpids in Right res + +instance MimeUnrender HTML [MT.AmountRefill] +instance FromForm [MT.AmountRefill] where + fromForm form = + let kvs = toListStable form + ks = map fst kvs + kpids = filter ("amountRefillproductId" `T.isPrefixOf`) ks + prods = filter ((`notElem` kpids) . fst) kvs + stripPid = snd . T.breakOnEnd "-" + digestForm key = + let pid = read (T.unpack $ stripPid key) + amountSingles = read + (T.unpack . fromJust $ + lookup ("amountRefillAmountSingles-" <> stripPid key) prods) + amountCrates = read + (T.unpack . fromJust $ + lookup ("amountRefillAmountCrates-" <> stripPid key) prods) + in MT.AmountRefill pid amountSingles amountCrates + res = map digestForm kpids + in + Right res diff --git a/src/Types/Views.hs b/src/Types/Views.hs index b8f1d88..9ad1916 100644 --- a/src/Types/Views.hs +++ b/src/Types/Views.hs @@ -27,3 +27,5 @@ type CashBuyOverviewPage = H.Html type CashBuyConfirmPage = H.Html type ProductPriceListPage = H.Html + +type ProductRefillPage = H.Html diff --git a/src/Util.hs b/src/Util.hs index 7b3483b..de0814b 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -147,6 +147,7 @@ redirectOverAuth -> UserHandler UserOverviewPage redirectOverAuth muid mLink mRefine = do let redirectHeaders = errHeaders $ + -- redirect303 authLink redirect303 (authLink (Just $ "/" <> fromString (show $ linkURI (case (mLink, muid) of (Just link, _) -> link @@ -195,3 +196,18 @@ controlInit mcookie = do l10n <- asks rsL10n backend <- asks rsBackend return (token, muser, loc, l10n, backend) + +handleClientErr err authTargetLink = + case err of + FailureResponse _ resp -> + if statusCode (responseStatusCode resp) == 401 + then + redirectOverAuth Nothing authTargetLink Nothing + else + throwError $ + addMessage (fromString $ show err) $ + redirect303 userSelectLink + othererr -> + throwError $ + addMessage (fromString $ show othererr) $ + redirect303 userSelectLink diff --git a/src/View/Product.hs b/src/View/Product.hs index e8c4559..b2b5ba3 100644 --- a/src/View/Product.hs +++ b/src/View/Product.hs @@ -2,11 +2,15 @@ {-# LANGUAGE PackageImports #-} module View.Product where +import Servant.Links + import Data.String (fromString) import qualified Data.Text as T import Data.Text.I18n +import Data.Maybe (fromJust, isJust) + import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5.Attributes as HA @@ -53,3 +57,96 @@ productPriceListPage l10n loc mcookie list = list where translate = localize l10n loc . gettext + +productRefillPage + :: L10n + -> Locale + -> Maybe T.Text + -> [MT.ProductShortOverview] + -> ProductRefillPage +productRefillPage l10n loc mcookie prodList = + scaffold l10n loc mcookie (initPage $ + translate "Matebeamter" <> + " - " <> + translate "Refill stock" + ) $ do + H.form + H.! HA.method "post" + H.! HA.action ("/" <> fromString + (show $ linkURI productPostRefillLink) + ) + H.! HA.enctype "application/x-www-form-urlencoded" + $ do + mapM_ + (\(MT.ProductShortOverview pid ident price amount ml maid) -> do + H.div + H.! HA.class_ "form-group optional" + H.!? + ( isJust maid + , productBgStyle (fromString $ show $ fromJust maid) + ) + $ do + H.label + H.! HA.for ( + "amount-refill-product-id-" <> + fromString (show pid) + ) + $ H.toHtml ident + H.input + H.! HA.id ( + "amount-refill-product-id-" <> + fromString (show pid) + ) + H.! HA.class_ "form-control product-select" + H.! HA.name ( + "amountRefillProductId-" <> + fromString (show pid) + ) + H.! HA.type_ "checkbox" + H.! HA.value "true" + H.div + H.! HA.class_ "form-group optional" + $ do + H.label + H.! HA.for ( + "amount-refill-amount-singeles-" <> + fromString (show pid) + ) + $ H.toHtml (translate "Amount") + H.input + H.! HA.id ( + "amount-refill-amount-singles-" <> + fromString (show pid) + ) + H.! HA.class_ "form-control product-amount" + H.! HA.name ( + "amountRefillAmountSingles- " <> + fromString (show pid) + ) + H.! HA.type_ "number" + H.! HA.min "0" + H.! HA.step "1" + H.! HA.value "0" + H.input + H.! HA.id ( + "amount-refill-amount-crates-" <> + fromString (show pid) + ) + H.! HA.class_ "form-control product-amount" + H.! HA.name ( + "amountRefillAmountCrates- " <> + fromString (show pid) + ) + H.! HA.type_ "number" + H.! HA.min "0" + H.! HA.step "1" + H.! HA.value "0" + ) + prodList + H.div H.! HA.class_ "form-group optional" $ + H.button + H.! HA.class_ "btn btn-default" + H.! HA.type_ "submit" + $ H.toHtml $ translate "Submit" + where + translate = localize l10n loc . gettext