mateamt/src/Control/Buy.hs

65 lines
1.4 KiB
Haskell
Raw Normal View History

2019-12-26 20:36:06 +00:00
{-# LANGUAGE OverloadedStrings #-}
2019-08-10 08:37:45 +00:00
module Control.Buy where
import Control.Monad (void, foldM)
2019-10-14 20:50:42 +00:00
import Control.Monad.Reader (asks)
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
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
2019-09-07 00:48:16 +00:00
(missing, real) <- foldM (\(ms, rs) pd -> do
2019-08-10 08:37:45 +00:00
mmiss <- checkProductAvailability pd conn
case mmiss of
Just miss -> return
( (pd {purchaseDetailAmount = miss}):ms
2019-10-14 20:50:42 +00:00
, pd {purchaseDetailAmount = max 0 (purchaseDetailAmount pd - miss)}:rs
2019-08-10 08:37:45 +00:00
)
Nothing -> return
( ms
, pd:rs
)
)
([], [])
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
2019-10-14 21:34:45 +00:00
( if newBalance < 0
then PurchaseDebtful
else PurchaseOK
2019-08-10 08:37:45 +00:00
)
2019-10-14 21:34:45 +00:00
missing
2021-02-15 18:00:29 +00:00
userNotify auth result
return result
2019-12-26 20:36:06 +00:00
Nothing -> do
void $ insertNewJournalEntry
(JournalSubmit
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