fix product refill and add new product creation

matebeamter.cabal

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

src/Control/Product.hs

@@ -95,4 +95,46 @@ productPostRefill mcookie refills = do
 productGetNew
   :: Maybe T.Text
   -> 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

src/Main.hs

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

src/Types.hs

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

src/Types/Orphans.hs

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

src/Types/Product.hs

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

src/Types/Views.hs

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

src/View/Buy.hs

@@ -89,15 +89,15 @@ buyConfirmPage l10n locale uid ziptups total forceBuy mcookie =
                     H.! HA.for ("product-total-" <> fromString (show pid))
                     $ H.toHtml $
                       " @ " <> 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
           H.div H.! HA.class_ "form-group required" $ do

src/View/Product.hs

@@ -69,7 +69,7 @@ productRefillPage l10n loc mcookie prodList =
     translate "Matebeamter" <>
     " - " <>
     translate "Refill stock"
-    ) $ do
+    ) $
       H.form
         H.! HA.method "post"
         H.! HA.action ("/" <> fromString
@@ -112,7 +112,7 @@ productRefillPage l10n loc mcookie prodList =
                         "amount-refill-amount-singeles-" <>
                         fromString (show pid)
                         )
-                      $ H.toHtml (translate "Amount")
+                      $ H.toHtml (translate "Amount of single items")
                     H.input
                       H.! HA.id (
                         "amount-refill-amount-singles-" <>
@@ -127,6 +127,12 @@ productRefillPage l10n loc mcookie prodList =
                       H.! HA.min "0"
                       H.! HA.step "1"
                       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.! HA.id (
                         "amount-refill-amount-crates-" <>
@@ -156,11 +162,128 @@ productNewPage
   -> Locale
   -> Maybe T.Text
   -> ProductNewPage
-productnewPage l10n loc mcookie =
+productNewPage l10n loc mcookie =
   scaffold l10n loc mcookie (initPage $
     translate "Matebeamter" <>
     " - " <>
     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
     translate = localize l10n loc . gettext

src/View/User.hs

@@ -130,6 +130,12 @@ userSettingsPointer l10n locale uid =
       H.! HA.formaction
         ("/" <> fromString (show $ linkURI $ journalLink Nothing))
       $ 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
     translate = localize l10n locale . gettext