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.Refine
, Types.User , Types.User
, Types.Purchase , Types.Purchase
, Types.Amount
-- other-extensions: -- other-extensions:
build-depends: base ^>=4.12.0.0 build-depends: base ^>=4.12.0.0
, servant , servant

View file

@ -36,7 +36,7 @@ type UserAPI =
:<|> "new" :> AuthProtect "header-auth" :> ReqBody '[JSON] ProductSubmit :<|> "new" :> AuthProtect "header-auth" :> ReqBody '[JSON] ProductSubmit
:> Post '[JSON] Int :> Post '[JSON] Int
:<|> "update" :> AuthProtect "header-auth" :<|> "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] :<|> "buy" :> AuthProtect "header-auth" :> ReqBody '[JSON] [PurchaseDetail]
:> Post '[JSON] PurchaseResult :> Post '[JSON] PurchaseResult

View file

@ -161,14 +161,19 @@ products =
new :: Maybe Int -> ProductSubmit -> MateHandler Int new :: Maybe Int -> ProductSubmit -> MateHandler Int
new (Just _) bevsub = do new (Just _) bevsub = do
conn <- rsConnection <$> ask 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 _ = new Nothing _ =
throwError $ err403 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 conn <- rsConnection <$> ask
void $ liftIO $ runUpdate_ conn (updateProduct bid bevsub) liftIO $ do
now <- getCurrentTime
void $ runInsert_ conn (manualProductAmountUpdate amosub now bid)
update Nothing _ _ = update Nothing _ _ =
throwError $ err403 throwError $ err403
@ -176,7 +181,7 @@ buy :: Maybe Int -> [PurchaseDetail] -> MateHandler PurchaseResult
buy (Just auid) pds = do buy (Just auid) pds = do
conn <- rsConnection <$> ask conn <- rsConnection <$> ask
(missing, real) <- foldM (\acc@(ms, rs) pd -> do (missing, real) <- foldM (\acc@(ms, rs) pd -> do
mmiss <- checkProductAvailability conn pd mmiss <- checkProductAvailability pd conn
case mmiss of case mmiss of
Just miss -> return Just miss -> return
( (pd {pdAmount = miss}):ms ( (pd {pdAmount = miss}):ms
@ -189,8 +194,13 @@ buy (Just auid) pds = do
) )
([], []) ([], [])
pds 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)) liftIO $ runUpdate_ conn (addToUserBalance auid (-price))
newBalance <- userBalanceSelect conn auid newBalance <- userBalanceSelect conn auid
return $ PurchaseResult return $ PurchaseResult
@ -202,7 +212,7 @@ buy (Just auid) pds = do
buy Nothing pds = do buy Nothing pds = do
conn <- rsConnection <$> ask conn <- rsConnection <$> ask
(missing, real) <- foldM (\acc@(ms, rs) pd -> do (missing, real) <- foldM (\acc@(ms, rs) pd -> do
mmiss <- checkProductAvailability conn pd mmiss <- checkProductAvailability pd conn
case mmiss of case mmiss of
Just miss -> return Just miss -> return
( (pd {pdAmount = miss}):ms ( (pd {pdAmount = miss}):ms
@ -215,8 +225,15 @@ buy Nothing pds = do
) )
([], []) ([], [])
pds 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 return $ PurchaseResult
(PayAmount price) (PayAmount price)
missing missing

View file

@ -1,13 +1,24 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Model.Amount where module Model.Amount where
import Data.Time.Clock (getCurrentTime)
import Data.Time (UTCTime)
import Data.Profunctor.Product (p5) import Data.Profunctor.Product (p5)
import qualified Database.PostgreSQL.Simple as PGS import qualified Database.PostgreSQL.Simple as PGS
import Control.Arrow ((<<<))
import Control.Monad.IO.Class (liftIO)
import Opaleye as O import Opaleye as O
import Opaleye.Constant as C import Opaleye.Constant as C
-- internal imports
import Types
initAmount :: PGS.Query initAmount :: PGS.Query
initAmount = mconcat initAmount = mconcat
[ "CREATE TABLE IF NOT EXISTS \"amount\" (" [ "CREATE TABLE IF NOT EXISTS \"amount\" ("
@ -22,13 +33,13 @@ initAmount = mconcat
amountTable :: Table amountTable :: Table
( Field SqlInt4 ( Field SqlInt4
, Field SqlDate , Field SqlTimestamptz
, Field SqlInt4 , Field SqlInt4
, Field SqlInt4 , Field SqlInt4
, Field SqlBool , Field SqlBool
) )
( Field SqlInt4 ( Field SqlInt4
, Field SqlDate , Field SqlTimestamptz
, Field SqlInt4 , Field SqlInt4
, Field SqlInt4 , Field SqlInt4
, Field SqlBool , Field SqlBool
@ -42,3 +53,143 @@ amountTable = table "amount" (
, tableField "amount_verified" , 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.Text as T hiding (head, foldl)
import Data.Time.Calendar (Day) import Data.Time.Calendar (Day)
import Data.Profunctor.Product (p13) import Data.Profunctor.Product (p10)
import Data.Aeson import Data.Aeson
import Data.Aeson.Types import Data.Aeson.Types
@ -35,9 +35,9 @@ initProduct = mconcat
[ "create table if not exists \"product\" (" [ "create table if not exists \"product\" ("
, "product_id serial primary key," , "product_id serial primary key,"
, "product_ident varchar(128) not null," , "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_ml integer not null,"
, "product_avatar integer," , "product_avatar integer,"
, "product_supplier integer," , "product_supplier integer,"
@ -52,9 +52,9 @@ initProduct = mconcat
productTable :: Table productTable :: Table
( Maybe (Field SqlInt4) ( Maybe (Field SqlInt4)
, Field SqlText , Field SqlText
, Field SqlInt4 -- , Field SqlInt4
, Field SqlInt4 -- , Field SqlInt4
, Field SqlInt4 -- , Field SqlInt4
, Field SqlInt4 , Field SqlInt4
, FieldNullable SqlInt4 , FieldNullable SqlInt4
, FieldNullable SqlInt4 , FieldNullable SqlInt4
@ -66,9 +66,9 @@ productTable :: Table
) )
( Field SqlInt4 ( Field SqlInt4
, Field SqlText , Field SqlText
, Field SqlInt4 -- , Field SqlInt4
, Field SqlInt4 -- , Field SqlInt4
, Field SqlInt4 -- , Field SqlInt4
, Field SqlInt4 , Field SqlInt4
, FieldNullable SqlInt4 , FieldNullable SqlInt4
, FieldNullable SqlInt4 , FieldNullable SqlInt4
@ -79,12 +79,12 @@ productTable :: Table
, FieldNullable SqlText , FieldNullable SqlText
) )
productTable = table "product" ( productTable = table "product" (
p13 p10
( tableField "product_id" ( tableField "product_id"
, tableField "product_ident" , 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_ml"
, tableField "product_avatar" , tableField "product_avatar"
, tableField "product_supplier" , tableField "product_supplier"
@ -105,9 +105,9 @@ productSelect conn = do
) :: MateHandler ) :: MateHandler
[ ( Int [ ( Int
, T.Text , T.Text
, Int -- , Int
, Int -- , Int
, Int -- , Int
, Int , Int
, Maybe Int , Maybe Int
, Maybe Int , Maybe Int
@ -119,86 +119,86 @@ productSelect conn = do
) )
] ]
mapM 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 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 insertProduct
@ -210,9 +210,9 @@ insertProduct (ProductSubmit ident price ml ava sup max apc ppc artnr) = Insert
[ [
( C.constant (Nothing :: Maybe Int) ( C.constant (Nothing :: Maybe Int)
, C.constant ident , 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 ml
, C.constant ava , C.constant ava
, C.constant sup , C.constant sup
@ -223,65 +223,65 @@ insertProduct (ProductSubmit ident price ml ava sup max apc ppc artnr) = Insert
, C.constant artnr , C.constant artnr
) )
] ]
, iReturning = rReturning (\(id, _, _, _, _, _, _, _, _, _, _, _, _) -> id) , iReturning = rReturning (\(id, _, _, _, _, _, _, _, _, _) -> id)
, iOnConflict = Nothing , 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
} -- }

View file

@ -8,3 +8,4 @@ import Types.Refine as T
import Types.Reader as T import Types.Reader as T
import Types.User as T import Types.User as T
import Types.Purchase 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) deriving (Show, Generic)
instance ToJSON AuthInfo where instance ToJSON AuthInfo where
toEncoding = genericToEncoding defaultOptions
instance FromJSON AuthInfo instance FromJSON AuthInfo

View file

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