mateamt/src/Model/Amount.hs

261 lines
6.5 KiB
Haskell
Raw Normal View History

2019-07-21 12:53:00 +00:00
{-# LANGUAGE OverloadedStrings #-}
2019-07-21 12:40:49 +00:00
module Model.Amount where
2019-07-27 14:34:28 +00:00
import Data.Time.Clock (getCurrentTime)
import Data.Time (UTCTime)
2019-07-21 12:40:49 +00:00
import Data.Profunctor.Product (p5)
import qualified Database.PostgreSQL.Simple as PGS
2019-07-27 14:34:28 +00:00
import Control.Arrow ((<<<))
import Control.Monad.IO.Class (liftIO)
2019-07-21 12:40:49 +00:00
import Opaleye as O
import Opaleye.Constant as C
2019-07-27 14:34:28 +00:00
-- internal imports
import Types
2019-07-21 12:40:49 +00:00
initAmount :: PGS.Query
2019-07-21 14:05:31 +00:00
initAmount = mconcat
2019-07-21 12:40:49 +00:00
[ "CREATE TABLE IF NOT EXISTS \"amount\" ("
2019-07-21 14:39:23 +00:00
, "amount_product_id BIGINT NOT NULL REFERENCES \"product\"(\"product_id\") ON DELETE CASCADE,"
, "amount_timestamp TIMESTAMPTZ NOT NULL,"
, "amount_amount INTEGER NOT NULL,"
, "amount_price INTEGER NOT NULL,"
, "amount_verified BOOLEAN NOT NULL,"
, "PRIMARY KEY (amount_product_id, amount_timestamp)"
2019-07-21 14:14:18 +00:00
, ")"
2019-07-21 12:40:49 +00:00
]
amountTable :: Table
( Field SqlInt4
2019-07-27 14:34:28 +00:00
, Field SqlTimestamptz
2019-07-21 12:40:49 +00:00
, Field SqlInt4
, Field SqlInt4
, Field SqlBool
)
( Field SqlInt4
2019-07-27 14:34:28 +00:00
, Field SqlTimestamptz
2019-07-21 12:40:49 +00:00
, Field SqlInt4
, Field SqlInt4
, Field SqlBool
)
amountTable = table "amount" (
p5
2019-07-27 12:05:00 +00:00
( tableField "amount_product_id"
2019-07-21 14:39:23 +00:00
, tableField "amount_timestamp"
, tableField "amount_amount"
, tableField "amount_price"
, tableField "amount_verified"
2019-07-21 12:40:49 +00:00
)
2019-07-21 12:53:00 +00:00
)
2019-07-27 14:34:28 +00:00
insertNewEmptyAmount
:: Int -- | the associated product id
-> ProductSubmit -- | submitted product data
2019-07-28 09:55:22 +00:00
-> PGS.Connection
-> MateHandler Int
2019-08-09 18:55:40 +00:00
insertNewEmptyAmount bevid (ProductSubmit _ price _ _ _ _ _ _ _) conn =
liftIO $ do
now <- getCurrentTime
fmap head $ runInsert_ conn $ Insert
{ iTable = amountTable
, iRows =
[
( C.constant bevid
, C.constant now
, C.constant (0 :: Int)
, C.constant price
, C.constant False
)
]
, iReturning = rReturning (\(id_, _, _, _, _) -> id_)
, iOnConflict = Nothing
}
2019-07-27 14:34:28 +00:00
getLatestPriceByProductId
:: Int -- The associated Product ID
-> PGS.Connection
-> MateHandler Int -- The price in cents
getLatestPriceByProductId pid conn = do
amounts <- liftIO $ runSelect conn $
2019-08-09 18:55:57 +00:00
limit 1 $ orderBy (desc (\(_, ts, _, _, _) -> ts))
2019-07-27 14:34:28 +00:00
(keepWhen (\(id_, _, _, _, _) -> id_ .== C.constant pid) <<< queryTable amountTable)
:: MateHandler
[ ( Int
, UTCTime
, Int
, Int
, Bool
)
]
head <$> mapM
(\(_, _, _, price, _) -> return price)
amounts
getLatestAmountByProductId
:: Int -- The associated Product ID
-> PGS.Connection
-> MateHandler Int -- The amount
getLatestAmountByProductId pid conn = do
amounts <- liftIO $ runSelect conn $
2019-08-09 18:55:57 +00:00
limit 1 $ orderBy (desc (\(_, ts, _, _, _) -> ts))
(keepWhen (\(id_, _, _, _, _) -> id_ .== C.constant pid) <<< queryTable amountTable)
:: MateHandler
[ ( Int
, UTCTime
, Int
, Int
, Bool
)
]
head <$> return ( map
(\(_, _, amount, _, _) -> amount)
amounts
)
2019-07-27 14:34:28 +00:00
getLatestTotalPrice
:: PurchaseDetail -- The associated PurchaseDetail
-> PGS.Connection
-> MateHandler Int -- The price in cents
getLatestTotalPrice (PurchaseDetail pid amount) conn = do
amounts <- liftIO $ runSelect conn $
2019-08-09 18:55:57 +00:00
limit 1 $ orderBy (desc (\(_, ts, _, _, _) -> ts)) $
2019-07-27 14:34:28 +00:00
keepWhen (\(id_, _, _, _, _) -> id_ .== C.constant pid) <<<
queryTable amountTable
:: MateHandler
[ ( Int
, UTCTime
, Int
, Int
, Bool
)
]
2019-10-14 20:50:42 +00:00
(amount *) . head <$> return (map
(\(_, _, _, price, _) -> price)
2019-07-27 14:34:28 +00:00
amounts
)
2019-07-27 14:34:28 +00:00
checkProductAvailability
:: PurchaseDetail
-> PGS.Connection
-> MateHandler (Maybe Int) -- | Returns maybe missing amount
checkProductAvailability (PurchaseDetail pid amount) conn = do
2019-10-14 20:50:42 +00:00
realamount <- (\(_, _, ramount, _, _) -> ramount) . head <$>
2019-08-09 18:55:57 +00:00
(liftIO $ runSelect conn $ limit 1 $
2019-07-27 14:34:28 +00:00
orderBy (desc (\(_, ts, _, _, _) -> ts)) $
keepWhen (\(id_, _, _, _, _) -> id_ .== C.constant pid) <<<
queryTable amountTable
:: MateHandler
[ ( Int
, UTCTime
, Int
, Int
, Bool
)
]
)
if realamount < amount
then return (Just $ amount - realamount)
else return Nothing
2019-07-27 14:34:28 +00:00
manualProductAmountUpdate
:: [AmountUpdate]
2019-07-28 09:55:22 +00:00
-> PGS.Connection
-> MateHandler [Int]
manualProductAmountUpdate aups conn =
mapM
(\(AmountUpdate pid amount) -> do
oldprice <- getLatestPriceByProductId pid conn
2019-10-14 20:50:42 +00:00
head <$> liftIO (do
now <- getCurrentTime
runInsert_ conn $ Insert
{ iTable = amountTable
, iRows =
[
( C.constant pid
, C.constant now
, C.constant amount
, C.constant oldprice
, C.constant True
)
]
, iReturning = rReturning (\(id_, _, _, _, _) -> id_)
, iOnConflict = Nothing
}
)
2019-07-28 09:55:22 +00:00
)
aups
manualProductAmountRefill
:: [AmountRefill]
-> PGS.Connection
-> MateHandler [Int]
manualProductAmountRefill aups conn =
mapM
(\(AmountRefill pid amount) -> do
oldamount <- getLatestAmountByProductId pid conn
oldprice <- getLatestPriceByProductId pid conn
2019-10-14 20:50:42 +00:00
head <$> liftIO (do
now <- getCurrentTime
runInsert_ conn $ Insert
{ iTable = amountTable
, iRows =
[
( C.constant pid
, C.constant now
, C.constant (oldamount + amount)
, C.constant oldprice
, C.constant False
)
]
, iReturning = rReturning (\(id_, _, _, _, _) -> id_)
, iOnConflict = Nothing
}
)
)
aups
2019-07-27 14:34:28 +00:00
postBuyProductAmountUpdate
:: PurchaseDetail
-> PGS.Connection
-> MateHandler Int
postBuyProductAmountUpdate (PurchaseDetail pid pdamount) conn = do
2019-10-14 20:50:42 +00:00
now <- liftIO getCurrentTime
(amount, oldprice) <- (\(_, _, am, op, _) -> (am, op)) . head <$> (
2019-08-09 18:55:57 +00:00
liftIO $ runSelect conn $ limit 1 $
2019-07-27 14:34:28 +00:00
orderBy (desc (\(_, ts, _, _, _) -> ts)) $
keepWhen (\(id_, _, _, _, _) -> id_ .== C.constant pid) <<<
queryTable amountTable
:: MateHandler
[ ( Int
, UTCTime
, Int
, Int
, Bool
)
]
)
liftIO $ head <$> runInsert_ conn (Insert
{ iTable = amountTable
, iRows =
[
( C.constant pid
, C.constant now
, C.constant (amount - pdamount)
, C.constant oldprice
, C.constant False
)
]
, iReturning = rReturning (\(id_, _, _, _, _) -> id_)
, iOnConflict = Nothing
}
)