nek0/matebeamter
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

process purchases without missing items

Browse source
This commit is contained in:
nek0 2019-10-24 07:39:46 +02:00
parent 2c798c3e7e
commit f41aab662a
4 changed files with 136 additions and 32 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
src/API.hs
View file

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

68
src/Control/Buy.hs
View file

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

1
src/Main.hs
View file

@ -44,6 +44,7 @@ userApp initState = serveWithContext userApi EmptyContext $
(\mcookie -> userSelectControl mcookie
:<|> userOverviewControl mcookie
:<|> buyControl mcookie
:<|> purchaseControl mcookie
:<|> userManageControl mcookie
:<|> userManageDetailsSubmitControl mcookie
:<|> userManageAuthCreateControl mcookie

97
src/View/Buy.hs
View file

@ -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 $
mapM_
(\( MT.PurchaseDetail pdid amount
, MT.ProductShortOverview pid ident price _ _ mava) ->
H.li $ do
H.img
H.!?
( isJust mava
, 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)
)
)
ziptups
H.p $ H.toHtml $
(translate "Total price")
<> ": "
<> formatMoney total
-- <> "€" -- TODO: ask for currency symbol
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.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
)
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.div H.! HA.class_ "form-group required" $ do
H.label
H.! HA.for "total-price"
$ H.toHtml ("Total price: " :: T.Text)
H.input
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