proceed with amounts implementation

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

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

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 :: Maybe Int -> Int -> AmountUpdate -> MateHandler ()
-    update (Just _) bid bevsub = do
+    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
+  void $ mapM_ (\pd -> postBuyProductAmountUpdate pd conn) real
-  price <- foldM (\total pd -> fmap (+ total) (getProductPrice pd conn)) 0 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
+  void $ mapM_
-  price <- foldM (\total pd -> fmap (+ total) (getProductPrice pd conn)) 0 real
+    (\pd -> postBuyProductAmountUpdate pd conn)
+    real
+  price <- foldM
+    (\total pd ->
+      fmap (+ total) (getLatestTotalPrice pd conn)
+    )
+    0
+    real
   return $ PurchaseResult
     (PayAmount price)
     missing

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
+    }
+    )

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_price integer not null,"
-  , "product_amount integer not null,"
+  -- , "product_amount integer not null,"
-  , "product_vanish 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_price"
-    , tableField "product_amount"
+    -- , tableField "product_amount"
-    , tableField "product_vanish"
+    -- , 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 $
+    (\(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
+      Product i1 i2 {-i3 i4 i5-} i6 i7 i8 i9 i10 i11 i12 i13
       )
     bevs
 
 
-getProductPrice
+-- getProductPrice
-  :: PurchaseDetail
+--   :: PurchaseDetail
-  -> PGS.Connection
+--   -> PGS.Connection
-  -> MateHandler Int
+--   -> MateHandler Int
-getProductPrice (PurchaseDetail bid amount) conn = do
+-- getProductPrice (PurchaseDetail bid amount) conn = do
-  when (amount < 0) (
+--   when (amount < 0) (
-    throwError $ err406
+--     throwError $ err406
-      { errBody = "Amounts less or equal zero are not acceptable"
+--       { errBody = "Amounts less or equal zero are not acceptable"
-      }
+--       }
-    )
+--     )
-  bevs <- liftIO $ runSelect conn
+--   bevs <- liftIO $ runSelect conn
-    ( keepWhen
+--     ( keepWhen
-      (\(id_, _, _, _, _, _, _, _, _, _, _, _, _) -> id_ .== C.constant bid) <<<
+--       (\(id_, _, _, _, _, _, _, _, _, _, _) -> id_ .== C.constant bid) <<<
-        queryTable productTable
+--         queryTable productTable
-    ) :: MateHandler
+--     ) :: MateHandler
-        [ ( Int
+--         [ ( Int
-          , T.Text
+--           , T.Text
-          , Int
+--           -- , Int
-          , Int
+--           -- , Int
-          , Int
+--           , Int
-          , Int
+--           , Int
-          , Maybe Int
+--           , Maybe Int
-          , Maybe Int
+--           , Maybe Int
-          , Int
+--           , Int
-          , Int
+--           , Int
-          , Int
+--           , Int
-          , Maybe Int
+--           , Maybe Int
-          , Maybe T.Text
+--           , Maybe T.Text
-          )
+--           )
-        ]
+--         ]
-  (amount *) <$> head <$> mapM
+--   (amount *) <$> head <$> mapM
-    (\(i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13) -> return $
+--     (\(i1, i2, {-i3, i4,-} i5, i6, i7, i8, i9, i10, i11, i12, i13) -> return $
-      i3
+--       i3
-      )
+--       )
-    bevs
+--     bevs
 
 
-checkProductAvailability
+-- checkProductAvailability
-  :: PGS.Connection
+--   :: PGS.Connection
-  -> PurchaseDetail
+--   -> PurchaseDetail
-  -> MateHandler (Maybe Int) -- | returns maybe missing amount
+--   -> MateHandler (Maybe Int) -- | returns maybe missing amount
-checkProductAvailability conn (PurchaseDetail bid amount) = do
+-- checkProductAvailability conn (PurchaseDetail bid amount) = do
-  when (amount <= 0) $
+--   when (amount <= 0) $
-    throwError $ err406
+--     throwError $ err406
-      { errBody = "Amounts less or equal zero are not acceptable"
+--       { errBody = "Amounts less or equal zero are not acceptable"
-      }
+--       }
-  bevs <- liftIO $ runSelect conn
+--   bevs <- liftIO $ runSelect conn
-    ( keepWhen
+--     ( keepWhen
-      (\(id_, _, _, _, _, _, _, _, _, _, _, _, _) -> id_ .== C.constant bid) <<<
+--       (\(id_, _, _, _, _, _, _, _, _, _, _) -> id_ .== C.constant bid) <<<
-        queryTable productTable
+--         queryTable productTable
-    ) :: MateHandler
+--     ) :: MateHandler
-        [ ( Int
+--         [ ( Int
-          , T.Text
+--           , T.Text
-          , Int
+--           , Int
-          , Int
+--           -- , Int
-          , Int
+--           -- , Int
-          , Int
+--           , Int
-          , Maybe Int
+--           , Maybe Int
-          , Maybe Int
+--           , Maybe Int
-          , Int
+--           , Int
-          , Int
+--           , Int
-          , Int
+--           , Int
-          , Maybe Int
+--           , Maybe Int
-          , Maybe T.Text
+--           , Maybe T.Text
-          )
+--           )
-        ]
+--         ]
-  realamount <- head <$> mapM
+--   realamount <- head <$> mapM
-    (\(i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13) -> return $
+--     (\(i1, i2, i3, {-i4, i5,-} i6, i7, i8, i9, i10, i11, i12, i13) -> return $
-      i4
+--       i4
-      )
+--       )
-    bevs
+--     bevs
-  if realamount < amount
+--   if realamount < amount
-  then return (Just (amount - realamount))
+--   then return (Just (amount - realamount))
-  else return Nothing
+--   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 price
-    , C.constant (0 :: Int)
+    -- , C.constant (0 :: Int)
-    , 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
+-- updateProduct
-  :: Int
+--   :: Int
-  -> ProductSubmit
+--   -> ProductSubmit
-  -> Update Int64
+--   -> Update Int64
-updateProduct sid (ProductSubmit ident price ml ava sup max apc ppc artnr) = Update
+-- updateProduct sid (ProductSubmit ident price ml ava sup max apc ppc artnr) = Update
-  { uTable      = productTable
+--   { uTable      = productTable
-  , uUpdateWith = updateEasy (\(id_, _, _, amo, van, _, _, _, _, tot, _, _, _) ->
+--   , uUpdateWith = updateEasy (\(id_, _, _, amo, van, _, _, _, _, tot, _, _, _) ->
-      ( id_
+--       ( id_
-      , C.constant ident
+--       , C.constant ident
-      , C.constant price
+--       , C.constant price
-      , amo
+--       , amo
-      , van
+--       , van
-      , C.constant ml
+--       , C.constant ml
-      , C.constant ava
+--       , C.constant ava
-      , C.constant sup
+--       , C.constant sup
-      , C.constant max
+--       , C.constant max
-      , tot
+--       , tot
-      , C.constant apc
+--       , C.constant apc
-      , C.constant ppc
+--       , C.constant ppc
-      , C.constant artnr
+--       , C.constant artnr
-      )
+--       )
-    )
+--     )
-  , uWhere      =
+--   , uWhere      =
-    (\(id_, _, _, _, _, _, _, _, _, _, _, _, _) ->
+--     (\(id_, _, _, _, _, _, _, _, _, _, _, _, _) ->
-      id_ .== C.constant sid
+--       id_ .== C.constant sid
-    )
+--     )
-  , uReturning = rCount
+--   , uReturning = rCount
-  }
+--   }
 
-reduceProductAmount
+-- reduceProductAmount
-  :: PurchaseDetail
+--   :: PurchaseDetail
-  -> Update Int64
+--   -> Update Int64
-reduceProductAmount (PurchaseDetail pid amount) = Update
+-- reduceProductAmount (PurchaseDetail pid amount) = Update
-  { uTable      = productTable
+--   { uTable      = productTable
-  , uUpdateWith = updateEasy
+--   , uUpdateWith = updateEasy
-    (\(id_, ident, price, amo, van, ml, ava, sup, max, tot, apc, ppc, artnr) ->
+--     (\(id_, ident, price, amo, van, ml, ava, sup, max, tot, apc, ppc, artnr) ->
-      ( id_
+--       ( id_
-      , ident
+--       , ident
-      , price
+--       , price
-      , amo - C.constant amount
+--       , amo - C.constant amount
-      , van
+--       , van
-      , ml
+--       , ml
-      , ava
+--       , ava
-      , sup
+--       , sup
-      , max
+--       , max
-      , tot + C.constant amount
+--       , tot + C.constant amount
-      , apc
+--       , apc
-      , ppc
+--       , ppc
-      , artnr
+--       , artnr
-      )
+--       )
-    )
+--     )
-  , uWhere      = 
+--   , uWhere      = 
-    (\(id_, _, _, _, _, _, _, _, _, _, _, _, _) ->
+--     (\(id_, _, _, _, _, _, _, _, _, _, _, _, _) ->
-      id_ .== C.constant pid
+--       id_ .== C.constant pid
-    )
+--     )
-  , uReturning = rCount
+--   , uReturning = rCount
-  }
+--   }

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

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

src/Types/Auth.hs

@@ -32,6 +32,7 @@ data AuthInfo = AuthInfo
   deriving (Show, Generic)
 
 instance ToJSON AuthInfo where
+  toEncoding = genericToEncoding defaultOptions
 
 instance FromJSON AuthInfo
 

src/Types/Product.hs

@@ -10,9 +10,9 @@ import qualified Data.Text as T
 data Product = Product
   { productId             :: Int
   , productIdent          :: T.Text
-  , productPrice          :: Int
+  -- , productPrice          :: Int
-  , productAmount         :: Int
+  -- , productAmount         :: Int
-  , productVanish         :: Int
+  -- , productVanish         :: Int
   , productMl             :: Int
   , productAvatar         :: Maybe Int
   , productSupplier       :: Maybe Int