mateamt/src/Control/Product.hs

122 lines
3.1 KiB
Haskell
Raw Normal View History

2019-08-14 16:04:16 +00:00
{-# LANGUAGE OverloadedStrings #-}
module Control.Product where
import Servant
2022-07-30 23:43:46 +00:00
import Control.Monad
2019-08-14 16:04:16 +00:00
2019-10-14 20:50:42 +00:00
import Control.Monad.Reader (asks)
2019-08-14 16:04:16 +00:00
2020-09-16 15:54:42 +00:00
import Control.Monad.Extra (anyM, allM)
2020-09-16 15:54:42 +00:00
import Data.Maybe (fromMaybe, isJust)
2019-09-09 11:17:43 +00:00
2019-08-14 16:04:16 +00:00
-- internal imports
import Types
import Model
2022-04-15 19:06:18 +00:00
import Util
2019-08-14 16:04:16 +00:00
2019-09-15 12:59:22 +00:00
productNew
:: Maybe (Int, AuthMethod)
-> ProductSubmit
-> MateHandler Int
productNew (Just (uid, auth)) bevsub = do
mayAddProduct <- checkCapability uid roleCanManageProducts
2022-07-30 23:43:46 +00:00
unless mayAddProduct throwUnauthAccess
if auth `elem` [PrimaryPass, ChallengeResponse]
then do
conn <- asks rsConnection
bevid <- insertProduct bevsub conn
void $ insertNewEmptyAmount bevid bevsub conn
return bevid
else
2022-07-30 23:43:46 +00:00
throwWrongAuth
2019-08-14 16:04:16 +00:00
productNew Nothing _ =
2022-07-30 23:43:46 +00:00
throwMissingAuth
2019-08-14 16:04:16 +00:00
2021-06-16 16:09:08 +00:00
productOverview
:: Int
-> MateHandler ProductOverview
productOverview pid = do
conn <- asks rsConnection
productOverviewSelectSingle pid conn
2019-08-14 16:04:16 +00:00
2019-09-15 12:59:22 +00:00
productStockRefill
:: Maybe (Int, AuthMethod)
-> [AmountRefill]
2022-07-17 19:28:22 +00:00
-> MateHandler NoContent
productStockRefill (Just (uid, auth)) amorefs = do
mayRefill <- anyM
(checkCapability uid)
[ roleCanRefillStock, roleCanManageProducts ]
2022-07-30 23:43:46 +00:00
unless mayRefill throwUnauthAccess
if auth `elem` [PrimaryPass, ChallengeResponse]
then do
conn <- asks rsConnection
2020-09-16 15:54:42 +00:00
let prods = map
(\refill -> productSelectSingle (amountRefillProductId refill) conn)
amorefs
allProdsExist <- allM (fmap isJust) prods
if allProdsExist
then
if
all
(\refill ->
(>= 0) (amountRefillAmountSingles refill) &&
(>= 0) (amountRefillAmountCrates refill)
)
amorefs
then do
void $ manualProductAmountRefill amorefs conn
2022-07-17 19:28:22 +00:00
return NoContent
else
throwError $ err400
{ errBody = "Amounts less than 0 are not acceptable."
}
2019-12-14 23:03:49 +00:00
else
throwError $ err400
{ errBody = "Non-existent Products are non-refillable."
2019-12-14 23:03:49 +00:00
}
2019-08-14 16:04:16 +00:00
else
2022-07-30 23:43:46 +00:00
throwUnauthAccess
2019-08-14 16:04:16 +00:00
productStockRefill Nothing _ =
2022-07-30 23:43:46 +00:00
throwMissingAuth
2019-08-14 16:04:16 +00:00
2019-09-15 12:59:22 +00:00
productStockUpdate
:: Maybe (Int, AuthMethod)
-> [AmountUpdate]
2022-07-17 19:28:22 +00:00
-> MateHandler NoContent
productStockUpdate (Just (uid, method)) amoups = do
mayUpdateStock <- checkCapability uid roleCanManageProducts
2022-07-30 23:43:46 +00:00
unless mayUpdateStock throwUnauthAccess
if method `elem` [PrimaryPass, ChallengeResponse]
2019-12-13 22:48:09 +00:00
then
if all ((>= 0) . amountUpdateRealAmount) amoups
then do
conn <- asks rsConnection
void $ manualProductAmountUpdate amoups conn
2022-07-17 19:28:22 +00:00
return NoContent
2019-12-13 22:48:09 +00:00
else
throwError $ err400
{ errBody = "Amounts less than 0 are not acceptable."
}
2019-08-14 16:04:16 +00:00
else
2022-07-30 23:43:46 +00:00
throwWrongAuth
2019-08-14 16:04:16 +00:00
productStockUpdate Nothing _ =
2022-07-30 23:43:46 +00:00
throwMissingAuth
2019-08-14 16:04:16 +00:00
2019-09-15 12:59:22 +00:00
productList
:: Maybe ProductRefine
-> MateHandler [ProductOverview]
2019-09-09 10:57:08 +00:00
productList mrefine = do
2019-10-14 20:50:42 +00:00
conn <- asks rsConnection
2019-09-09 10:57:08 +00:00
productOverviewSelect (fromMaybe AvailableProducts mrefine) conn
productShortList
:: Maybe ProductRefine
-> MateHandler [ProductShortOverview]
productShortList mrefine = do
2019-10-14 20:50:42 +00:00
conn <- asks rsConnection
productShortOverviewSelect (fromMaybe AvailableProducts mrefine) conn