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

refill kinda does things

Browse source
This commit is contained in:
nek0 2019-12-15 00:05:12 +01:00
parent 2708f14ce4
commit 9cbc638a62
9 changed files with 186 additions and 14 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

7
src/API.hs
View file

@ -72,6 +72,11 @@ type UserAPI =
:> Post '[HTML] JournalPage
:<|> "product" :> "list"
:> Get '[HTML] ProductPriceListPage
:<|> "product" :> "refill"
:> Get '[HTML] ProductRefillPage
:<|> "product" :> "refill"
:> ReqBody '[FormUrlEncoded] [MT.AmountRefill]
:> Post '[HTML] ProductRefillPage
:<|> "auth"
:> QueryParam "destination" T.Text
:> Get '[HTML]
@ -105,6 +110,8 @@ type UserAPI =
journalGetCheckLink :<|>
journalPostCheckLink :<|>
productGetPriceListLink :<|>
productGetRefillLink :<|>
productPostRefillLink :<|>
authLink :<|>
authPostLink :<|>
authLogoutLink

8
src/Control/Buy.hs
View file

@ -71,6 +71,10 @@ buyControl mcookie uid pds forceBuy =
0
ziptup
return (buyConfirmPage l10n loc uid ziptup total forceBuy mcookie)
Left err ->
throwError $
addMessage (fromString $ show err) $
redirect303 userSelectLink
else
throwError (redirect303 $ userOverviewLink uid Nothing)
@ -91,7 +95,7 @@ purchaseControl mcookie uid pds forceBuy = do
erefres <- if forceBuy
then do
let refills = map
(\(MT.PurchaseDetail pid amount) -> MT.AmountRefill pid amount)
(\(MT.PurchaseDetail pid amount) -> MT.AmountRefill pid amount 0)
pds
liftIO $ runClientM
(productStockRefill
@ -256,6 +260,8 @@ cashBuyPurchaseControl mcookie {-forceBuy-} pds = do
throwError $ err500
{ errBody = fromString (show err)
}
Left err ->
handleClientErr err (Just userSelectLink)
else
throwError
$ addMessage (translate l10n loc "Please choose your product(s)")

27
src/Control/Journal.hs
View file

@ -93,19 +93,20 @@ journalPostCheckControl mcookie (CashCheck floatAmount) = do
addMessage (translate l10n loc "Cash check received and processed") $
redirect303 (journalLink Nothing)
Left err ->
case err of
FailureResponse _ resp ->
if statusCode (responseStatusCode resp) == 401
then
redirectOverAuth Nothing (Just journalGetCheckLink) Nothing
else
throwError $
addMessage (fromString $ show err) $
redirect303 userSelectLink
otherErr ->
throwError $
addMessage (fromString $ show otherErr) $
redirect303 userSelectLink
handleClientErr err (Just journalGetCheckLink)
-- case err of
-- FailureResponse _ resp ->
-- if statusCode (responseStatusCode resp) == 401
-- then
-- redirectOverAuth Nothing (Just journalGetCheckLink) Nothing
-- else
-- throwError $
-- addMessage (fromString $ show err) $
-- redirect303 userSelectLink
-- otherErr ->
-- throwError $
-- addMessage (fromString $ show otherErr) $
-- redirect303 userSelectLink
Nothing ->
redirectOverAuth Nothing (Just $ journalLink Nothing) Nothing
where

20
src/Control/Product.hs
View file

@ -42,3 +42,23 @@ productGetPriceList mcookie = do
throwError $
addMessage (fromString $ show err) $
redirect303 userSelectLink
productGetRefill
:: Maybe T.Text
-> UserHandler ProductRefillPage
productGetRefill mcookie = do
(token, muser, loc, l10n, backend) <- controlInit mcookie
case muser of
Just _ -> do
elist <- liftIO $ runClientM
(productShortList (Just MT.AllProducts))
backend
case elist of
Right list -> do
return $ productRefillPage l10n loc mcookie list
Left err ->
throwError $
addMessage (fromString $ show err) $
redirect303 userSelectLink
Nothing ->
redirectOverAuth Nothing (Just productGetRefillLink) Nothing

2
src/Main.hs
View file

@ -86,6 +86,8 @@ userApp initState = serveWithContext userApi EmptyContext $
:<|> journalGetCheckControl mcookie
:<|> journalPostCheckControl mcookie
:<|> productGetPriceList mcookie
:<|> productGetRefill mcookie
:<|> (\_ _ -> error "not yet implemented") mcookie
:<|> authControl mcookie
:<|> authPostControl mcookie
:<|> authLogoutControl mcookie

21
src/Types/Orphans.hs
View file

@ -39,3 +39,24 @@ instance FromForm [MT.PurchaseDetail] where
res = map digestForm kpids
in
Right res
instance MimeUnrender HTML [MT.AmountRefill]
instance FromForm [MT.AmountRefill] where
fromForm form =
let kvs = toListStable form
ks = map fst kvs
kpids = filter ("amountRefillproductId" `T.isPrefixOf`) ks
prods = filter ((`notElem` kpids) . fst) kvs
stripPid = snd . T.breakOnEnd "-"
digestForm key =
let pid = read (T.unpack $ stripPid key)
amountSingles = read
(T.unpack . fromJust $
lookup ("amountRefillAmountSingles-" <> stripPid key) prods)
amountCrates = read
(T.unpack . fromJust $
lookup ("amountRefillAmountCrates-" <> stripPid key) prods)
in MT.AmountRefill pid amountSingles amountCrates
res = map digestForm kpids
in
Right res

2
src/Types/Views.hs
View file

@ -27,3 +27,5 @@ type CashBuyOverviewPage = H.Html
type CashBuyConfirmPage = H.Html
type ProductPriceListPage = H.Html
type ProductRefillPage = H.Html

16
src/Util.hs
View file

@ -147,6 +147,7 @@ redirectOverAuth
-> UserHandler UserOverviewPage
redirectOverAuth muid mLink mRefine = do
let redirectHeaders = errHeaders $
-- redirect303 authLink
redirect303 (authLink (Just $ "/" <>
fromString (show $ linkURI (case (mLink, muid) of
(Just link, _) -> link
@ -195,3 +196,18 @@ controlInit mcookie = do
l10n <- asks rsL10n
backend <- asks rsBackend
return (token, muser, loc, l10n, backend)
handleClientErr err authTargetLink =
case err of
FailureResponse _ resp ->
if statusCode (responseStatusCode resp) == 401
then
redirectOverAuth Nothing authTargetLink Nothing
else
throwError $
addMessage (fromString $ show err) $
redirect303 userSelectLink
othererr ->
throwError $
addMessage (fromString $ show othererr) $
redirect303 userSelectLink

97
src/View/Product.hs
View file

@ -2,11 +2,15 @@
{-# LANGUAGE PackageImports #-}
module View.Product where
import Servant.Links
import Data.String (fromString)
import qualified Data.Text as T
import Data.Text.I18n
import Data.Maybe (fromJust, isJust)
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as HA
@ -53,3 +57,96 @@ productPriceListPage l10n loc mcookie list =
list
where
translate = localize l10n loc . gettext
productRefillPage
:: L10n
-> Locale
-> Maybe T.Text
-> [MT.ProductShortOverview]
-> ProductRefillPage
productRefillPage l10n loc mcookie prodList =
scaffold l10n loc mcookie (initPage $
translate "Matebeamter" <>
" - " <>
translate "Refill stock"
) $ do
H.form
H.! HA.method "post"
H.! HA.action ("/" <> fromString
(show $ linkURI productPostRefillLink)
)
H.! HA.enctype "application/x-www-form-urlencoded"
$ do
mapM_
(\(MT.ProductShortOverview pid ident price amount ml maid) -> do
H.div
H.! HA.class_ "form-group optional"
H.!?
( isJust maid
, productBgStyle (fromString $ show $ fromJust maid)
)
$ do
H.label
H.! HA.for (
"amount-refill-product-id-" <>
fromString (show pid)
)
$ H.toHtml ident
H.input
H.! HA.id (
"amount-refill-product-id-" <>
fromString (show pid)
)
H.! HA.class_ "form-control product-select"
H.! HA.name (
"amountRefillProductId-" <>
fromString (show pid)
)
H.! HA.type_ "checkbox"
H.! HA.value "true"
H.div
H.! HA.class_ "form-group optional"
$ do
H.label
H.! HA.for (
"amount-refill-amount-singeles-" <>
fromString (show pid)
)
$ H.toHtml (translate "Amount")
H.input
H.! HA.id (
"amount-refill-amount-singles-" <>
fromString (show pid)
)
H.! HA.class_ "form-control product-amount"
H.! HA.name (
"amountRefillAmountSingles- " <>
fromString (show pid)
)
H.! HA.type_ "number"
H.! HA.min "0"
H.! HA.step "1"
H.! HA.value "0"
H.input
H.! HA.id (
"amount-refill-amount-crates-" <>
fromString (show pid)
)
H.! HA.class_ "form-control product-amount"
H.! HA.name (
"amountRefillAmountCrates- " <>
fromString (show pid)
)
H.! HA.type_ "number"
H.! HA.min "0"
H.! HA.step "1"
H.! HA.value "0"
)
prodList
H.div H.! HA.class_ "form-group optional" $
H.button
H.! HA.class_ "btn btn-default"
H.! HA.type_ "submit"
$ H.toHtml $ translate "Submit"
where
translate = localize l10n loc . gettext