process purchases without missing items

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

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

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

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 $
+    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.li $ do
+              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
+                        , 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)
                         )
+                    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.p $ H.toHtml $
+        H.div H.! HA.class_ "form-group required" $ do
-      (translate "Total price")
+          H.label
-      <> ": "
+            H.! HA.for "total-price"
-      <> formatMoney total
+            $ H.toHtml ("Total price: " :: T.Text)
-      -- <> "€" -- TODO: ask for currency symbol
+          H.input
-    H.form
+            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