finished buyCash

This commit is contained in:
nek0 2019-11-09 12:29:29 +01:00
parent a39c83d5f7
commit fdc7beda60
6 changed files with 130 additions and 43 deletions

View file

@ -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

View file

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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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