make proper refill options

src/Control/Product.hs

@@ -37,14 +37,29 @@ productStockRefill
   :: Maybe (Int, AuthMethod)
   -> [AmountRefill]
   -> MateHandler ()
-productStockRefill (Just _) amorefs =
+productStockRefill (Just _) amorefs = do
-  if all ((>= 0) . amountRefillAmount) amorefs
+  conn <- asks rsConnection
-  then do
+  prods <- mapM
-    conn <- asks rsConnection
+    (\refill -> productSelectSingle (amountRefillProductId refill) conn)
-    void $ manualProductAmountRefill amorefs conn
+    amorefs
+  if all (not . null) prods
+  then
+    if
+      all
+        (\refill ->
+          (>= 0) (amountRefillAmountSingles refill) &&
+          (>= 0) (amountRefillAmountCrates refill)
+          )
+        amorefs
+    then do
+      void $ manualProductAmountRefill amorefs conn
+    else
+      throwError $ err400
+        { errBody = "Amounts less than 0 are not acceptable."
+        }
   else
     throwError $ err400
-      { errBody = "Amounts less than 0 are not acceptable."
+      { errBody = "Non-existent Products are non-refillable."
       }
 productStockRefill Nothing _ =
   throwError $ err401

src/Model/Amount.hs

@@ -193,36 +193,6 @@ manualProductAmountUpdate aups conn =
     aups
 
 
-manualProductAmountRefill
-  :: [AmountRefill]
-  -> PGS.Connection
-  -> MateHandler [Int]
-manualProductAmountRefill aups conn =
-  mapM
-    (\(AmountRefill pid amount) -> do
-      oldamount <- getLatestAmountByProductId pid conn
-      oldprice <- getLatestPriceByProductId pid conn
-      head <$> liftIO (do
-        now <- getCurrentTime
-        runInsert_ conn $ Insert
-          { iTable = amountTable
-          , iRows  =
-            [
-            ( C.constant pid
-            , C.constant now
-            , C.constant (oldamount + amount)
-            , C.constant oldprice
-            , C.constant False
-            )
-            ]
-          , iReturning = rReturning (\(id_, _, _, _, _) -> id_)
-          , iOnConflict = Nothing
-          }
-        )
-      )
-    aups
-
-
 postBuyProductAmountUpdate
   :: PurchaseDetail
   -> PGS.Connection

src/Model/Product.hs

@@ -5,6 +5,7 @@
 module Model.Product where
 
 import Data.Text as T hiding (head, foldl)
+import Data.Time (getCurrentTime)
 import Data.Time.Clock (UTCTime)
 import Data.Profunctor.Product (p9)
 
@@ -100,6 +101,35 @@ productSelect conn = do
     prods
 
 
+productSelectSingle
+  :: Int
+  -> PGS.Connection
+  -> MateHandler [Product]
+productSelectSingle pid conn = do
+  prods <- liftIO $ runSelect conn
+    ( limit 1
+      (keepWhen (
+        \(id_, _, _, _, _, _, _, _, _) -> id_ .== C.constant pid
+        ) <<< queryTable productTable)
+    ) :: MateHandler
+        [ ( Int
+          , T.Text
+          , Int
+          , Maybe Int
+          , Maybe Int
+          , Int
+          , Int
+          , Maybe Int
+          , Maybe T.Text
+          )
+        ]
+  mapM
+    (\(i1, i2, i3, i4, i5, i6, i7, i8, i9) -> return $
+      Product i1 i2 i3 i4 i5 i6 i7 i8 i9
+      )
+    prods
+
+
 productOverviewSelect
   :: ProductRefine
   -> PGS.Connection
@@ -281,3 +311,34 @@ insertProduct (ProductSubmit ident _ ml ava sup maxi apc ppc artnr) conn =
     , iReturning = rReturning (\(id_, _, _, _, _, _, _, _, _) -> id_)
     , iOnConflict = Nothing
     }
+
+manualProductAmountRefill
+  :: [AmountRefill]
+  -> PGS.Connection
+  -> MateHandler [Int]
+manualProductAmountRefill aups conn =
+  mapM
+    (\(AmountRefill pid amountSingles amountCrates) -> do
+      oldamount <- getLatestAmountByProductId pid conn
+      oldprice <- getLatestPriceByProductId pid conn
+      perCrate <- (productAmountPerCrate . head) <$>
+        productSelectSingle pid conn
+      head <$> liftIO (do
+        now <- getCurrentTime
+        runInsert_ conn $ Insert
+          { iTable = amountTable
+          , iRows  =
+            [
+            ( C.constant pid
+            , C.constant now
+            , C.constant (oldamount + amountSingles + perCrate * amountCrates)
+            , C.constant oldprice
+            , C.constant False
+            )
+            ]
+          , iReturning = rReturning (\(id_, _, _, _, _) -> id_)
+          , iOnConflict = Nothing
+          }
+        )
+      )
+    aups

src/Types/Amount.hs

@@ -18,8 +18,9 @@ instance FromJSON AmountUpdate
 
 
 data AmountRefill = AmountRefill
-  { amountRefillProductId  :: Int
+  { amountRefillProductId     :: Int
-  , amountRefillAmount     :: Int
+  , amountRefillAmountSingles :: Int
+  , amountRefillAmountCrates  :: Int
   }
   deriving (Show, Generic)