{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Arrows #-} module Model.Amount where import Data.Time.Clock (getCurrentTime) import Data.Time (UTCTime) import Data.Profunctor.Product (p5) import qualified Database.PostgreSQL.Simple as PGS import Control.Arrow import Control.Monad.IO.Class (liftIO) import Opaleye as O -- internal imports import Types import Classes initAmount :: PGS.Query initAmount = mconcat [ "CREATE TABLE IF NOT EXISTS \"amount\" (" , "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)" , ")" ] amountTable :: Table ( Field SqlInt4 , Field SqlTimestamptz , Field SqlInt4 , Field SqlInt4 , Field SqlBool ) ( Field SqlInt4 , Field SqlTimestamptz , Field SqlInt4 , Field SqlInt4 , Field SqlBool ) amountTable = table "amount" ( p5 ( tableField "amount_product_id" , tableField "amount_timestamp" , tableField "amount_amount" , tableField "amount_price" , tableField "amount_verified" ) ) insertNewEmptyAmount :: Int -- ^ the associated product id -> ProductSubmit -- ^ submitted product data -> PGS.Connection -> MateHandler Int insertNewEmptyAmount bevid (ProductSubmit _ price _ _ _ _ _ _ _ _) conn = liftIO $ do now_ <- getCurrentTime fmap head $ runInsert_ conn $ Insert { iTable = amountTable , iRows = [ ( toFields bevid , toFields now_ , toFields (0 :: Int) , toFields price , toFields False ) ] , iReturning = rReturning (\(id_, _, _, _, _) -> id_) , iOnConflict = Nothing } getLatestPriceByProductId :: Int -- The associated Product ID -> PGS.Connection -> MateHandler Int -- The price in cents getLatestPriceByProductId pid conn = do liftIO $ amountPrice . fromDatabase . head <$> runSelect conn (proc () -> do stuff@(id_, _, _, _, _) <- limit 1 (orderBy (desc (\(_, ts, _, _, _) -> ts)) (selectTable amountTable)) -< () restrict -< id_ .== toFields pid returnA -< stuff ) getLatestAmountByProductId :: Int -- The associated Product ID -> PGS.Connection -> MateHandler Int -- The amount getLatestAmountByProductId pid conn = do liftIO $ amountAmount . fromDatabase . head <$> runSelect conn ( proc () -> do stuff@(id_, _, _, _, _) <- limit 1 (orderBy (desc (\(_, ts, _, _, _) -> ts)) (selectTable amountTable)) -< () restrict -< id_ .== toFields pid returnA -< stuff ) getLatestTotalPrice :: PurchaseDetail -- The associated PurchaseDetail -> PGS.Connection -> MateHandler Int -- The price in cents getLatestTotalPrice (PurchaseDetail pid amount) conn = do liftIO $ (amount *) . amountPrice . fromDatabase . head <$> runSelect conn (proc () -> do stuff@(id_, _, _, _, _) <- limit 1 (orderBy (desc (\(_, ts, _, _, _) -> ts)) (selectTable amountTable)) -< () restrict -< id_ .== toFields pid returnA -< stuff) checkProductAvailability :: PurchaseDetail -> PGS.Connection -> MateHandler (Maybe Int) -- ^ Returns maybe missing amount checkProductAvailability (PurchaseDetail pid amount) conn = do realamount <- amountAmount . fromDatabase . head <$> liftIO (runSelect conn $ proc () -> do stuff@(id_, _, _, _, _) <- limit 1 (orderBy (desc (\(_, ts, _, _, _) -> ts)) (selectTable amountTable)) -< () restrict -< id_ .== toFields pid returnA -< stuff ) if realamount < amount then return (Just $ amount - realamount) else return Nothing manualProductAmountUpdate :: [AmountUpdate] -> PGS.Connection -> MateHandler [Int] manualProductAmountUpdate aups conn = mapM (\(AmountUpdate pid amount) -> do oldprice <- getLatestPriceByProductId pid conn head <$> liftIO (do now_ <- getCurrentTime runInsert_ conn $ Insert { iTable = amountTable , iRows = [ ( toFields pid , toFields now_ , toFields amount , toFields oldprice , toFields True ) ] , iReturning = rReturning (\(id_, _, _, _, _) -> id_) , iOnConflict = Nothing } ) ) aups postBuyProductAmountUpdate :: PurchaseDetail -> PGS.Connection -> MateHandler Int postBuyProductAmountUpdate (PurchaseDetail pid pdamount) conn = do now_ <- liftIO getCurrentTime (amount, oldprice) <- (\am -> (amountAmount am, amountPrice am)) . fromDatabase . head <$> ( liftIO $ runSelect conn (proc () -> do stuff@(id_, _, _, _, _) <- limit 1 (orderBy (desc (\(_, ts, _, _, _) -> ts)) (selectTable amountTable)) -< () restrict -< id_ .== toFields pid returnA -< stuff) :: MateHandler [ ( Int , UTCTime , Int , Int , Bool ) ] ) liftIO $ head <$> runInsert_ conn (Insert { iTable = amountTable , iRows = [ ( toFields pid , toFields now_ , toFields (amount - pdamount) , toFields oldprice , toFields False ) ] , iReturning = rReturning (\(id_, _, _, _, _) -> id_) , iOnConflict = Nothing } )