mateamt/src/Control/Buy.hs

77 lines
1.8 KiB
Haskell
Raw Normal View History

2019-08-10 08:37:45 +00:00
{-# LANGUAGE OverloadedStrings #-}
module Control.Buy where
import Control.Monad (void, foldM)
import Control.Monad.Reader (ask)
-- internal imports
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-09-15 12:59:22 +00:00
buy (Just (auid, _)) pds = do
2019-08-10 08:37:45 +00:00
conn <- rsConnection <$> ask
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
, (pd {purchaseDetailAmount = max 0 (purchaseDetailAmount pd - miss)}:rs)
)
Nothing -> return
( ms
, pd:rs
)
)
([], [])
pds
void $ mapM_ (\pd -> postBuyProductAmountUpdate pd conn) real
price <- foldM
(\total pd ->
fmap (+ total) (getLatestTotalPrice pd conn)
)
0
real
2019-09-07 00:48:16 +00:00
void $ addToUserBalance auid (-price) conn
2019-08-10 08:37:45 +00:00
newBalance <- userBalanceSelect conn auid
return $ PurchaseResult
( if newBalance < 0
then PurchaseDebtful
else PurchaseOK
)
missing
buy Nothing pds = do
conn <- rsConnection <$> ask
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
, (pd {purchaseDetailAmount = max 0 (purchaseDetailAmount pd - miss)}:rs)
)
Nothing -> return
( ms
, pd:rs
)
)
([], [])
pds
void $ mapM_
(\pd -> postBuyProductAmountUpdate pd conn)
real
price <- foldM
(\total pd ->
fmap (+ total) (getLatestTotalPrice pd conn)
)
0
real
void $ insertNewJournalEntry (JournalSubmit "Cash purchase" price) conn
return $ PurchaseResult
(PayAmount price)
missing