From fdc7beda609f2ededbc929d95bd55ba20dc206ac Mon Sep 17 00:00:00 2001 From: nek0 Date: Sat, 9 Nov 2019 12:29:29 +0100 Subject: [PATCH] finished buyCash --- src/API.hs | 6 +- src/ClientAuth.hs | 3 + src/Control/Buy.hs | 150 +++++++++++++++++++++++++++++++++++---------- src/Main.hs | 2 +- src/View/Buy.hs | 10 +-- src/View/User.hs | 2 +- 6 files changed, 130 insertions(+), 43 deletions(-) diff --git a/src/API.hs b/src/API.hs index 0a8c3f6..410243e 100644 --- a/src/API.hs +++ b/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 diff --git a/src/ClientAuth.hs b/src/ClientAuth.hs index abf678b..a8d23d6 100644 --- a/src/ClientAuth.hs +++ b/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 diff --git a/src/Control/Buy.hs b/src/Control/Buy.hs index b89e079..87786f0 100644 --- a/src/Control/Buy.hs +++ b/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) []) -> - logoutAndRedirectHome - (translate l10n loc "Please Pay" <> ": " <> formatMoney price) - backend - token - (MT.PurchaseResult (MT.PayAmount price) miss) -> - throwError - $ addMessage (translate l10n loc "Please Pay" <> ": " - <> formatMoney price - <> "\n" - <> translate l10n loc ("But there seems to be something missing.") - ) - $ redirect307 (buyLink uid (Just True)) + (MT.PurchaseResult (MT.PayAmount _) _) -> + throwError $ err500 + { errBody = "You can't buy with cash while logged in" + } + -- (MT.PurchaseResult (MT.PayAmount price) []) -> + -- logoutAndRedirectHome + -- (translate l10n loc "Please Pay" <> ": " <> formatMoney price) + -- backend + -- token + -- (MT.PurchaseResult (MT.PayAmount price) miss) -> + -- throwError + -- $ addMessage (translate l10n loc "Please Pay" <> ": " + -- <> 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 diff --git a/src/Main.hs b/src/Main.hs index 0568bec..5c54c58 100644 --- a/src/Main.hs +++ b/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 diff --git a/src/View/Buy.hs b/src/View/Buy.hs index 69c0317..761c7e3 100644 --- a/src/View/Buy.hs +++ b/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 diff --git a/src/View/User.hs b/src/View/User.hs index be9d0a5..1985607 100644 --- a/src/View/User.hs +++ b/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