alter/add api endpoints for update/refill

src/API.hs

@@ -32,12 +32,13 @@ type UserAPI =
       :> Capture "id" Int :> ReqBody '[JSON] UserDetailsSubmit :> Post '[JSON] ()
     )
   :<|> "product" :>
-    ( "list" :> Get '[JSON] [ProductShortOverview]
-    :<|> "list" :> AuthProtect "header-auth" :> Get '[JSON] [ProductOverview]
+    ( "list" :> Get '[JSON] [ProductOverview]
     :<|> "new" :> AuthProtect "header-auth" :> ReqBody '[JSON] ProductSubmit
       :> Post '[JSON] Int
     :<|> "update" :> AuthProtect "header-auth"
-      :> ReqBody '[JSON] AmountUpdate :> Post '[JSON] ()
+      :> ReqBody '[JSON] [AmountUpdate] :> Post '[JSON] ()
+    :<|> "refill" :> AuthProtect "header-auth"
+      :> ReqBody '[JSON] [AmountRefill] :> Post '[JSON] ()
     )
   :<|> "buy" :> AuthProtect "header-auth" :> ReqBody '[JSON] [PurchaseDetail]
     :> Post '[JSON] PurchaseResult

src/Main.hs

@@ -149,22 +149,15 @@ users =
           }
 
 products =
-  listShort :<|>
   listLong :<|>
   new :<|>
-  update
+  stockUpdate :<|>
+  stockRefill
   where
-    listShort :: MateHandler [ProductShortOverview]
-    listShort = do
-      conn <- rsConnection <$> ask
-      productShortOverviewSelect conn
-
-    listLong :: Maybe Int -> MateHandler [ProductOverview]
-    listLong (Just _) = do
+    listLong :: MateHandler [ProductOverview]
+    listLong = do
       conn <- rsConnection <$> ask
       productOverviewSelect conn
-    listLong Nothing =
-      throwError $ err403
 
     new :: Maybe Int -> ProductSubmit -> MateHandler Int
     new (Just _) bevsub = do
@@ -176,14 +169,36 @@ products =
     new Nothing _ =
       throwError $ err403
 
-    update :: Maybe Int -> AmountUpdate -> MateHandler ()
-    update (Just _) amosub@(AmountUpdate pid amount) = do
-      conn <- rsConnection <$> ask
-      now <- liftIO $ getCurrentTime
-      oldprice <- getLatestPriceByProductId pid conn
-      void $ manualProductAmountUpdate amosub now oldprice conn
-    update Nothing _ =
+    stockUpdate :: Maybe Int -> [AmountUpdate] -> MateHandler ()
+    stockUpdate (Just _) amoups = do
+      if all ((>= 0) . amountUpdateRealAmount) amoups
+      then do
+        conn <- rsConnection <$> ask
+        void $ manualProductAmountUpdate amoups conn
+      else
+        throwError $ err406
+          { errBody = "Amounts less than 0 are not acceptable"
+          }
+    stockUpdate Nothing _ =
       throwError $ err403
+        { errBody = "No Authentication present"
+        }
+
+    stockRefill :: Maybe Int -> [AmountRefill] -> MateHandler ()
+    stockRefill (Just _) amorefs = do
+      if all ((>= 0) . amountRefillAmount) amorefs
+      then do
+        conn <- rsConnection <$> ask
+        void $ manualProductAmountRefill amorefs conn
+      else
+        throwError $ err406
+          { errBody = "Amounts less than 0 are not acceptable"
+          }
+    stockRefill Nothing _ =
+      throwError $ err403
+        { errBody = "No Authentication present"
+        }
+
 
 buy :: Maybe Int -> [PurchaseDetail] -> MateHandler PurchaseResult
 buy (Just auid) pds = do

src/Model/Amount.hs

@@ -96,6 +96,27 @@ getLatestPriceByProductId pid conn = do
     (\(_, _, _, price, _) -> return price)
     amounts
 
+getLatestAmountByProductId
+  :: Int             -- The associated Product ID
+  -> PGS.Connection
+  -> MateHandler Int -- The amount
+getLatestAmountByProductId pid conn = do
+  amounts <- liftIO $ runSelect conn $
+    orderBy (desc (\(_, ts, _, _, _) -> ts))
+      (keepWhen (\(id_, _, _, _, _) -> id_ .== C.constant pid) <<< queryTable amountTable)
+    :: MateHandler
+      [ ( Int
+        , UTCTime
+        , Int
+        , Int
+        , Bool
+        )
+      ]
+  head <$> return ( map
+    (\(_, _, amount, _, _) -> amount)
+    amounts
+    )
+
 getLatestTotalPrice
   :: PurchaseDetail  -- The associated PurchaseDetail
   -> PGS.Connection
@@ -113,9 +134,10 @@ getLatestTotalPrice (PurchaseDetail pid amount) conn = do
         , Bool
         )
       ]
-  (amount *) <$> head <$> mapM
-    (\(_, _, _, price, _) -> return price)
+  (amount *) <$> head <$> return (map
+    (\(_, _, _, price, _) -> price)
     amounts
+    )
 
 checkProductAvailability
   :: PurchaseDetail
@@ -140,27 +162,65 @@ checkProductAvailability (PurchaseDetail pid amount) conn = do
   then return (Just $ amount - realamount)
   else return Nothing
 
+
 manualProductAmountUpdate
-  :: AmountUpdate
-  -> UTCTime      -- Current time
-  -> Int          -- Old BeveragePrice
+  :: [AmountUpdate]
   -> PGS.Connection
-  -> MateHandler Int
-manualProductAmountUpdate (AmountUpdate pid amount) now oldprice conn =
-  fmap head $ liftIO $ runInsert_ conn $ Insert
-    { iTable = amountTable
-    , iRows  =
-      [
-      ( C.constant pid
-      , C.constant now
-      , C.constant amount
-      , C.constant oldprice
-      , C.constant True
+  -> MateHandler [Int]
+manualProductAmountUpdate aups conn =
+  mapM
+    (\(AmountUpdate pid amount) -> do
+      oldprice <- getLatestPriceByProductId pid conn
+      head <$> (liftIO $ do
+        now <- getCurrentTime
+        runInsert_ conn $ Insert
+          { iTable = amountTable
+          , iRows  =
+            [
+            ( C.constant pid
+            , C.constant now
+            , C.constant amount
+            , C.constant oldprice
+            , C.constant True
+            )
+            ]
+          , iReturning = rReturning (\(id_, _, _, _, _) -> id_)
+          , iOnConflict = Nothing
+          }
+        )
       )
-      ]
-    , iReturning = rReturning (\(id_, _, _, _, _) -> id_)
-    , iOnConflict = Nothing
-    }
+    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

src/Types/Amount.hs

@@ -15,3 +15,15 @@ instance ToJSON AmountUpdate where
   toEncoding = genericToEncoding defaultOptions
 
 instance FromJSON AmountUpdate
+
+
+data AmountRefill = AmountRefill
+  { amountRefillProductId  :: Int
+  , amountRefillAmount     :: Int
+  }
+  deriving (Show, Generic)
+
+instance ToJSON AmountRefill where
+  toEncoding = genericToEncoding defaultOptions
+
+instance FromJSON AmountRefill