2019-12-26 20:36:06 +00:00
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
2019-08-10 08:37:45 +00:00
|
|
|
module Control.Buy where
|
|
|
|
|
2021-07-14 01:08:58 +00:00
|
|
|
import Control.Monad (void, foldM, unless)
|
2019-08-10 08:37:45 +00:00
|
|
|
|
2019-10-14 20:50:42 +00:00
|
|
|
import Control.Monad.Reader (asks)
|
2019-08-10 08:37:45 +00:00
|
|
|
|
2021-07-14 01:08:58 +00:00
|
|
|
import Data.Maybe (fromJust)
|
|
|
|
|
|
|
|
import qualified Data.Text as T
|
|
|
|
|
|
|
|
import Text.Printf (printf)
|
|
|
|
|
2019-08-10 08:37:45 +00:00
|
|
|
-- internal imports
|
|
|
|
|
2019-12-26 08:26:32 +00:00
|
|
|
import Control.User
|
2019-08-10 08:37:45 +00:00
|
|
|
import Types
|
|
|
|
import Model
|
2021-07-14 01:08:58 +00:00
|
|
|
import Util
|
2019-08-10 08:37:45 +00:00
|
|
|
|
|
|
|
buy
|
2019-09-15 12:59:22 +00:00
|
|
|
:: Maybe (Int, AuthMethod)
|
2019-08-10 08:37:45 +00:00
|
|
|
-> [PurchaseDetail]
|
|
|
|
-> MateHandler PurchaseResult
|
2019-10-14 21:34:45 +00:00
|
|
|
buy auth pds = do
|
2019-10-14 20:50:42 +00:00
|
|
|
conn <- asks rsConnection
|
2021-06-10 15:54:57 +00:00
|
|
|
(missing, real) <-
|
|
|
|
foldM
|
|
|
|
(\(ms, rs) pd -> do
|
|
|
|
mmiss <- checkProductAvailability pd conn
|
|
|
|
case mmiss of
|
|
|
|
Just miss -> return
|
|
|
|
-- If there is less items in stock than ordered
|
|
|
|
( (pd {purchaseDetailAmount = miss}):ms
|
|
|
|
-- Add number of missing items
|
|
|
|
, pd {purchaseDetailAmount = max 0 (purchaseDetailAmount pd - miss)}:rs
|
|
|
|
-- purchase remaining items in stock
|
|
|
|
)
|
|
|
|
Nothing -> return
|
|
|
|
-- There are at least as many items in stock as ordered
|
|
|
|
( ms -- Missing items do not change
|
|
|
|
, pd:rs -- Add everything to purchase
|
|
|
|
)
|
2019-08-10 08:37:45 +00:00
|
|
|
)
|
2021-06-10 15:54:57 +00:00
|
|
|
([], [])
|
|
|
|
pds
|
2019-10-14 20:50:42 +00:00
|
|
|
mapM_ (`postBuyProductAmountUpdate` conn) real
|
2019-08-10 08:37:45 +00:00
|
|
|
price <- foldM
|
|
|
|
(\total pd ->
|
|
|
|
fmap (+ total) (getLatestTotalPrice pd conn)
|
|
|
|
)
|
|
|
|
0
|
|
|
|
real
|
2019-10-14 21:34:45 +00:00
|
|
|
case auth of
|
|
|
|
Just (auid, _) -> do
|
|
|
|
void $ addToUserBalance auid (-price) conn
|
|
|
|
newBalance <- userBalanceSelect conn auid
|
2019-12-26 08:26:32 +00:00
|
|
|
userUpdateTimestamp auth
|
2021-02-15 18:00:29 +00:00
|
|
|
let result = PurchaseResult
|
2021-06-09 21:45:43 +00:00
|
|
|
( if newBalance < 0
|
|
|
|
then PurchaseDebtful
|
|
|
|
else PurchaseOK
|
|
|
|
)
|
|
|
|
missing
|
2021-02-15 18:01:15 +00:00
|
|
|
userNotify auth real result
|
2021-02-15 18:00:29 +00:00
|
|
|
return result
|
2019-12-26 20:36:06 +00:00
|
|
|
Nothing -> do
|
|
|
|
void $ insertNewJournalEntry
|
|
|
|
(JournalSubmit
|
2020-05-10 09:29:07 +00:00
|
|
|
Nothing
|
|
|
|
BuyCash
|
2019-12-26 20:36:06 +00:00
|
|
|
price
|
|
|
|
)
|
|
|
|
conn
|
2019-10-14 21:34:45 +00:00
|
|
|
return $ PurchaseResult
|
|
|
|
(PayAmount price)
|
|
|
|
missing
|
2021-07-14 01:08:58 +00:00
|
|
|
|
|
|
|
amountUpdate
|
|
|
|
:: [PurchaseDetail]
|
|
|
|
-> MateHandler ()
|
|
|
|
amountUpdate details = do
|
|
|
|
conn <- asks rsConnection
|
|
|
|
notify <- foldM (\acc pd@(PurchaseDetail pid _) -> do
|
|
|
|
void $ postBuyProductAmountUpdate pd conn
|
|
|
|
newAmout <- getLatestAmountByProductId pid conn
|
|
|
|
minAmout <- productMinAmount . fromJust <$> productSelectSingle pid conn
|
|
|
|
if newAmout < minAmout
|
|
|
|
then return (pid : acc)
|
|
|
|
else return acc
|
|
|
|
)
|
|
|
|
[]
|
|
|
|
details
|
|
|
|
unless (null notify) $
|
|
|
|
do
|
|
|
|
messageText <- T.pack . mconcat . map (<> "\n") . (\insert ->
|
|
|
|
[ printf (__ "Hello,")
|
|
|
|
, ""
|
|
|
|
, printf (__ "Following products are low on stock:")
|
|
|
|
]
|
|
|
|
++
|
|
|
|
insert
|
|
|
|
++
|
|
|
|
[ ""
|
|
|
|
, __ "Please consider ordering and refilling those products."
|
|
|
|
, __ "\nSincerely,\nMateamt"
|
|
|
|
]) <$>
|
|
|
|
mapM
|
|
|
|
(\pid -> do
|
|
|
|
name <- productIdent . fromJust <$> productSelectSingle pid conn
|
|
|
|
amount <- getLatestAmountByProductId pid conn
|
|
|
|
return (printf (__ "%s (Amout remaining: %d)") name amount)
|
|
|
|
)
|
|
|
|
notify
|
|
|
|
sendAdminNotification (__ "Low sotck alert") messageText
|