From a937fe4775a62d696151832da13591379f2739fc Mon Sep 17 00:00:00 2001 From: nek0 Date: Sun, 28 Jul 2019 11:55:22 +0200 Subject: [PATCH] get things in order --- src/API.hs | 4 +- src/Main.hs | 34 +++++------ src/Model/Amount.hs | 64 ++++++++++---------- src/Model/Auth.hs | 56 +++++++++-------- src/Model/Product.hs | 136 ++++++++++++++++++++++++++++++++---------- src/Model/User.hs | 23 +++++-- src/Types/Product.hs | 24 +++++++- src/Types/Purchase.hs | 8 +-- 8 files changed, 230 insertions(+), 119 deletions(-) diff --git a/src/API.hs b/src/API.hs index 4a3f5b4..48892d5 100644 --- a/src/API.hs +++ b/src/API.hs @@ -32,11 +32,11 @@ type UserAPI = :> Capture "id" Int :> ReqBody '[JSON] UserDetailsSubmit :> Post '[JSON] () ) :<|> "product" :> - ( "list" :> Get '[JSON] [Product] + ( "list" :> Get '[JSON] [ProductOverview] :<|> "new" :> AuthProtect "header-auth" :> ReqBody '[JSON] ProductSubmit :> Post '[JSON] Int :<|> "update" :> AuthProtect "header-auth" - :> Capture "id" Int :> ReqBody '[JSON] AmountUpdate :> Post '[JSON] () + :> 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 516124d..421d60f 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -113,7 +113,7 @@ users = now <- liftIO $ getCurrentTime randSalt <- liftIO $ random 8 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 Nothing _ = @@ -142,7 +142,7 @@ users = then do now <- liftIO $ getCurrentTime conn <- rsConnection <$> ask - void $ liftIO $ runUpdate_ conn (updateUserDetails id uds (utctDay now)) + void $ updateUserDetails id uds (utctDay now) conn else throwError $ err403 { errBody = "Wrong Authentication present" @@ -153,28 +153,28 @@ products = new :<|> update where - list :: MateHandler [Product] + list :: MateHandler [ProductOverview] list = do conn <- rsConnection <$> ask - productSelect conn + productOverviewSelect conn new :: Maybe Int -> ProductSubmit -> MateHandler Int new (Just _) bevsub = do conn <- rsConnection <$> ask now <- liftIO $ getCurrentTime - bevid <- head <$> (liftIO $ runInsert_ conn (insertProduct bevsub)) - void $ liftIO $ runInsert_ conn (insertNewEmptyAmount bevid now bevsub) + bevid <- insertProduct bevsub conn + void $ insertNewEmptyAmount bevid now bevsub conn return bevid new Nothing _ = throwError $ err403 - update :: Maybe Int -> Int -> AmountUpdate -> MateHandler () - update (Just _) bid amosub = do + update :: Maybe Int -> AmountUpdate -> MateHandler () + update (Just _) amosub@(AmountUpdate pid amount) = do conn <- rsConnection <$> ask - liftIO $ do - now <- getCurrentTime - void $ runInsert_ conn (manualProductAmountUpdate amosub now bid) - update Nothing _ _ = + now <- liftIO $ getCurrentTime + oldprice <- getLatestPriceByProductId pid conn + void $ manualProductAmountUpdate amosub now oldprice conn + update Nothing _ = throwError $ err403 buy :: Maybe Int -> [PurchaseDetail] -> MateHandler PurchaseResult @@ -184,8 +184,8 @@ buy (Just auid) pds = do mmiss <- checkProductAvailability pd conn case mmiss of Just miss -> return - ( (pd {pdAmount = miss}):ms - , (pd {pdAmount = max 0 (pdAmount pd - miss)}:rs) + ( (pd {purchaseDetailAmount = miss}):ms + , (pd {purchaseDetailAmount = max 0 (purchaseDetailAmount pd - miss)}:rs) ) Nothing -> return ( ms @@ -201,7 +201,7 @@ buy (Just auid) pds = do ) 0 real - liftIO $ runUpdate_ conn (addToUserBalance auid (-price)) + addToUserBalance auid (-price) conn newBalance <- userBalanceSelect conn auid return $ PurchaseResult ( if newBalance < 0 @@ -215,8 +215,8 @@ buy Nothing pds = do mmiss <- checkProductAvailability pd conn case mmiss of Just miss -> return - ( (pd {pdAmount = miss}):ms - , (pd {pdAmount = max 0 (pdAmount pd - miss)}:rs) + ( (pd {purchaseDetailAmount = miss}):ms + , (pd {purchaseDetailAmount = max 0 (purchaseDetailAmount pd - miss)}:rs) ) Nothing -> return ( ms diff --git a/src/Model/Amount.hs b/src/Model/Amount.hs index dfb0c24..9f3123f 100644 --- a/src/Model/Amount.hs +++ b/src/Model/Amount.hs @@ -58,21 +58,23 @@ 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 - } + -> PGS.Connection + -> MateHandler Int +insertNewEmptyAmount bevid now (ProductSubmit _ price _ _ _ _ _ _ _) conn = + fmap head $ liftIO $ runInsert_ conn $ 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 @@ -142,21 +144,23 @@ 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 - } + -> PGS.Connection + -> MateHandler Int +manualProductAmountUpdate (AmountUpdate pid amount) now oldprice conn = + fmap head $ liftIO $ runInsert_ conn $ 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 diff --git a/src/Model/Auth.hs b/src/Model/Auth.hs index 81b042c..2fc34bd 100644 --- a/src/Model/Auth.hs +++ b/src/Model/Auth.hs @@ -128,9 +128,8 @@ validateToken conn header = do if diffUTCTime stamp now > 0 then return $ Just uid else do - liftIO $ do - void $ forkIO $ void $ runDelete_ conn (deleteToken header) - threadDelay $ 1 * 10 ^ 6 + void $ deleteToken header conn + liftIO $ threadDelay $ 1 * 10 ^ 6 throwError $ err401 { errBody = "Your token expired!" } @@ -169,7 +168,7 @@ generateToken (Ticket _ ident exp) (AuthHash hash) = do <$> (random 23) <*> (pure ident) <*> (addUTCTime (23*60) <$> getCurrentTime) - void $ liftIO $ runInsert_ conn (insertToken token) + void $ insertToken token conn return $ Granted (AuthToken $ tokenString token) else return Denied @@ -177,35 +176,40 @@ generateToken (Ticket _ ident exp) (AuthHash hash) = do insertToken :: Token - -> Insert [ByteString] -insertToken (Token tString tUser tExpiry) = Insert - { iTable = tokenTable - , iRows = - [ - ( C.constant tString - , C.constant tUser - , C.constant tExpiry - ) - ] - , iReturning = rReturning (\(ident, _, _) -> ident) - , iOnConflict = Nothing - } + -> PGS.Connection + -> MateHandler ByteString +insertToken (Token tString tUser tExpiry) conn = + fmap head $ liftIO $ runInsert_ conn $ Insert + { iTable = tokenTable + , iRows = + [ + ( C.constant tString + , C.constant tUser + , C.constant tExpiry + ) + ] + , iReturning = rReturning (\(ident, _, _) -> ident) + , iOnConflict = Nothing + } deleteToken :: ByteString - -> Opaleye.Delete Int64 -deleteToken tstr = Delete - { dTable = tokenTable - , dWhere = (\(rtstr, _, _) -> rtstr .== C.constant tstr) - , dReturning = rCount - } + -> PGS.Connection + -> Handler Int64 +deleteToken tstr conn = + liftIO $ runDelete_ conn $ Delete + { dTable = tokenTable + , dWhere = (\(rtstr, _, _) -> rtstr .== C.constant tstr) + , dReturning = rCount + } deleteTokenByUserId :: Int - -> Opaleye.Delete Int64 -deleteTokenByUserId uid = Delete + -> PGS.Connection + -> MateHandler Int64 +deleteTokenByUserId uid conn = liftIO $ runDelete_ conn $ Delete { dTable = tokenTable , dWhere = (\(_, rid, _) -> rid .== C.constant uid) , dReturning = rCount @@ -262,4 +266,4 @@ processLogout -> MateHandler () processLogout uid = do conn <- rsConnection <$> ask - liftIO $ void $ runDelete_ conn (deleteTokenByUserId uid) + void $ deleteTokenByUserId uid conn diff --git a/src/Model/Product.hs b/src/Model/Product.hs index 50f8930..889db3b 100644 --- a/src/Model/Product.hs +++ b/src/Model/Product.hs @@ -1,12 +1,15 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Arrows #-} module Model.Product where import Servant.Server import Data.Text as T hiding (head, foldl) 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.Types @@ -17,7 +20,7 @@ import Control.Monad (when) import Control.Monad.IO.Class (liftIO) import Control.Monad.Error.Class (throwError) -import Control.Arrow ((<<<)) +import Control.Arrow ((<<<), returnA) import qualified Database.PostgreSQL.Simple as PGS @@ -29,6 +32,7 @@ import Opaleye.Constant as C -- internal imports import Types +import Model.Amount initProduct :: PGS.Query initProduct = mconcat @@ -42,7 +46,7 @@ initProduct = mconcat , "product_avatar integer," , "product_supplier integer," , "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_price_per_crate integer," , "product_art_nr varchar(128)" @@ -59,7 +63,7 @@ productTable :: Table , FieldNullable SqlInt4 , FieldNullable SqlInt4 , Field SqlInt4 - , Field SqlInt4 + -- , Field SqlInt4 , Field SqlInt4 , FieldNullable SqlInt4 , FieldNullable SqlText @@ -73,13 +77,13 @@ productTable :: Table , FieldNullable SqlInt4 , FieldNullable SqlInt4 , Field SqlInt4 - , Field SqlInt4 + -- , Field SqlInt4 , Field SqlInt4 , FieldNullable SqlInt4 , FieldNullable SqlText ) productTable = table "product" ( - p10 + p9 ( tableField "product_id" , tableField "product_ident" -- , tableField "product_price" @@ -89,13 +93,14 @@ productTable = table "product" ( , tableField "product_avatar" , tableField "product_supplier" , tableField "product_max_amount" - , tableField "product_total_bought" + -- , tableField "product_total_bought" , tableField "product_amount_per_crate" , tableField "product_price_per_crate" , tableField "product_art_nr" ) ) + productSelect :: PGS.Connection -> MateHandler [Product] @@ -112,15 +117,78 @@ productSelect conn = do , Maybe Int , Maybe Int , Int - , Int + -- , Int , Int , Maybe Int , Maybe T.Text ) ] 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 + + +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 @@ -203,29 +271,31 @@ productSelect conn = do insertProduct :: ProductSubmit - -> Insert [Int] -insertProduct (ProductSubmit ident price ml ava sup max apc ppc artnr) = Insert - { iTable = productTable - , iRows = - [ - ( C.constant (Nothing :: Maybe Int) - , C.constant ident - -- , C.constant price - -- , C.constant (0 :: Int) - -- , C.constant (0 :: Int) - , C.constant ml - , C.constant ava - , C.constant sup - , C.constant max - , C.constant (0 :: Int) - , C.constant apc - , C.constant ppc - , C.constant artnr - ) - ] - , iReturning = rReturning (\(id, _, _, _, _, _, _, _, _, _) -> id) - , iOnConflict = Nothing - } + -> PGS.Connection + -> MateHandler Int +insertProduct (ProductSubmit ident price ml ava sup max apc ppc artnr) conn = + fmap head $ liftIO $ runInsert_ conn $ Insert + { iTable = productTable + , iRows = + [ + ( C.constant (Nothing :: Maybe Int) + , C.constant ident + -- , C.constant price + -- , C.constant (0 :: Int) + -- , C.constant (0 :: Int) + , C.constant ml + , C.constant ava + , C.constant sup + , C.constant max + -- , C.constant (0 :: Int) + , C.constant apc + , C.constant ppc + , C.constant artnr + ) + ] + , iReturning = rReturning (\(id, _, _, _, _, _, _, _, _) -> id) + , iOnConflict = Nothing + } -- updateProduct diff --git a/src/Model/User.hs b/src/Model/User.hs index f0e6627..897b0de 100644 --- a/src/Model/User.hs +++ b/src/Model/User.hs @@ -173,8 +173,13 @@ userBalanceSelect conn id = do users -insertUser :: UserSubmit -> Day -> ByteString -> Insert [Int] -insertUser us now randSalt = Insert +insertUser + :: UserSubmit + -> Day + -> ByteString + -> PGS.Connection + -> MateHandler Int +insertUser us now randSalt conn = fmap head $ liftIO $ runInsert_ conn $ Insert { iTable = userTable , iRows = [ @@ -193,8 +198,13 @@ insertUser us now randSalt = Insert , iOnConflict = Nothing } -updateUserDetails :: Int -> UserDetailsSubmit -> Day -> Update Int64 -updateUserDetails uid uds now = Update +updateUserDetails + :: Int + -> UserDetailsSubmit + -> Day + -> PGS.Connection + -> MateHandler Int64 +updateUserDetails uid uds now conn = liftIO $ runUpdate_ conn $ Update { uTable = userTable , uUpdateWith = updateEasy (\(id_, _, i3, _, _, _, i7, i8, _) -> ( id_ @@ -215,8 +225,9 @@ updateUserDetails uid uds now = Update addToUserBalance :: Int -> Int - -> Update Int64 -addToUserBalance uid amount = Update + -> PGS.Connection + -> MateHandler Int64 +addToUserBalance uid amount conn = liftIO $ runUpdate_ conn $ Update { uTable = userTable , uUpdateWith = updateEasy (\(id_, i2, i3, i4, i5, i6, i7, i8, i9) -> ( id_ diff --git a/src/Types/Product.hs b/src/Types/Product.hs index e601683..bf66ab1 100644 --- a/src/Types/Product.hs +++ b/src/Types/Product.hs @@ -17,7 +17,7 @@ data Product = Product , productAvatar :: Maybe Int , productSupplier :: Maybe Int , productMaxAmount :: Int - , productTotalBought :: Int + -- , productTotalBought :: Int , productAmountPerCrate :: Int , productPricePerCrate :: Maybe Int , productArtNr :: Maybe T.Text @@ -29,6 +29,28 @@ instance ToJSON Product where 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 { productSubmitIdent :: T.Text , productSubmitPrice :: Int diff --git a/src/Types/Purchase.hs b/src/Types/Purchase.hs index c1e6714..6d888ba 100644 --- a/src/Types/Purchase.hs +++ b/src/Types/Purchase.hs @@ -10,8 +10,8 @@ import GHC.Generics data PurchaseDetail = PurchaseDetail - { pdBeverage :: Int - , pdAmount :: Int + { purchaseDetailBeverage :: Int + , purchaseDetailAmount :: Int } deriving (Generic, Show) @@ -22,8 +22,8 @@ instance FromJSON PurchaseDetail data PurchaseResult = PurchaseResult - { prFlag :: PurchaseResultFlag - , prMissingItems :: [PurchaseDetail] + { purchaseResultFlag :: PurchaseResultFlag + , purchaseResultMissingItems :: [PurchaseDetail] } deriving (Generic, Show)