diff --git a/mateamt.cabal b/mateamt.cabal index a1463b9..67d971e 100644 --- a/mateamt.cabal +++ b/mateamt.cabal @@ -35,6 +35,7 @@ executable mateamt , Types.Refine , Types.User , Types.Purchase + , Types.Amount -- other-extensions: build-depends: base ^>=4.12.0.0 , servant diff --git a/src/API.hs b/src/API.hs index ff0210d..4a3f5b4 100644 --- a/src/API.hs +++ b/src/API.hs @@ -36,7 +36,7 @@ type UserAPI = :<|> "new" :> AuthProtect "header-auth" :> ReqBody '[JSON] ProductSubmit :> Post '[JSON] Int :<|> "update" :> AuthProtect "header-auth" - :> Capture "id" Int :> ReqBody '[JSON] ProductSubmit :> Post '[JSON] () + :> Capture "id" Int :> ReqBody '[JSON] AmountUpdate :> Post '[JSON] () ) :<|> "buy" :> AuthProtect "header-auth" :> ReqBody '[JSON] [PurchaseDetail] :> Post '[JSON] PurchaseResult diff --git a/src/Main.hs b/src/Main.hs index 5b82087..516124d 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -161,14 +161,19 @@ products = new :: Maybe Int -> ProductSubmit -> MateHandler Int new (Just _) bevsub = do conn <- rsConnection <$> ask - head <$> (liftIO $ runInsert_ conn (insertProduct bevsub)) + now <- liftIO $ getCurrentTime + bevid <- head <$> (liftIO $ runInsert_ conn (insertProduct bevsub)) + void $ liftIO $ runInsert_ conn (insertNewEmptyAmount bevid now bevsub) + return bevid new Nothing _ = throwError $ err403 - update :: Maybe Int -> Int -> ProductSubmit -> MateHandler () - update (Just _) bid bevsub = do + update :: Maybe Int -> Int -> AmountUpdate -> MateHandler () + update (Just _) bid amosub = do conn <- rsConnection <$> ask - void $ liftIO $ runUpdate_ conn (updateProduct bid bevsub) + liftIO $ do + now <- getCurrentTime + void $ runInsert_ conn (manualProductAmountUpdate amosub now bid) update Nothing _ _ = throwError $ err403 @@ -176,7 +181,7 @@ buy :: Maybe Int -> [PurchaseDetail] -> MateHandler PurchaseResult buy (Just auid) pds = do conn <- rsConnection <$> ask (missing, real) <- foldM (\acc@(ms, rs) pd -> do - mmiss <- checkProductAvailability conn pd + mmiss <- checkProductAvailability pd conn case mmiss of Just miss -> return ( (pd {pdAmount = miss}):ms @@ -189,8 +194,13 @@ buy (Just auid) pds = do ) ([], []) pds - void$ liftIO $ mapM_ (\pd -> runUpdate_ conn (reduceProductAmount pd)) real - price <- foldM (\total pd -> fmap (+ total) (getProductPrice pd conn)) 0 real + void $ mapM_ (\pd -> postBuyProductAmountUpdate pd conn) real + price <- foldM + (\total pd -> + fmap (+ total) (getLatestTotalPrice pd conn) + ) + 0 + real liftIO $ runUpdate_ conn (addToUserBalance auid (-price)) newBalance <- userBalanceSelect conn auid return $ PurchaseResult @@ -202,7 +212,7 @@ buy (Just auid) pds = do buy Nothing pds = do conn <- rsConnection <$> ask (missing, real) <- foldM (\acc@(ms, rs) pd -> do - mmiss <- checkProductAvailability conn pd + mmiss <- checkProductAvailability pd conn case mmiss of Just miss -> return ( (pd {pdAmount = miss}):ms @@ -215,8 +225,15 @@ buy Nothing pds = do ) ([], []) pds - void $ liftIO $ mapM_ (\pd -> runUpdate_ conn (reduceProductAmount pd)) real - price <- foldM (\total pd -> fmap (+ total) (getProductPrice pd conn)) 0 real + void $ mapM_ + (\pd -> postBuyProductAmountUpdate pd conn) + real + price <- foldM + (\total pd -> + fmap (+ total) (getLatestTotalPrice pd conn) + ) + 0 + real return $ PurchaseResult (PayAmount price) missing diff --git a/src/Model/Amount.hs b/src/Model/Amount.hs index ea0a2e9..dfb0c24 100644 --- a/src/Model/Amount.hs +++ b/src/Model/Amount.hs @@ -1,13 +1,24 @@ {-# LANGUAGE OverloadedStrings #-} 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 import Opaleye.Constant as C +-- internal imports + +import Types + initAmount :: PGS.Query initAmount = mconcat [ "CREATE TABLE IF NOT EXISTS \"amount\" (" @@ -22,13 +33,13 @@ initAmount = mconcat amountTable :: Table ( Field SqlInt4 - , Field SqlDate + , Field SqlTimestamptz , Field SqlInt4 , Field SqlInt4 , Field SqlBool ) ( Field SqlInt4 - , Field SqlDate + , Field SqlTimestamptz , Field SqlInt4 , Field SqlInt4 , Field SqlBool @@ -42,3 +53,143 @@ amountTable = table "amount" ( , tableField "amount_verified" ) ) + +insertNewEmptyAmount + :: Int -- | the associated product id + -> UTCTime -- | current time + -> ProductSubmit -- | submitted product data + -> Insert [Int] +insertNewEmptyAmount bevid now (ProductSubmit _ price _ _ _ _ _ _ _) = 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 + } + +getLatestPriceByProductId + :: Int -- The associated Product ID + -> PGS.Connection + -> MateHandler Int -- The price in cents +getLatestPriceByProductId pid conn = do + amounts <- liftIO $ runSelect conn $ + orderBy (desc (\(_, ts, _, _, _) -> ts)) + (keepWhen (\(id_, _, _, _, _) -> id_ .== C.constant pid) <<< queryTable amountTable) + :: MateHandler + [ ( Int + , UTCTime + , Int + , Int + , Bool + ) + ] + head <$> mapM + (\(_, _, _, price, _) -> return price) + amounts + +getLatestTotalPrice + :: PurchaseDetail -- The associated PurchaseDetail + -> PGS.Connection + -> MateHandler Int -- The price in cents +getLatestTotalPrice (PurchaseDetail pid amount) conn = do + amounts <- liftIO $ runSelect conn $ + orderBy (desc (\(_, ts, _, _, _) -> ts)) $ + keepWhen (\(id_, _, _, _, _) -> id_ .== C.constant pid) <<< + queryTable amountTable + :: MateHandler + [ ( Int + , UTCTime + , Int + , Int + , Bool + ) + ] + (amount *) <$> head <$> mapM + (\(_, _, _, price, _) -> return price) + amounts + +checkProductAvailability + :: PurchaseDetail + -> PGS.Connection + -> MateHandler (Maybe Int) -- | Returns maybe missing amount +checkProductAvailability (PurchaseDetail pid amount) conn = do + realamount <- (\(_, _, ramount, _, _) -> ramount) <$> head <$> + (liftIO $ runSelect conn $ + 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 + +manualProductAmountUpdate + :: AmountUpdate + -> UTCTime -- Current time + -> Int -- Old BeveragePrice + -> Insert [Int] +manualProductAmountUpdate (AmountUpdate pid amount) now oldprice = 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 + } + +postBuyProductAmountUpdate + :: PurchaseDetail + -> PGS.Connection + -> MateHandler Int +postBuyProductAmountUpdate (PurchaseDetail pid pdamount) conn = do + now <- liftIO $ getCurrentTime + (amount, oldprice) <- (\(_, _, am, op, _) -> (am, op)) <$> head <$> ( + liftIO $ runSelect conn $ + 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 + } + ) diff --git a/src/Model/Product.hs b/src/Model/Product.hs index 812a177..50f8930 100644 --- a/src/Model/Product.hs +++ b/src/Model/Product.hs @@ -6,7 +6,7 @@ import Servant.Server import Data.Text as T hiding (head, foldl) import Data.Time.Calendar (Day) -import Data.Profunctor.Product (p13) +import Data.Profunctor.Product (p10) import Data.Aeson import Data.Aeson.Types @@ -35,9 +35,9 @@ initProduct = mconcat [ "create table if not exists \"product\" (" , "product_id serial primary key," , "product_ident varchar(128) not null," - , "product_price integer not null," - , "product_amount integer not null," - , "product_vanish integer not null," + -- , "product_price integer not null," + -- , "product_amount integer not null," + -- , "product_vanish integer not null," , "product_ml integer not null," , "product_avatar integer," , "product_supplier integer," @@ -52,9 +52,9 @@ initProduct = mconcat productTable :: Table ( Maybe (Field SqlInt4) , Field SqlText - , Field SqlInt4 - , Field SqlInt4 - , Field SqlInt4 + -- , Field SqlInt4 + -- , Field SqlInt4 + -- , Field SqlInt4 , Field SqlInt4 , FieldNullable SqlInt4 , FieldNullable SqlInt4 @@ -66,9 +66,9 @@ productTable :: Table ) ( Field SqlInt4 , Field SqlText - , Field SqlInt4 - , Field SqlInt4 - , Field SqlInt4 + -- , Field SqlInt4 + -- , Field SqlInt4 + -- , Field SqlInt4 , Field SqlInt4 , FieldNullable SqlInt4 , FieldNullable SqlInt4 @@ -79,12 +79,12 @@ productTable :: Table , FieldNullable SqlText ) productTable = table "product" ( - p13 + p10 ( tableField "product_id" , tableField "product_ident" - , tableField "product_price" - , tableField "product_amount" - , tableField "product_vanish" + -- , tableField "product_price" + -- , tableField "product_amount" + -- , tableField "product_vanish" , tableField "product_ml" , tableField "product_avatar" , tableField "product_supplier" @@ -105,9 +105,9 @@ productSelect conn = do ) :: MateHandler [ ( Int , T.Text - , Int - , Int - , Int + -- , Int + -- , Int + -- , Int , Int , Maybe Int , Maybe Int @@ -119,86 +119,86 @@ productSelect conn = do ) ] mapM - (\(i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13) -> return $ - Product i1 i2 i3 i4 i5 i6 i7 i8 i9 i10 i11 i12 i13 + (\(i1, i2, {-i3, i4, i5,-} i6, i7, i8, i9, i10, i11, i12, i13) -> return $ + Product i1 i2 {-i3 i4 i5-} i6 i7 i8 i9 i10 i11 i12 i13 ) bevs -getProductPrice - :: PurchaseDetail - -> PGS.Connection - -> MateHandler Int -getProductPrice (PurchaseDetail bid amount) conn = do - when (amount < 0) ( - throwError $ err406 - { errBody = "Amounts less or equal zero are not acceptable" - } - ) - bevs <- liftIO $ runSelect conn - ( keepWhen - (\(id_, _, _, _, _, _, _, _, _, _, _, _, _) -> id_ .== C.constant bid) <<< - queryTable productTable - ) :: MateHandler - [ ( Int - , T.Text - , Int - , Int - , Int - , Int - , Maybe Int - , Maybe Int - , Int - , Int - , Int - , Maybe Int - , Maybe T.Text - ) - ] - (amount *) <$> head <$> mapM - (\(i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13) -> return $ - i3 - ) - bevs +-- getProductPrice +-- :: PurchaseDetail +-- -> PGS.Connection +-- -> MateHandler Int +-- getProductPrice (PurchaseDetail bid amount) conn = do +-- when (amount < 0) ( +-- throwError $ err406 +-- { errBody = "Amounts less or equal zero are not acceptable" +-- } +-- ) +-- bevs <- liftIO $ runSelect conn +-- ( keepWhen +-- (\(id_, _, _, _, _, _, _, _, _, _, _) -> id_ .== C.constant bid) <<< +-- queryTable productTable +-- ) :: MateHandler +-- [ ( Int +-- , T.Text +-- -- , Int +-- -- , Int +-- , Int +-- , Int +-- , Maybe Int +-- , Maybe Int +-- , Int +-- , Int +-- , Int +-- , Maybe Int +-- , Maybe T.Text +-- ) +-- ] +-- (amount *) <$> head <$> mapM +-- (\(i1, i2, {-i3, i4,-} i5, i6, i7, i8, i9, i10, i11, i12, i13) -> return $ +-- i3 +-- ) +-- bevs -checkProductAvailability - :: PGS.Connection - -> PurchaseDetail - -> MateHandler (Maybe Int) -- | returns maybe missing amount -checkProductAvailability conn (PurchaseDetail bid amount) = do - when (amount <= 0) $ - throwError $ err406 - { errBody = "Amounts less or equal zero are not acceptable" - } - bevs <- liftIO $ runSelect conn - ( keepWhen - (\(id_, _, _, _, _, _, _, _, _, _, _, _, _) -> id_ .== C.constant bid) <<< - queryTable productTable - ) :: MateHandler - [ ( Int - , T.Text - , Int - , Int - , Int - , Int - , Maybe Int - , Maybe Int - , Int - , Int - , Int - , Maybe Int - , Maybe T.Text - ) - ] - realamount <- head <$> mapM - (\(i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13) -> return $ - i4 - ) - bevs - if realamount < amount - then return (Just (amount - realamount)) - else return Nothing +-- checkProductAvailability +-- :: PGS.Connection +-- -> PurchaseDetail +-- -> MateHandler (Maybe Int) -- | returns maybe missing amount +-- checkProductAvailability conn (PurchaseDetail bid amount) = do +-- when (amount <= 0) $ +-- throwError $ err406 +-- { errBody = "Amounts less or equal zero are not acceptable" +-- } +-- bevs <- liftIO $ runSelect conn +-- ( keepWhen +-- (\(id_, _, _, _, _, _, _, _, _, _, _) -> id_ .== C.constant bid) <<< +-- queryTable productTable +-- ) :: MateHandler +-- [ ( Int +-- , T.Text +-- , Int +-- -- , Int +-- -- , Int +-- , Int +-- , Maybe Int +-- , Maybe Int +-- , Int +-- , Int +-- , Int +-- , Maybe Int +-- , Maybe T.Text +-- ) +-- ] +-- realamount <- head <$> mapM +-- (\(i1, i2, i3, {-i4, i5,-} i6, i7, i8, i9, i10, i11, i12, i13) -> return $ +-- i4 +-- ) +-- bevs +-- if realamount < amount +-- then return (Just (amount - realamount)) +-- else return Nothing insertProduct @@ -210,9 +210,9 @@ insertProduct (ProductSubmit ident price ml ava sup max apc ppc artnr) = Insert [ ( C.constant (Nothing :: Maybe Int) , C.constant ident - , C.constant price - , C.constant (0 :: Int) - , C.constant (0 :: Int) + -- , C.constant price + -- , C.constant (0 :: Int) + -- , C.constant (0 :: Int) , C.constant ml , C.constant ava , C.constant sup @@ -223,65 +223,65 @@ insertProduct (ProductSubmit ident price ml ava sup max apc ppc artnr) = Insert , C.constant artnr ) ] - , iReturning = rReturning (\(id, _, _, _, _, _, _, _, _, _, _, _, _) -> id) + , iReturning = rReturning (\(id, _, _, _, _, _, _, _, _, _) -> id) , iOnConflict = Nothing } -updateProduct - :: Int - -> ProductSubmit - -> Update Int64 -updateProduct sid (ProductSubmit ident price ml ava sup max apc ppc artnr) = Update - { uTable = productTable - , uUpdateWith = updateEasy (\(id_, _, _, amo, van, _, _, _, _, tot, _, _, _) -> - ( id_ - , C.constant ident - , C.constant price - , amo - , van - , C.constant ml - , C.constant ava - , C.constant sup - , C.constant max - , tot - , C.constant apc - , C.constant ppc - , C.constant artnr - ) - ) - , uWhere = - (\(id_, _, _, _, _, _, _, _, _, _, _, _, _) -> - id_ .== C.constant sid - ) - , uReturning = rCount - } +-- updateProduct +-- :: Int +-- -> ProductSubmit +-- -> Update Int64 +-- updateProduct sid (ProductSubmit ident price ml ava sup max apc ppc artnr) = Update +-- { uTable = productTable +-- , uUpdateWith = updateEasy (\(id_, _, _, amo, van, _, _, _, _, tot, _, _, _) -> +-- ( id_ +-- , C.constant ident +-- , C.constant price +-- , amo +-- , van +-- , C.constant ml +-- , C.constant ava +-- , C.constant sup +-- , C.constant max +-- , tot +-- , C.constant apc +-- , C.constant ppc +-- , C.constant artnr +-- ) +-- ) +-- , uWhere = +-- (\(id_, _, _, _, _, _, _, _, _, _, _, _, _) -> +-- id_ .== C.constant sid +-- ) +-- , uReturning = rCount +-- } -reduceProductAmount - :: PurchaseDetail - -> Update Int64 -reduceProductAmount (PurchaseDetail pid amount) = Update - { uTable = productTable - , uUpdateWith = updateEasy - (\(id_, ident, price, amo, van, ml, ava, sup, max, tot, apc, ppc, artnr) -> - ( id_ - , ident - , price - , amo - C.constant amount - , van - , ml - , ava - , sup - , max - , tot + C.constant amount - , apc - , ppc - , artnr - ) - ) - , uWhere = - (\(id_, _, _, _, _, _, _, _, _, _, _, _, _) -> - id_ .== C.constant pid - ) - , uReturning = rCount - } +-- reduceProductAmount +-- :: PurchaseDetail +-- -> Update Int64 +-- reduceProductAmount (PurchaseDetail pid amount) = Update +-- { uTable = productTable +-- , uUpdateWith = updateEasy +-- (\(id_, ident, price, amo, van, ml, ava, sup, max, tot, apc, ppc, artnr) -> +-- ( id_ +-- , ident +-- , price +-- , amo - C.constant amount +-- , van +-- , ml +-- , ava +-- , sup +-- , max +-- , tot + C.constant amount +-- , apc +-- , ppc +-- , artnr +-- ) +-- ) +-- , uWhere = +-- (\(id_, _, _, _, _, _, _, _, _, _, _, _, _) -> +-- id_ .== C.constant pid +-- ) +-- , uReturning = rCount +-- } diff --git a/src/Types.hs b/src/Types.hs index f302c75..3d738d1 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -8,3 +8,4 @@ import Types.Refine as T import Types.Reader as T import Types.User as T import Types.Purchase as T +import Types.Amount as T diff --git a/src/Types/Amount.hs b/src/Types/Amount.hs new file mode 100644 index 0000000..9ec8445 --- /dev/null +++ b/src/Types/Amount.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE DeriveGeneric #-} +module Types.Amount where + +import GHC.Generics + +import Data.Aeson + +data AmountUpdate = AmountUpdate + { amountUpdateProductId :: Int + , amountUpdateRealAmount :: Int + } + deriving (Show, Generic) + +instance ToJSON AmountUpdate where + toEncoding = genericToEncoding defaultOptions + +instance FromJSON AmountUpdate diff --git a/src/Types/Auth.hs b/src/Types/Auth.hs index 0df941e..2e5017a 100644 --- a/src/Types/Auth.hs +++ b/src/Types/Auth.hs @@ -32,6 +32,7 @@ data AuthInfo = AuthInfo deriving (Show, Generic) instance ToJSON AuthInfo where + toEncoding = genericToEncoding defaultOptions instance FromJSON AuthInfo diff --git a/src/Types/Product.hs b/src/Types/Product.hs index 8b15601..e601683 100644 --- a/src/Types/Product.hs +++ b/src/Types/Product.hs @@ -10,9 +10,9 @@ import qualified Data.Text as T data Product = Product { productId :: Int , productIdent :: T.Text - , productPrice :: Int - , productAmount :: Int - , productVanish :: Int + -- , productPrice :: Int + -- , productAmount :: Int + -- , productVanish :: Int , productMl :: Int , productAvatar :: Maybe Int , productSupplier :: Maybe Int