finished buyCash

src/API.hs

@@ -32,11 +32,11 @@ type UserAPI =
     :> Get '[HTML] UserOverviewPage
   :<|> "user" :> Capture "id" Int :> "buy"
     :> ReqBody '[FormUrlEncoded] [MT.PurchaseDetail]
-    :> QueryParam "force" Bool
+    :> QueryFlag "force"
     :> Post '[HTML] BuyConfirmPage
   :<|> "user" :> Capture "id" Int :> "purchasecomplete"
     :> ReqBody '[FormUrlEncoded] [MT.PurchaseDetail]
-    :> QueryParam "force" Bool
+    :> QueryFlag "force"
     :> Post '[HTML] UserSelectPage
   :<|> "user" :> Capture "id" Int :> "recharge"
     :> Get '[HTML] UserRechargePage
@@ -60,7 +60,7 @@ type UserAPI =
     :> QueryParam "refine" MT.ProductRefine
     :> Get '[HTML] CashBuyOverviewPage
   :<|> "buy"
-    :> QueryParam "force" Bool
+    -- :> QueryFlag "force"
     :> ReqBody '[FormUrlEncoded] [MT.PurchaseDetail]
     :> Post '[HTML] CashBuyConfirmPage
   :<|> "journal" :> QueryParam "page" Word

src/ClientAuth.hs

@@ -10,3 +10,6 @@ type instance AuthClientData (AuthProtect "header-auth") = String
 
 authenticateReq :: String -> Request -> Request
 authenticateReq = addHeader "Authentication"
+
+nonAuthenticateRequest :: String -> Request -> Request
+nonAuthenticateRequest _ = id

src/Control/Buy.hs

@@ -40,7 +40,7 @@ buyControl
   :: Maybe T.Text
   -> Int
   -> [MT.PurchaseDetail]
-  -> Maybe Bool
+  -> Bool
   -> UserHandler BuyConfirmPage
 buyControl mcookie uid pds forceBuy =
   if not (null pds)
@@ -74,27 +74,11 @@ buyControl mcookie uid pds forceBuy =
   else
     throwError (redirect303 $ userOverviewLink uid Nothing)
 
-cashBuyOverviewControl
-  :: Maybe T.Text
-  -> Maybe MT.ProductRefine
-  -> UserHandler CashBuyOverviewPage
-cashBuyOverviewControl mcookie mrefine = do
-  (ReadState l10n backend _) <- ask
-  let loc = localeFromCookie mcookie
-  eproducts <- liftIO $ runClientM
-    (productShortList
-      mrefine
-      )
-    backend
-  case eproducts of
-    Right prods ->
-      return $ cashBuyOverviewPage l10n loc mcookie prods
-
 purchaseControl
   :: Maybe T.Text
   -> Int
   -> [MT.PurchaseDetail]
-  -> Maybe Bool
+  -> Bool
   -> UserHandler UserSelectPage
 purchaseControl mcookie uid pds forceBuy = do
   l10n <- asks rsL10n
@@ -104,7 +88,7 @@ purchaseControl mcookie uid pds forceBuy = do
   then do
     backend <- asks rsBackend
     let (token, _) = parseTokenAndUser mcookie
-    erefres <- if (isJust forceBuy && fromJust forceBuy)
+    erefres <- if forceBuy
       then do
         let refills = map
               (\(MT.PurchaseDetail pid amount) -> MT.AmountRefill pid amount)
@@ -142,23 +126,27 @@ purchaseControl mcookie uid pds forceBuy = do
             (translate l10n loc "Purchase successful")
             backend
             token
-        (MT.PurchaseResult (MT.PayAmount price) []) ->
+        (MT.PurchaseResult (MT.PayAmount _) _) ->
-          logoutAndRedirectHome
+          throwError $ err500
-            (translate l10n loc "Please Pay" <> ": " <> formatMoney price)
+            { errBody = "You can't buy with cash while logged in"
-            backend
+            }
-            token
+        -- (MT.PurchaseResult (MT.PayAmount price) []) ->
-        (MT.PurchaseResult (MT.PayAmount price) miss) ->
+        --   logoutAndRedirectHome
-          throwError
+        --     (translate l10n loc "Please Pay" <> ": " <> formatMoney price)
-            $ addMessage (translate l10n loc "Please Pay" <> ": "
+        --     backend
-              <> formatMoney price
+        --     token
-              <> "\n"
+        -- (MT.PurchaseResult (MT.PayAmount price) miss) ->
-              <> translate l10n loc ("But there seems to be something missing.")
+        --   throwError
-              )
+        --     $ addMessage (translate l10n loc "Please Pay" <> ": "
-            $ redirect307 (buyLink uid (Just True))
+        --       <> formatMoney price
+        --       <> "\n"
+        --       <> translate l10n loc ("But there seems to be something missing:")
+        --       )
+        --     $ redirect307 (buyLink uid True)
         (MT.PurchaseResult _ miss) ->
           throwError
             $ addMessage (translate l10n loc "Purchase partly successful.")
-            $ redirect307 (buyLink uid (Just True))
+            $ redirect307 (buyLink uid True)
       Left err ->
         throwError
           $ addMessage (fromString (show err))
@@ -178,3 +166,99 @@ purchaseControl mcookie uid pds forceBuy = do
         $ addMessage message
         $ redirect303 userSelectLink
     translate l10n locale = localize l10n locale . gettext
+
+cashBuyOverviewControl
+  :: Maybe T.Text
+  -> Maybe MT.ProductRefine
+  -> UserHandler CashBuyOverviewPage
+cashBuyOverviewControl mcookie mrefine = do
+  (ReadState l10n backend _) <- ask
+  let loc = localeFromCookie mcookie
+  eproducts <- liftIO $ runClientM
+    (productShortList
+      mrefine
+      )
+    backend
+  case eproducts of
+    Right prods ->
+      return $ cashBuyOverviewPage l10n loc mcookie prods
+    Left err ->
+      throwError $ err500
+        { errBody = fromString (show err)
+        }
+
+cashBuyPurchaseControl
+  :: Maybe T.Text
+  -- -> Bool
+  -> [MT.PurchaseDetail]
+  -> UserHandler UserSelectPage
+cashBuyPurchaseControl mcookie {-forceBuy-} pds = do
+  l10n <- asks rsL10n
+  let loc = localeFromCookie mcookie
+  if not (null pds)
+  then do
+    backend <- asks rsBackend
+    -- erefres <- if forceBuy
+    --   then do
+    --     let refills = map
+    --           (\(MT.PurchaseDetail pid amount) -> MT.AmountRefill pid amount)
+    --           pds
+    --     liftIO $ runClientM
+    --       (productStockRefill
+    --         (mkAuthenticatedRequest token authenticateReq)
+    --         refills
+    --         )
+    --       backend
+    --   else
+    --     return $ Right ()
+    eresult <- liftIO $ runClientM
+      (buy
+        (mkAuthenticatedRequest "secret" nonAuthenticateRequest)
+        pds
+        )
+      backend
+    case eresult of
+      Right result -> case result of
+        (MT.PurchaseResult (MT.PayAmount price) []) ->
+          throwError $
+            addMessage
+              (translate l10n loc "Please Pay" <> ": " <> formatMoney price) $
+            redirect303 userSelectLink
+        (MT.PurchaseResult (MT.PayAmount price) miss) -> do
+          eproducts <- liftIO $ runClientM
+            (productShortList
+              (Just MT.AllProducts)
+              )
+            backend
+          let missIds = map (\(MT.PurchaseDetail pid amount) -> (pid, amount)) miss
+          case eproducts of
+            Right prods ->
+              throwError
+                $ addMessage (translate l10n loc "Please Pay" <> ": "
+                  <> formatMoney price
+                  <> ". "
+                  <> translate l10n loc
+                    ("But there seems to be something missing: ")
+                  <> mconcat (reverse $ foldl
+                    (\acc (MT.ProductShortOverview psoid ident _ _ _ _) ->
+                      if psoid `elem` fst (unzip missIds)
+                      then
+                        (fromString (show $ fromJust $ lookup psoid missIds)
+                        <> " x "
+                        <> fromString (T.unpack ident)) : acc
+                      else acc
+                      )
+                    []
+                    prods
+                  ))
+                $ redirect303 userSelectLink
+            Left err ->
+              throwError $ err500
+                { errBody = fromString (show err)
+                }
+  else
+    throwError
+      $ addMessage (translate l10n loc "Please choose your product(s)")
+      $ (redirect303 $ cashBuyLink Nothing)
+  where
+    translate l10n locale = localize l10n locale . gettext

src/Main.hs

@@ -81,7 +81,7 @@ userApp initState = serveWithContext userApi EmptyContext $
     :<|> userNewControl mcookie
     :<|> userNewPostControl mcookie
     :<|> cashBuyOverviewControl mcookie
-    :<|> const (error "not yet implemented")
+    :<|> cashBuyPurchaseControl mcookie
     :<|> journalControl mcookie
     :<|> authControl mcookie
     :<|> authPostControl mcookie

src/View/Buy.hs

@@ -34,7 +34,7 @@ buyConfirmPage
   -> Int
   -> [(MT.PurchaseDetail, MT.ProductShortOverview)]
   -> Int
-  -> Maybe Bool
+  -> Bool
   -> Maybe T.Text
   -> H.Html
 buyConfirmPage l10n locale uid ziptups total forceBuy mcookie =
@@ -43,7 +43,7 @@ buyConfirmPage l10n locale uid ziptups total forceBuy mcookie =
     " - " <>
     translate "Home"
     ) $ do
-      if not (fromMaybe False forceBuy)
+      if not forceBuy
       then
         H.p $ H.toHtml $ translate "You are about to buy the following items:"
       else
@@ -116,10 +116,10 @@ buyConfirmPage l10n locale uid ziptups total forceBuy mcookie =
             H.button
               H.! HA.class_ "btn btn-default"
               H.! HA.type_ "submit"
-              $ H.toHtml $ if (fromMaybe False forceBuy)
+              $ H.toHtml $ if forceBuy
                 then translate "Buy anyway"
                 else translate "Buy"
-          when (fromMaybe False forceBuy) $
+          when forceBuy $
             H.button
               H.! HA.formnovalidate "formnovalidate"
               H.! HA.formmethod "get"
@@ -194,7 +194,7 @@ cashBuyOverviewPage l10n loc mcookie psos =
       H.form
         H.! HA.method "post"
         H.! HA.action ("/" <> fromString (
-          show $ linkURI $ cashBuyPostLink (Just False)
+          show $ linkURI cashBuyPostLink
           ))
         H.! HA.enctype "application/x-www-form-urlencoded"
         $ buyProductsForm l10n loc psos

src/View/User.hs

@@ -106,7 +106,7 @@ userOverviewPage l10n locale method ud pos mcookie =
       H.form
         H.! HA.method "post"
         H.! HA.action ("/" <> (fromString $ show $ linkURI $
-          buyLink (MT.userDetailsId ud) Nothing)
+          buyLink (MT.userDetailsId ud) False)
           )
         H.! HA.enctype "application/x-www-form-urlencoded" $
           buyProductsForm l10n locale pos