refill kinda does things

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

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)")

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
+          handleClientErr err (Just journalGetCheckLink)
-            FailureResponse _ resp ->
+          -- case err of
-              if statusCode (responseStatusCode resp) == 401
+          --   FailureResponse _ resp ->
-              then
+          --     if statusCode (responseStatusCode resp) == 401
-                redirectOverAuth Nothing (Just journalGetCheckLink) Nothing
+          --     then
-              else
+          --       redirectOverAuth Nothing (Just journalGetCheckLink) Nothing
-                throwError $
+          --     else
-                  addMessage (fromString $ show err) $
+          --       throwError $
-                  redirect303 userSelectLink
+          --         addMessage (fromString $ show err) $
-            otherErr ->
+          --         redirect303 userSelectLink
-              throwError $
+          --   otherErr ->
-                addMessage (fromString $ show otherErr) $
+          --     throwError $
-                redirect303 userSelectLink
+          --       addMessage (fromString $ show otherErr) $
+          --       redirect303 userSelectLink
     Nothing ->
       redirectOverAuth Nothing (Just $ journalLink Nothing) Nothing
   where

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

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

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

src/Types/Views.hs

@@ -27,3 +27,5 @@ type CashBuyOverviewPage = H.Html
 type CashBuyConfirmPage = H.Html
 
 type ProductPriceListPage = H.Html
+
+type ProductRefillPage = H.Html

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

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