proceed with amounts implementation

This commit is contained in:
nek0 2019-07-27 16:34:28 +02:00
parent 56eff113c3
commit ece76fe5de
9 changed files with 355 additions and 167 deletions

View File

@ -35,6 +35,7 @@ executable mateamt
, Types.Refine
, Types.User
, Types.Purchase
, Types.Amount
-- other-extensions:
build-depends: base ^>=4.12.0.0
, servant

View File

@ -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

View File

@ -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

View File

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

View File

@ -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
-- }

View File

@ -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

17
src/Types/Amount.hs Normal file
View File

@ -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

View File

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

View File

@ -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