From 340ccdc2759c0feaa7abef5b3446eb50aa8684e2 Mon Sep 17 00:00:00 2001 From: nek0 Date: Sat, 3 Aug 2019 09:30:18 +0200 Subject: [PATCH] add short product overview --- src/API.hs | 3 ++- src/Main.hs | 14 +++++++--- src/Model/Product.hs | 63 ++++++++++++++++++++++++++++++++++++++++++++ src/Types/Product.hs | 22 ++++++++++++++++ 4 files changed, 98 insertions(+), 4 deletions(-) diff --git a/src/API.hs b/src/API.hs index 48892d5..552e829 100644 --- a/src/API.hs +++ b/src/API.hs @@ -32,7 +32,8 @@ type UserAPI = :> Capture "id" Int :> ReqBody '[JSON] UserDetailsSubmit :> Post '[JSON] () ) :<|> "product" :> - ( "list" :> Get '[JSON] [ProductOverview] + ( "list" :> Get '[JSON] [ProductShortOverview] + :<|> "list" :> AuthProtect "header-auth" :> Get '[JSON] [ProductOverview] :<|> "new" :> AuthProtect "header-auth" :> ReqBody '[JSON] ProductSubmit :> Post '[JSON] Int :<|> "update" :> AuthProtect "header-auth" diff --git a/src/Main.hs b/src/Main.hs index 421d60f..7191f03 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -149,14 +149,22 @@ users = } products = - list :<|> + listShort :<|> + listLong :<|> new :<|> update where - list :: MateHandler [ProductOverview] - list = do + listShort :: MateHandler [ProductShortOverview] + listShort = do + conn <- rsConnection <$> ask + productShortOverviewSelect conn + + listLong :: Maybe Int -> MateHandler [ProductOverview] + listLong (Just _) = do conn <- rsConnection <$> ask productOverviewSelect conn + listLong Nothing = + throwError $ err403 new :: Maybe Int -> ProductSubmit -> MateHandler Int new (Just _) bevsub = do diff --git a/src/Model/Product.hs b/src/Model/Product.hs index 889db3b..022e739 100644 --- a/src/Model/Product.hs +++ b/src/Model/Product.hs @@ -193,6 +193,69 @@ productOverviewSelect conn = do bevs +productShortOverviewSelect + :: PGS.Connection + -> MateHandler [ProductShortOverview] +productShortOverviewSelect 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 $ ProductShortOverview + i1 i2 i3 i4 i6 i7 + ) + bevs + + -- getProductPrice -- :: PurchaseDetail -- -> PGS.Connection diff --git a/src/Types/Product.hs b/src/Types/Product.hs index bf66ab1..2beff65 100644 --- a/src/Types/Product.hs +++ b/src/Types/Product.hs @@ -51,6 +51,28 @@ instance ToJSON ProductOverview where instance FromJSON ProductOverview +data ProductShortOverview = ProductShortOverview + { productShortOverviewId :: Int + , productShortOverviewIdent :: T.Text + , productShortOverviewPrice :: Int + , productShortOverviewAmount :: Int + -- , productShortOverviewVanish :: Int + , productShortOverviewMl :: Int + , productShortOverviewAvatar :: Maybe Int + -- , productShortOverviewSupplier :: Maybe Int + -- , productShortOverviewMaxAmount :: Int + -- , productShortOverviewTotalBought :: Int + -- , productShortOverviewAmountPerCrate :: Int + -- , productShortOverviewPricePerCrate :: Maybe Int + -- , productShortOverviewArtNr :: Maybe T.Text + } deriving (Generic, Show) + +instance ToJSON ProductShortOverview where + toEncoding = genericToEncoding defaultOptions + +instance FromJSON ProductShortOverview + + data ProductSubmit = ProductSubmit { productSubmitIdent :: T.Text , productSubmitPrice :: Int