commence cotrolify

This commit is contained in:
nek0 2019-08-10 10:37:45 +02:00
parent ad33804096
commit 07bd9abde3
5 changed files with 112 additions and 61 deletions

View File

@ -23,6 +23,9 @@ flag develop
executable mateamt
main-is: Main.hs
other-modules: API
, Control
, Control.Buy
, Control.Journal
, Model
, Model.User
, Model.Product

6
src/Control.hs Normal file
View File

@ -0,0 +1,6 @@
module Control
( module C
) where
import Control.Buy as C
import Control.Journal as C

78
src/Control/Buy.hs Normal file
View File

@ -0,0 +1,78 @@
{-# LANGUAGE OverloadedStrings #-}
module Control.Buy where
import Servant
import Control.Monad (void, foldM)
import Control.Monad.Reader (ask)
-- internal imports
import Types
import Model
buy
:: Maybe Int
-> [PurchaseDetail]
-> MateHandler PurchaseResult
buy (Just auid) pds = do
conn <- rsConnection <$> ask
(missing, real) <- foldM (\acc@(ms, rs) pd -> do
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
addToUserBalance auid (-price) conn
newBalance <- userBalanceSelect conn auid
return $ PurchaseResult
( if newBalance < 0
then PurchaseDebtful
else PurchaseOK
)
missing
buy Nothing pds = do
conn <- rsConnection <$> ask
(missing, real) <- foldM (\acc@(ms, rs) pd -> do
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

24
src/Control/Journal.hs Normal file
View File

@ -0,0 +1,24 @@
{-# LANGUAGE OverloadedStrings #-}
module Control.Journal where
import Servant
import Control.Monad.Reader (ask)
-- internal imports
import Types
import Model.Journal
journalShow
:: Maybe Int
-> Maybe Int
-> Maybe Int
-> MateHandler [JournalEntry]
journalShow (Just _) mlimit moffset = do
conn <- rsConnection <$> ask
selectJournalEntries mlimit moffset conn
journalShow Nothing _ _ =
throwError $ err403
{ errBody = "No Authentication present"
}

View File

@ -39,6 +39,7 @@ import API
import Model as M
import Types
import Control
main :: IO ()
main = do
@ -229,64 +230,3 @@ productList :: MateHandler [ProductOverview]
productList = do
conn <- rsConnection <$> ask
productOverviewSelect conn
buy (Just auid) pds = do
conn <- rsConnection <$> ask
(missing, real) <- foldM (\acc@(ms, rs) pd -> do
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
addToUserBalance auid (-price) conn
newBalance <- userBalanceSelect conn auid
return $ PurchaseResult
( if newBalance < 0
then PurchaseDebtful
else PurchaseOK
)
missing
buy Nothing pds = do
conn <- rsConnection <$> ask
(missing, real) <- foldM (\acc@(ms, rs) pd -> do
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
return $ PurchaseResult
(PayAmount price)
missing