get things in order

This commit is contained in:
nek0 2019-07-28 11:55:22 +02:00
parent ece76fe5de
commit a937fe4775
8 changed files with 230 additions and 119 deletions

View file

@ -32,11 +32,11 @@ type UserAPI =
:> Capture "id" Int :> ReqBody '[JSON] UserDetailsSubmit :> Post '[JSON] () :> Capture "id" Int :> ReqBody '[JSON] UserDetailsSubmit :> Post '[JSON] ()
) )
:<|> "product" :> :<|> "product" :>
( "list" :> Get '[JSON] [Product] ( "list" :> Get '[JSON] [ProductOverview]
:<|> "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] AmountUpdate :> Post '[JSON] () :> 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

@ -113,7 +113,7 @@ users =
now <- liftIO $ getCurrentTime now <- liftIO $ getCurrentTime
randSalt <- liftIO $ random 8 randSalt <- liftIO $ random 8
conn <- rsConnection <$> ask conn <- rsConnection <$> ask
head <$> (liftIO $ runInsert_ conn (insertUser us (utctDay now) randSalt)) insertUser us (utctDay now) randSalt conn
userGetUpdate :: Maybe Int -> Int -> MateHandler UserDetails userGetUpdate :: Maybe Int -> Int -> MateHandler UserDetails
userGetUpdate Nothing _ = userGetUpdate Nothing _ =
@ -142,7 +142,7 @@ users =
then do then do
now <- liftIO $ getCurrentTime now <- liftIO $ getCurrentTime
conn <- rsConnection <$> ask conn <- rsConnection <$> ask
void $ liftIO $ runUpdate_ conn (updateUserDetails id uds (utctDay now)) void $ updateUserDetails id uds (utctDay now) conn
else else
throwError $ err403 throwError $ err403
{ errBody = "Wrong Authentication present" { errBody = "Wrong Authentication present"
@ -153,28 +153,28 @@ products =
new :<|> new :<|>
update update
where where
list :: MateHandler [Product] list :: MateHandler [ProductOverview]
list = do list = do
conn <- rsConnection <$> ask conn <- rsConnection <$> ask
productSelect conn productOverviewSelect conn
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
now <- liftIO $ getCurrentTime now <- liftIO $ getCurrentTime
bevid <- head <$> (liftIO $ runInsert_ conn (insertProduct bevsub)) bevid <- insertProduct bevsub conn
void $ liftIO $ runInsert_ conn (insertNewEmptyAmount bevid now bevsub) void $ insertNewEmptyAmount bevid now bevsub conn
return bevid return bevid
new Nothing _ = new Nothing _ =
throwError $ err403 throwError $ err403
update :: Maybe Int -> Int -> AmountUpdate -> MateHandler () update :: Maybe Int -> AmountUpdate -> MateHandler ()
update (Just _) bid amosub = do update (Just _) amosub@(AmountUpdate pid amount) = do
conn <- rsConnection <$> ask conn <- rsConnection <$> ask
liftIO $ do now <- liftIO $ getCurrentTime
now <- getCurrentTime oldprice <- getLatestPriceByProductId pid conn
void $ runInsert_ conn (manualProductAmountUpdate amosub now bid) void $ manualProductAmountUpdate amosub now oldprice conn
update Nothing _ _ = update Nothing _ =
throwError $ err403 throwError $ err403
buy :: Maybe Int -> [PurchaseDetail] -> MateHandler PurchaseResult buy :: Maybe Int -> [PurchaseDetail] -> MateHandler PurchaseResult
@ -184,8 +184,8 @@ buy (Just auid) pds = do
mmiss <- checkProductAvailability pd conn mmiss <- checkProductAvailability pd conn
case mmiss of case mmiss of
Just miss -> return Just miss -> return
( (pd {pdAmount = miss}):ms ( (pd {purchaseDetailAmount = miss}):ms
, (pd {pdAmount = max 0 (pdAmount pd - miss)}:rs) , (pd {purchaseDetailAmount = max 0 (purchaseDetailAmount pd - miss)}:rs)
) )
Nothing -> return Nothing -> return
( ms ( ms
@ -201,7 +201,7 @@ buy (Just auid) pds = do
) )
0 0
real real
liftIO $ runUpdate_ conn (addToUserBalance auid (-price)) addToUserBalance auid (-price) conn
newBalance <- userBalanceSelect conn auid newBalance <- userBalanceSelect conn auid
return $ PurchaseResult return $ PurchaseResult
( if newBalance < 0 ( if newBalance < 0
@ -215,8 +215,8 @@ buy Nothing pds = do
mmiss <- checkProductAvailability pd conn mmiss <- checkProductAvailability pd conn
case mmiss of case mmiss of
Just miss -> return Just miss -> return
( (pd {pdAmount = miss}):ms ( (pd {purchaseDetailAmount = miss}):ms
, (pd {pdAmount = max 0 (pdAmount pd - miss)}:rs) , (pd {purchaseDetailAmount = max 0 (purchaseDetailAmount pd - miss)}:rs)
) )
Nothing -> return Nothing -> return
( ms ( ms

View file

@ -58,21 +58,23 @@ insertNewEmptyAmount
:: Int -- | the associated product id :: Int -- | the associated product id
-> UTCTime -- | current time -> UTCTime -- | current time
-> ProductSubmit -- | submitted product data -> ProductSubmit -- | submitted product data
-> Insert [Int] -> PGS.Connection
insertNewEmptyAmount bevid now (ProductSubmit _ price _ _ _ _ _ _ _) = Insert -> MateHandler Int
{ iTable = amountTable insertNewEmptyAmount bevid now (ProductSubmit _ price _ _ _ _ _ _ _) conn =
, iRows = fmap head $ liftIO $ runInsert_ conn $ Insert
[ { iTable = amountTable
( C.constant bevid , iRows =
, C.constant now [
, C.constant (0 :: Int) ( C.constant bevid
, C.constant price , C.constant now
, C.constant False , C.constant (0 :: Int)
) , C.constant price
] , C.constant False
, iReturning = rReturning (\(id_, _, _, _, _) -> id_) )
, iOnConflict = Nothing ]
} , iReturning = rReturning (\(id_, _, _, _, _) -> id_)
, iOnConflict = Nothing
}
getLatestPriceByProductId getLatestPriceByProductId
:: Int -- The associated Product ID :: Int -- The associated Product ID
@ -142,21 +144,23 @@ manualProductAmountUpdate
:: AmountUpdate :: AmountUpdate
-> UTCTime -- Current time -> UTCTime -- Current time
-> Int -- Old BeveragePrice -> Int -- Old BeveragePrice
-> Insert [Int] -> PGS.Connection
manualProductAmountUpdate (AmountUpdate pid amount) now oldprice = Insert -> MateHandler Int
{ iTable = amountTable manualProductAmountUpdate (AmountUpdate pid amount) now oldprice conn =
, iRows = fmap head $ liftIO $ runInsert_ conn $ Insert
[ { iTable = amountTable
( C.constant pid , iRows =
, C.constant now [
, C.constant amount ( C.constant pid
, C.constant oldprice , C.constant now
, C.constant True , C.constant amount
) , C.constant oldprice
] , C.constant True
, iReturning = rReturning (\(id_, _, _, _, _) -> id_) )
, iOnConflict = Nothing ]
} , iReturning = rReturning (\(id_, _, _, _, _) -> id_)
, iOnConflict = Nothing
}
postBuyProductAmountUpdate postBuyProductAmountUpdate
:: PurchaseDetail :: PurchaseDetail

View file

@ -128,9 +128,8 @@ validateToken conn header = do
if diffUTCTime stamp now > 0 if diffUTCTime stamp now > 0
then return $ Just uid then return $ Just uid
else do else do
liftIO $ do void $ deleteToken header conn
void $ forkIO $ void $ runDelete_ conn (deleteToken header) liftIO $ threadDelay $ 1 * 10 ^ 6
threadDelay $ 1 * 10 ^ 6
throwError $ err401 throwError $ err401
{ errBody = "Your token expired!" { errBody = "Your token expired!"
} }
@ -169,7 +168,7 @@ generateToken (Ticket _ ident exp) (AuthHash hash) = do
<$> (random 23) <$> (random 23)
<*> (pure ident) <*> (pure ident)
<*> (addUTCTime (23*60) <$> getCurrentTime) <*> (addUTCTime (23*60) <$> getCurrentTime)
void $ liftIO $ runInsert_ conn (insertToken token) void $ insertToken token conn
return $ Granted (AuthToken $ tokenString token) return $ Granted (AuthToken $ tokenString token)
else else
return Denied return Denied
@ -177,35 +176,40 @@ generateToken (Ticket _ ident exp) (AuthHash hash) = do
insertToken insertToken
:: Token :: Token
-> Insert [ByteString] -> PGS.Connection
insertToken (Token tString tUser tExpiry) = Insert -> MateHandler ByteString
{ iTable = tokenTable insertToken (Token tString tUser tExpiry) conn =
, iRows = fmap head $ liftIO $ runInsert_ conn $ Insert
[ { iTable = tokenTable
( C.constant tString , iRows =
, C.constant tUser [
, C.constant tExpiry ( C.constant tString
) , C.constant tUser
] , C.constant tExpiry
, iReturning = rReturning (\(ident, _, _) -> ident) )
, iOnConflict = Nothing ]
} , iReturning = rReturning (\(ident, _, _) -> ident)
, iOnConflict = Nothing
}
deleteToken deleteToken
:: ByteString :: ByteString
-> Opaleye.Delete Int64 -> PGS.Connection
deleteToken tstr = Delete -> Handler Int64
{ dTable = tokenTable deleteToken tstr conn =
, dWhere = (\(rtstr, _, _) -> rtstr .== C.constant tstr) liftIO $ runDelete_ conn $ Delete
, dReturning = rCount { dTable = tokenTable
} , dWhere = (\(rtstr, _, _) -> rtstr .== C.constant tstr)
, dReturning = rCount
}
deleteTokenByUserId deleteTokenByUserId
:: Int :: Int
-> Opaleye.Delete Int64 -> PGS.Connection
deleteTokenByUserId uid = Delete -> MateHandler Int64
deleteTokenByUserId uid conn = liftIO $ runDelete_ conn $ Delete
{ dTable = tokenTable { dTable = tokenTable
, dWhere = (\(_, rid, _) -> rid .== C.constant uid) , dWhere = (\(_, rid, _) -> rid .== C.constant uid)
, dReturning = rCount , dReturning = rCount
@ -262,4 +266,4 @@ processLogout
-> MateHandler () -> MateHandler ()
processLogout uid = do processLogout uid = do
conn <- rsConnection <$> ask conn <- rsConnection <$> ask
liftIO $ void $ runDelete_ conn (deleteTokenByUserId uid) void $ deleteTokenByUserId uid conn

View file

@ -1,12 +1,15 @@
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE Arrows #-}
module Model.Product where module Model.Product where
import Servant.Server 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 (p10) import Data.Time.Clock (UTCTime)
import Data.Profunctor.Product (p9)
import Data.Aeson import Data.Aeson
import Data.Aeson.Types import Data.Aeson.Types
@ -17,7 +20,7 @@ import Control.Monad (when)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Control.Monad.Error.Class (throwError) import Control.Monad.Error.Class (throwError)
import Control.Arrow ((<<<)) import Control.Arrow ((<<<), returnA)
import qualified Database.PostgreSQL.Simple as PGS import qualified Database.PostgreSQL.Simple as PGS
@ -29,6 +32,7 @@ import Opaleye.Constant as C
-- internal imports -- internal imports
import Types import Types
import Model.Amount
initProduct :: PGS.Query initProduct :: PGS.Query
initProduct = mconcat initProduct = mconcat
@ -42,7 +46,7 @@ initProduct = mconcat
, "product_avatar integer," , "product_avatar integer,"
, "product_supplier integer," , "product_supplier integer,"
, "product_max_amount integer not null," , "product_max_amount integer not null,"
, "product_total_bought integer not null," -- , "product_total_bought integer not null,"
, "product_amount_per_crate integer not null," , "product_amount_per_crate integer not null,"
, "product_price_per_crate integer," , "product_price_per_crate integer,"
, "product_art_nr varchar(128)" , "product_art_nr varchar(128)"
@ -59,7 +63,7 @@ productTable :: Table
, FieldNullable SqlInt4 , FieldNullable SqlInt4
, FieldNullable SqlInt4 , FieldNullable SqlInt4
, Field SqlInt4 , Field SqlInt4
, Field SqlInt4 -- , Field SqlInt4
, Field SqlInt4 , Field SqlInt4
, FieldNullable SqlInt4 , FieldNullable SqlInt4
, FieldNullable SqlText , FieldNullable SqlText
@ -73,13 +77,13 @@ productTable :: Table
, FieldNullable SqlInt4 , FieldNullable SqlInt4
, FieldNullable SqlInt4 , FieldNullable SqlInt4
, Field SqlInt4 , Field SqlInt4
, Field SqlInt4 -- , Field SqlInt4
, Field SqlInt4 , Field SqlInt4
, FieldNullable SqlInt4 , FieldNullable SqlInt4
, FieldNullable SqlText , FieldNullable SqlText
) )
productTable = table "product" ( productTable = table "product" (
p10 p9
( tableField "product_id" ( tableField "product_id"
, tableField "product_ident" , tableField "product_ident"
-- , tableField "product_price" -- , tableField "product_price"
@ -89,13 +93,14 @@ productTable = table "product" (
, tableField "product_avatar" , tableField "product_avatar"
, tableField "product_supplier" , tableField "product_supplier"
, tableField "product_max_amount" , tableField "product_max_amount"
, tableField "product_total_bought" -- , tableField "product_total_bought"
, tableField "product_amount_per_crate" , tableField "product_amount_per_crate"
, tableField "product_price_per_crate" , tableField "product_price_per_crate"
, tableField "product_art_nr" , tableField "product_art_nr"
) )
) )
productSelect productSelect
:: PGS.Connection :: PGS.Connection
-> MateHandler [Product] -> MateHandler [Product]
@ -112,15 +117,78 @@ productSelect conn = do
, Maybe Int , Maybe Int
, Maybe Int , Maybe Int
, Int , Int
, Int -- , Int
, Int , Int
, Maybe Int , Maybe Int
, Maybe T.Text , Maybe T.Text
) )
] ]
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
productOverviewSelect
:: PGS.Connection
-> MateHandler [ProductOverview]
productOverviewSelect conn = do
bevs <- liftIO $ runSelect conn
( proc () -> do
(i1, i2, i6, i7, i8, i9, i11, i12, i13) <- queryTable productTable -< ()
returnA -< (i1, i2, i6, i7, i8, i9, i11, i12, i13)
) :: MateHandler
[ ( Int
, T.Text
-- , Int
-- , Int
-- , Int
, Int
, Maybe Int
, Maybe Int
, Int
-- , Int
, Int
, Maybe Int
, Maybe T.Text
)
]
mapM
(\(i1, i2, {-i3, i4, i5,-} i6, i7, i8, i9, {-i10,-} i11, i12, i13) -> do
amounts <- liftIO $ runSelect conn
( proc () -> do
stuff@(a1, _, _, _, _) <- orderBy (desc (\(_, ts, _, _, _) -> ts))
(queryTable amountTable) -< ()
restrict -< C.constant i1 .== a1
returnA -< stuff
) :: MateHandler
[ ( Int
, UTCTime
, Int
, Int
, Bool
)
]
(i3, i4) <- return $ (\(_, _, y, x, _) -> (x, y)) $ head amounts
i5 <- return $ (\(_, x) -> x) $
foldl
(\(bef, van) (_, _, amo, _, ver) ->
if ver
then (amo, if amo < bef then van + (bef - amo) else van)
else (amo, van)
)
(0, 0)
(Prelude.reverse amounts)
i10 <- return $ snd $ foldl (\(bef, tot) (_, _, amo, _, ver) ->
if ver
then (amo, tot)
else (amo, tot + (bef - amo))
)
(0, 0)
(Prelude.reverse amounts)
return $ ProductOverview
i1 i2 i3 i4 i5 i6 i7 i8 i9 i10 i11 i12 i13
) )
bevs bevs
@ -203,29 +271,31 @@ productSelect conn = do
insertProduct insertProduct
:: ProductSubmit :: ProductSubmit
-> Insert [Int] -> PGS.Connection
insertProduct (ProductSubmit ident price ml ava sup max apc ppc artnr) = Insert -> MateHandler Int
{ iTable = productTable insertProduct (ProductSubmit ident price ml ava sup max apc ppc artnr) conn =
, iRows = fmap head $ liftIO $ runInsert_ conn $ Insert
[ { iTable = productTable
( C.constant (Nothing :: Maybe Int) , iRows =
, C.constant ident [
-- , C.constant price ( C.constant (Nothing :: Maybe Int)
-- , C.constant (0 :: Int) , C.constant ident
-- , C.constant (0 :: Int) -- , C.constant price
, C.constant ml -- , C.constant (0 :: Int)
, C.constant ava -- , C.constant (0 :: Int)
, C.constant sup , C.constant ml
, C.constant max , C.constant ava
, C.constant (0 :: Int) , C.constant sup
, C.constant apc , C.constant max
, C.constant ppc -- , C.constant (0 :: Int)
, C.constant artnr , C.constant apc
) , C.constant ppc
] , C.constant artnr
, iReturning = rReturning (\(id, _, _, _, _, _, _, _, _, _) -> id) )
, iOnConflict = Nothing ]
} , iReturning = rReturning (\(id, _, _, _, _, _, _, _, _) -> id)
, iOnConflict = Nothing
}
-- updateProduct -- updateProduct

View file

@ -173,8 +173,13 @@ userBalanceSelect conn id = do
users users
insertUser :: UserSubmit -> Day -> ByteString -> Insert [Int] insertUser
insertUser us now randSalt = Insert :: UserSubmit
-> Day
-> ByteString
-> PGS.Connection
-> MateHandler Int
insertUser us now randSalt conn = fmap head $ liftIO $ runInsert_ conn $ Insert
{ iTable = userTable { iTable = userTable
, iRows = , iRows =
[ [
@ -193,8 +198,13 @@ insertUser us now randSalt = Insert
, iOnConflict = Nothing , iOnConflict = Nothing
} }
updateUserDetails :: Int -> UserDetailsSubmit -> Day -> Update Int64 updateUserDetails
updateUserDetails uid uds now = Update :: Int
-> UserDetailsSubmit
-> Day
-> PGS.Connection
-> MateHandler Int64
updateUserDetails uid uds now conn = liftIO $ runUpdate_ conn $ Update
{ uTable = userTable { uTable = userTable
, uUpdateWith = updateEasy (\(id_, _, i3, _, _, _, i7, i8, _) -> , uUpdateWith = updateEasy (\(id_, _, i3, _, _, _, i7, i8, _) ->
( id_ ( id_
@ -215,8 +225,9 @@ updateUserDetails uid uds now = Update
addToUserBalance addToUserBalance
:: Int :: Int
-> Int -> Int
-> Update Int64 -> PGS.Connection
addToUserBalance uid amount = Update -> MateHandler Int64
addToUserBalance uid amount conn = liftIO $ runUpdate_ conn $ Update
{ uTable = userTable { uTable = userTable
, uUpdateWith = updateEasy (\(id_, i2, i3, i4, i5, i6, i7, i8, i9) -> , uUpdateWith = updateEasy (\(id_, i2, i3, i4, i5, i6, i7, i8, i9) ->
( id_ ( id_

View file

@ -17,7 +17,7 @@ data Product = Product
, productAvatar :: Maybe Int , productAvatar :: Maybe Int
, productSupplier :: Maybe Int , productSupplier :: Maybe Int
, productMaxAmount :: Int , productMaxAmount :: Int
, productTotalBought :: Int -- , productTotalBought :: Int
, productAmountPerCrate :: Int , productAmountPerCrate :: Int
, productPricePerCrate :: Maybe Int , productPricePerCrate :: Maybe Int
, productArtNr :: Maybe T.Text , productArtNr :: Maybe T.Text
@ -29,6 +29,28 @@ instance ToJSON Product where
instance FromJSON Product instance FromJSON Product
data ProductOverview = ProductOverview
{ productOverviewId :: Int
, productOverviewIdent :: T.Text
, productOverviewPrice :: Int
, productOverviewAmount :: Int
, productOverviewVanish :: Int
, productOverviewMl :: Int
, productOverviewAvatar :: Maybe Int
, productOverviewSupplier :: Maybe Int
, productOverviewMaxAmount :: Int
, productOverviewTotalBought :: Int
, productOverviewAmountPerCrate :: Int
, productOverviewPricePerCrate :: Maybe Int
, productOverviewArtNr :: Maybe T.Text
} deriving (Generic, Show)
instance ToJSON ProductOverview where
toEncoding = genericToEncoding defaultOptions
instance FromJSON ProductOverview
data ProductSubmit = ProductSubmit data ProductSubmit = ProductSubmit
{ productSubmitIdent :: T.Text { productSubmitIdent :: T.Text
, productSubmitPrice :: Int , productSubmitPrice :: Int

View file

@ -10,8 +10,8 @@ import GHC.Generics
data PurchaseDetail = PurchaseDetail data PurchaseDetail = PurchaseDetail
{ pdBeverage :: Int { purchaseDetailBeverage :: Int
, pdAmount :: Int , purchaseDetailAmount :: Int
} }
deriving (Generic, Show) deriving (Generic, Show)
@ -22,8 +22,8 @@ instance FromJSON PurchaseDetail
data PurchaseResult = PurchaseResult data PurchaseResult = PurchaseResult
{ prFlag :: PurchaseResultFlag { purchaseResultFlag :: PurchaseResultFlag
, prMissingItems :: [PurchaseDetail] , purchaseResultMissingItems :: [PurchaseDetail]
} }
deriving (Generic, Show) deriving (Generic, Show)