fix product refill and add new product creation

This commit is contained in:
nek0 2019-12-19 02:43:10 +01:00
parent ad0a795ff0
commit 31f6665fee
10 changed files with 213 additions and 24 deletions

View file

@ -30,6 +30,7 @@ executable matebeamter
, Types.Views , Types.Views
, Types.User , Types.User
, Types.Journal , Types.Journal
, Types.Product
, Types.Orphans , Types.Orphans
, Types.Configuration , Types.Configuration
, Control , Control

View file

@ -95,4 +95,46 @@ productPostRefill mcookie refills = do
productGetNew productGetNew
:: Maybe T.Text :: Maybe T.Text
-> UserHandler ProductNewPage -> UserHandler ProductNewPage
productgetNew mcookie = do productGetNew mcookie = do
(token, muser, loc, l10n, backend) <- controlInit mcookie
case muser of
Just user ->
-- TODO: Fetch avatars and suppliers
return $ productNewPage l10n loc mcookie
Nothing ->
redirectOverAuth (read <$> muser) (Just productGetRefillLink) Nothing
productPostNew
:: Maybe T.Text
-> ProductSubmit
-> UserHandler ProductNewPage
productPostNew mcookie (ProductSubmit ident flPrice ml max apc ppc artnr) = do
(token, muser, loc, l10n, backend) <- controlInit mcookie
case muser of
Just user -> do
eresult <- liftIO $ runClientM
(productNew
(mkAuthenticatedRequest token authenticateReq)
(MT.ProductSubmit
ident
(floor $ flPrice * 100)
ml
-- TODO: repleace following two values with real avatar and supplier
Nothing
Nothing
max
apc
(floor <$> fmap (* 100) ppc)
artnr
)
)
backend
case eresult of
Right _ ->
throwError $
addMessage (translate l10n loc "Product created successfully") $
redirect303 (userOverviewLink (read user) Nothing)
Nothing ->
redirectOverAuth (read <$> muser) (Just productGetRefillLink) Nothing
where
translate l10n loc = localize l10n loc . gettext

View file

@ -88,6 +88,8 @@ userApp initState = serveWithContext userApi EmptyContext $
:<|> productGetPriceList mcookie :<|> productGetPriceList mcookie
:<|> productGetRefill mcookie :<|> productGetRefill mcookie
:<|> productPostRefill mcookie :<|> productPostRefill mcookie
:<|> productGetNew mcookie
:<|> productPostNew mcookie
:<|> authControl mcookie :<|> authControl mcookie
:<|> authPostControl mcookie :<|> authPostControl mcookie
:<|> authLogoutControl mcookie :<|> authLogoutControl mcookie

View file

@ -8,5 +8,6 @@ import Types.Reader as T
import Types.Views as T import Types.Views as T
import Types.User as T import Types.User as T
import Types.Journal as T import Types.Journal as T
import Types.Product as T
import Types.Orphans as T import Types.Orphans as T
import Types.Configuration as T import Types.Configuration as T

View file

@ -16,6 +16,8 @@ import Web.Internal.FormUrlEncoded
import qualified Data.Text as T import qualified Data.Text as T
import Data.Maybe (fromJust) import Data.Maybe (fromJust)
import Debug.Trace
instance MimeUnrender HTML MT.UserSubmit instance MimeUnrender HTML MT.UserSubmit
instance FromForm MT.UserSubmit instance FromForm MT.UserSubmit
@ -45,7 +47,7 @@ instance FromForm [MT.AmountRefill] where
fromForm form = fromForm form =
let kvs = toListStable form let kvs = toListStable form
ks = map fst kvs ks = map fst kvs
kpids = filter ("amountRefillproductId" `T.isPrefixOf`) ks kpids = filter ("amountRefillProductId" `T.isPrefixOf`) ks
prods = filter ((`notElem` kpids) . fst) kvs prods = filter ((`notElem` kpids) . fst) kvs
stripPid = snd . T.breakOnEnd "-" stripPid = snd . T.breakOnEnd "-"
digestForm key = digestForm key =
@ -56,7 +58,10 @@ instance FromForm [MT.AmountRefill] where
amountCrates = read amountCrates = read
(T.unpack . fromJust $ (T.unpack . fromJust $
lookup ("amountRefillAmountCrates-" <> stripPid key) prods) lookup ("amountRefillAmountCrates-" <> stripPid key) prods)
in MT.AmountRefill pid amountSingles amountCrates in MT.AmountRefill
res = map digestForm kpids (trace (show pid) pid)
(trace (show amountSingles) amountSingles)
(trace (show amountCrates) amountCrates)
res = map digestForm (trace (show kvs) kpids)
in in
Right res Right res

View file

@ -1,19 +1,28 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Types.Product where module Types.Product where
import GHC.Generics import GHC.Generics
import Servant.API
import Servant.HTML.Blaze
import Web.Internal.FormUrlEncoded
import qualified Data.Text as T import qualified Data.Text as T
data ProductSubmit = ProductSubmit data ProductSubmit = ProductSubmit
{ productSubmitIdent :: T.Text { productSubmitIdent :: T.Text
, productSubmitPrice :: Int , productSubmitPrice :: Float
, productSubmitMl :: Int , productSubmitMl :: Int
, productSubmitAvatar :: Maybe Int -- TODO: Create and manage suppliers and avatars
, productSubmitSupplier :: Maybe Int -- , productSubmitAvatar :: Maybe Int
-- , productSubmitSupplier :: Maybe Int
, productSubmitMaxAmount :: Int , productSubmitMaxAmount :: Int
, productSubmitAmountPerCrate :: Int , productSubmitAmountPerCrate :: Int
, productSubmitPricePerCrate :: Maybe Int , productSubmitPricePerCrate :: Maybe Float
, productSubmitArtNr :: Maybe T.Text , productSubmitArtNr :: Maybe T.Text
} deriving (Generic, Show) } deriving (Generic, Show)
instance MimeUnrender HTML ProductSubmit
instance FromForm ProductSubmit

View file

@ -30,4 +30,4 @@ type ProductPriceListPage = H.Html
type ProductRefillPage = H.Html type ProductRefillPage = H.Html
type productNewPage = H.Html type ProductNewPage = H.Html

View file

@ -89,15 +89,15 @@ buyConfirmPage l10n locale uid ziptups total forceBuy mcookie =
H.! HA.for ("product-total-" <> fromString (show pid)) H.! HA.for ("product-total-" <> fromString (show pid))
$ H.toHtml $ $ H.toHtml $
" @ " <> formatMoney price <> "" -- TODO: ask for currency symbol " @ " <> formatMoney price <> "" -- TODO: ask for currency symbol
H.input -- H.input
H.! HA.id ("product-total-" <> fromString (show pid)) -- H.! HA.id ("product-total-" <> fromString (show pid))
H.! HA.class_ "form-control" -- H.! HA.class_ "form-control"
H.! HA.name ("productTotal-" <> fromString (show pid)) -- H.! HA.name ("productTotal-" <> fromString (show pid))
H.! HA.type_ "text" -- H.! HA.type_ "text"
H.! HA.value -- H.! HA.value
(fromString $ T.unpack $ formatMoney $ amount * price) -- (fromString $ T.unpack $ formatMoney $ amount * price)
H.! HA.disabled "" -- H.! HA.disabled ""
H.toHtml ("" :: T.Text) -- TODO: ask for currency symbol -- H.toHtml ("€" :: T.Text) -- TODO: ask for currency symbol
) )
ziptups ziptups
H.div H.! HA.class_ "form-group required" $ do H.div H.! HA.class_ "form-group required" $ do

View file

@ -69,7 +69,7 @@ productRefillPage l10n loc mcookie prodList =
translate "Matebeamter" <> translate "Matebeamter" <>
" - " <> " - " <>
translate "Refill stock" translate "Refill stock"
) $ do ) $
H.form H.form
H.! HA.method "post" H.! HA.method "post"
H.! HA.action ("/" <> fromString H.! HA.action ("/" <> fromString
@ -112,7 +112,7 @@ productRefillPage l10n loc mcookie prodList =
"amount-refill-amount-singeles-" <> "amount-refill-amount-singeles-" <>
fromString (show pid) fromString (show pid)
) )
$ H.toHtml (translate "Amount") $ H.toHtml (translate "Amount of single items")
H.input H.input
H.! HA.id ( H.! HA.id (
"amount-refill-amount-singles-" <> "amount-refill-amount-singles-" <>
@ -120,13 +120,19 @@ productRefillPage l10n loc mcookie prodList =
) )
H.! HA.class_ "form-control product-amount" H.! HA.class_ "form-control product-amount"
H.! HA.name ( H.! HA.name (
"amountRefillAmountSingles- " <> "amountRefillAmountSingles-" <>
fromString (show pid) fromString (show pid)
) )
H.! HA.type_ "number" H.! HA.type_ "number"
H.! HA.min "0" H.! HA.min "0"
H.! HA.step "1" H.! HA.step "1"
H.! HA.value "0" H.! HA.value "0"
H.label
H.! HA.for (
"amount-refill-amount-crates-" <>
fromString (show pid)
)
$ H.toHtml (translate "Amount of full crates")
H.input H.input
H.! HA.id ( H.! HA.id (
"amount-refill-amount-crates-" <> "amount-refill-amount-crates-" <>
@ -134,7 +140,7 @@ productRefillPage l10n loc mcookie prodList =
) )
H.! HA.class_ "form-control product-amount" H.! HA.class_ "form-control product-amount"
H.! HA.name ( H.! HA.name (
"amountRefillAmountCrates- " <> "amountRefillAmountCrates-" <>
fromString (show pid) fromString (show pid)
) )
H.! HA.type_ "number" H.! HA.type_ "number"
@ -156,11 +162,128 @@ productNewPage
-> Locale -> Locale
-> Maybe T.Text -> Maybe T.Text
-> ProductNewPage -> ProductNewPage
productnewPage l10n loc mcookie = productNewPage l10n loc mcookie =
scaffold l10n loc mcookie (initPage $ scaffold l10n loc mcookie (initPage $
translate "Matebeamter" <> translate "Matebeamter" <>
" - " <> " - " <>
translate "Create new product" translate "Create new product"
) $ do ) $
H.form
H.! HA.method "post"
H.! HA.action ("/" <> fromString
(show $ linkURI productPostNewLink)
)
H.! HA.enctype "application/x-www-form-urlencoded"
$ do
H.div H.! HA.class_ "form-group required" $ do
H.label H.! HA.for "ident" $ H.toHtml $ translate "Product name"
H.input
H.! HA.id "ident"
H.! HA.class_ "form-control"
H.! HA.name "productSubmitIdent"
H.! HA.type_ "text"
H.! HA.value ""
H.! HA.required ""
H.div H.! HA.class_ "form-group required" $ do
H.label H.! HA.for "price" $ H.toHtml $ translate "Product price"
H.input
H.! HA.id "price"
H.! HA.class_ "form-control"
H.! HA.name "productSubmitPrice"
H.! HA.type_ "number"
H.! HA.min "0"
H.! HA.step "0.01"
H.! HA.value "0"
H.! HA.required ""
H.div H.! HA.class_ "form-group required" $ do
H.label H.! HA.for "ml" $ H.toHtml $
translate "Product volume in ml"
H.input
H.! HA.id "ml"
H.! HA.class_ "form-control"
H.! HA.name "productSubmitMl"
H.! HA.type_ "number"
H.! HA.min "0"
H.! HA.step "1"
H.! HA.value "0"
H.! HA.required ""
H.div H.! HA.class_ "form-group required" $ do
H.label H.! HA.for "max-amount" $ H.toHtml $
translate "Product maximum stock amount"
H.input
H.! HA.id "max-amount"
H.! HA.class_ "form-control"
H.! HA.name "productSubmitMaxAmount"
H.! HA.type_ "number"
H.! HA.min "0"
H.! HA.step "1"
H.! HA.value "0"
H.! HA.required ""
H.div H.! HA.class_ "form-group required" $ do
H.label H.! HA.for "amount-per-crate" $ H.toHtml $
translate "Product amount per crate"
H.input
H.! HA.id "amount-per-crate"
H.! HA.class_ "form-control"
H.! HA.name "productSubmitAmountPerCrate"
H.! HA.type_ "number"
H.! HA.min "0"
H.! HA.step "1"
H.! HA.value "0"
H.! HA.required ""
H.div H.! HA.class_ "form-group optional" $ do
H.label H.! HA.for "price-per-crate" $ H.toHtml $
translate "Product price per crate"
H.input
H.! HA.id "price-per-crate"
H.! HA.class_ "form-control"
H.! HA.name "productSubmitPricePerCrate"
H.! HA.type_ "number"
H.! HA.min "0"
H.! HA.step "0.01"
H.! HA.value "0"
H.div H.! HA.class_ "form-group optional" $ do
H.label H.! HA.for "article-number" $ H.toHtml $
translate "Product article number"
H.input
H.! HA.id "article-number"
H.! HA.class_ "form-control"
H.! HA.name "productSubmitArtNr"
H.! HA.type_ "text"
H.! HA.value ""
H.! HA.required ""
{- -- TODO: Create and manage suppliers and avatars
H.div H.! HA.class_ "form-group optional" $ do
H.label H.! HA.for "supplier" $ H.toHtml $
translate "Product supplier"
H.select
H.! HA.id "supplier"
H.! HA.class_ "form-control"
H.! HA.name "productSubmitSupplier"
$ do
H.option
H.! HA.value ""
H.! HA.selected ""
$ toHtml $ translate "None"
-- TODO: FILL ME!
H.div H.! HA.class_ "form-group optional" $ do
H.label H.! HA.for "avatar" $ H.toHtml $
translate "Product avater"
H.select
H.! HA.id "avatar"
H.! HA.class_ "form-control"
H.! HA.name "productSubmitAvatar"
$ do
H.option
H.! HA.value ""
H.! HA.selected ""
$ toHtml $ translate "None"
-- TODO: FILL ME!
-}
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 where
translate = localize l10n loc . gettext translate = localize l10n loc . gettext

View file

@ -130,6 +130,12 @@ userSettingsPointer l10n locale uid =
H.! HA.formaction H.! HA.formaction
("/" <> fromString (show $ linkURI $ journalLink Nothing)) ("/" <> fromString (show $ linkURI $ journalLink Nothing))
$ H.toHtml $ translate "View Journal" $ H.toHtml $ translate "View Journal"
H.button
H.! HA.type_ "submit"
H.! HA.formmethod "get"
H.! HA.formaction
("/" <> fromString (show $ linkURI productGetNewLink))
$ H.toHtml $ translate "Add new product"
where where
translate = localize l10n locale . gettext translate = localize l10n locale . gettext