diff --git a/src/API.hs b/src/API.hs index 552e829..8659908 100644 --- a/src/API.hs +++ b/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 diff --git a/src/Main.hs b/src/Main.hs index 7191f03..39b8ee4 100644 --- a/src/Main.hs +++ b/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 diff --git a/src/Model/Amount.hs b/src/Model/Amount.hs index 9f3123f..94873ff 100644 --- a/src/Model/Amount.hs +++ b/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 diff --git a/src/Types/Amount.hs b/src/Types/Amount.hs index 9ec8445..841711f 100644 --- a/src/Types/Amount.hs +++ b/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