fix product overview queries

This commit is contained in:
nek0 2019-10-21 20:40:30 +02:00
parent f7be7e317d
commit 8612987cf8
2 changed files with 108 additions and 99 deletions

View file

@ -42,7 +42,7 @@ executable mateamt
default-language: Haskell2010 default-language: Haskell2010
library library
exposed-modules: API exposed-modules: API
, Control , Control
, Control.Buy , Control.Buy
, Control.Journal , Control.Journal
@ -67,6 +67,7 @@ library
, Types.Amount , Types.Amount
, Types.Journal , Types.Journal
, Types.Avatar , Types.Avatar
, Util
-- other-extensions: -- other-extensions:
build-depends: base ^>=4.12.0.0 build-depends: base ^>=4.12.0.0
, servant , servant
@ -76,6 +77,7 @@ library
, aeson , aeson
, text , text
, time , time
, profunctors
, product-profunctors , product-profunctors
, postgresql-simple , postgresql-simple
, warp , warp

View file

@ -10,11 +10,15 @@ import Data.Profunctor.Product (p9)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Control.Arrow ((<<<), returnA, arr) import Control.Arrow
import qualified Database.PostgreSQL.Simple as PGS import qualified Database.PostgreSQL.Simple as PGS
import Opaleye as O hiding (max) import qualified Data.Profunctor as P
import qualified Data.Profunctor.Product as PP
import qualified Data.Profunctor.Product.Default as D
import Opaleye as O
import Opaleye.Constant as C import Opaleye.Constant as C
-- internal imports -- internal imports
@ -103,55 +107,76 @@ productOverviewSelect
-> PGS.Connection -> PGS.Connection
-> MateHandler [ProductOverview] -> MateHandler [ProductOverview]
productOverviewSelect refine conn = do productOverviewSelect refine conn = do
prods <- liftIO $ runSelect conn prods <- liftIO $ runSelect conn (produceProductOverviews refine)
( proc () -> do
-- (a1, _, a3, _, _)
-- <- arr
-- (\(arrdata, pid) -> (limit 1 (
-- orderBy (desc (\(_, ts, _, _, _) -> ts)) (
-- keepWhen (\(aid, _, _, _, _) -> pid .== aid) <<< arrdata)))) <<<
-- (arr (\pid -> (selectTable amountTable, pid))) -< pid
(pid, i2, i6, i7, i8, i9, i11, i12, i13, a3) ::
( Column PGInt4
, Column PGText
, Column PGInt4
, Column (Nullable PGInt4)
, Column (Nullable PGInt4)
, Column (PGInt4)
, Column (PGInt4)
, Column (Nullable SqlInt4)
, Column (Nullable SqlText)
, Column PGInt4
) <-
arr (\((p, i2, i6, i7, i8, i9, i11, i12, i13), (_, _, a3, _, _)) ->
(p, i2, i6, i7, i8, i9, i11, i12, i13, a3))
<<< leftJoin
(selectTable productTable)
(selectTable amountTable)
(\((pid, _, _, _, _, _, _, _, _), (aid, _, _, _, _)) ->
pid .== aid
) -< ()
restrict -< case refine of
AllProducts -> C.constant True
AvailableProducts -> a3 ./= C.constant (0 :: Int)
DepletedProducts -> a3 .== C.constant (0 :: Int)
returnA -< (pid, i2, i6, i7, i8, i9, i11, i12, i13)
) :: MateHandler
[ ( Int
, T.Text
, Int
, Maybe Int
, Maybe Int
, Int
, Int
, Maybe Int
, Maybe T.Text
)
]
mapM mapM
(generateProductOverview conn) (generateProductOverview conn)
prods prods
produceProductOverviews
:: ProductRefine
-> Select
( Column PGInt4
, Column PGText
, Column PGInt4
, Column (Nullable PGInt4)
, Column (Nullable PGInt4)
, Column PGInt4
, Column PGInt4
, Column (Nullable PGInt4)
, Column (Nullable PGText)
, Column PGInt4
, Column PGInt4
)
produceProductOverviews refine =
( proc () -> do
(p, i2, i6, i7, i8, i9, i11, i12, i13, a3, a4)
<- leftJoinF
(\(pid, pi2, pi6, pi7, pi8, pi9, pi11, pi12, pi13)
(aid, ai2, ai3, ai4, ai5) ->
(pid, pi2, pi6, pi7, pi8, pi9, pi11, pi12, pi13, ai3, ai4)
)
(\_ ->
( (C.constant (0 :: Int) :: Column PGInt4)
, (C.constant ("ERROR PRODUCT" :: T.Text) :: Column PGText)
, (C.constant (0 :: Int) :: Column PGInt4)
, (C.constant (Just (0 :: Int)) :: Column (Nullable PGInt4))
, (C.constant (Just (0 :: Int)) :: Column (Nullable PGInt4))
, (C.constant (0 :: Int) :: Column PGInt4)
, (C.constant (0 :: Int) :: Column PGInt4)
, (C.constant (Just (0 :: Int)) :: Column (Nullable PGInt4))
, (C.constant (Just ("" :: T.Text)) :: Column (Nullable PGText))
, (C.constant (0 :: Int) :: Column PGInt4)
, (C.constant (0 :: Int) :: Column PGInt4)
)
)
(\(pid, pi2, pi6, pi7, pi8, pi9, pi11, pi12, pi13)
(aid, ai2, ai3, ai4, ai5) ->
pid .== aid
)
(selectTable productTable)
(joinF
(\(a1, a2, a3, a4, a5) (b1, b2) ->
(b1, b2, a3, a4, a5)
)
(\(a1, a2, a3, a4, a5) (b1, b2) ->
(a1 .== b1) .&& (a2 .== b2)
)
(selectTable amountTable)
(aggregate
((,)
<$> P.lmap fst O.groupBy
<*> P.lmap snd O.max
)
(arr (\(a, b, c, d, e) -> (a, b)) <<< selectTable amountTable))
) -< ()
-- <<< arr (\_ -> (selectTable productTable, selectTable amountTable)) -< ()
restrict -< case refine of
AllProducts -> C.constant True
AvailableProducts -> a3 ./= (C.constant (0 :: Int) :: Column PGInt4)
DepletedProducts -> a3 .== (C.constant (0 :: Int) :: Column PGInt4)
returnA -< (p, i2, i6, i7, i8, i9, i11, i12, i13, a3, a4)
)
queryAmounts queryAmounts
:: PGS.Connection :: PGS.Connection
-> Int -> Int
@ -164,9 +189,20 @@ queryAmounts conn pid = runSelect conn $ proc () -> do
generateProductOverview generateProductOverview
:: PGS.Connection :: PGS.Connection
-> (Int, Text, Int, Maybe Int, Maybe Int, Int, Int, Maybe Int, Maybe Text) -> ( Int
, Text
, Int
, Maybe Int
, Maybe Int
, Int
, Int
, Maybe Int
, Maybe Text
, Int
, Int
)
-> MateHandler ProductOverview -> MateHandler ProductOverview
generateProductOverview conn (i1, i2, i3, i4, i5, i6, i7, i8, i9) = do generateProductOverview conn (i1, i2, i3, i4, i5, i6, i7, i8, i9, a3, a4) = do
amounts <- liftIO $ queryAmounts conn i1 amounts <- liftIO $ queryAmounts conn i1
(ii3, ii4) <- return $ (\(_, _, y, x, _) -> (x, y)) $ head amounts (ii3, ii4) <- return $ (\(_, _, y, x, _) -> (x, y)) $ head amounts
let ii5 = snd $ let ii5 = snd $
@ -181,38 +217,22 @@ generateProductOverview conn (i1, i2, i3, i4, i5, i6, i7, i8, i9) = do
ii10 = snd $ foldl (\(bef, tot) (_, _, amo, _, ver) -> ii10 = snd $ foldl (\(bef, tot) (_, _, amo, _, ver) ->
if ver if ver
then (amo, tot) then (amo, tot)
else (amo, tot + max 0 (bef - amo)) else (amo, tot + Prelude.max 0 (bef - amo))
) )
(0, 0) (0, 0)
(Prelude.reverse amounts) (Prelude.reverse amounts)
return $ ProductOverview return $ ProductOverview
i1 i2 ii3 ii4 ii5 i3 i4 i5 i6 ii10 i7 i8 i9 i1 i2 a3 a4 ii5 i3 i4 i5 i6 ii10 i7 i8 i9
productOverviewSelectSingle productOverviewSelectSingle
:: Int :: Int
-> PGS.Connection -> PGS.Connection
-> MateHandler ProductOverview -> MateHandler ProductOverview
productOverviewSelectSingle pid conn = do productOverviewSelectSingle pid conn = do
prods <- liftIO $ runSelect conn prods <- liftIO $ runSelect conn (produceProductOverviews AllProducts)
( proc () -> do
(i1, i2, i6, i7, i8, i9, i11, i12, i13) <- queryTable productTable -< ()
restrict -< C.constant pid .== i1
returnA -< (i1, i2, i6, i7, i8, i9, i11, i12, i13)
) :: MateHandler
[ ( Int
, T.Text
, Int
, Maybe Int
, Maybe Int
, Int
, Int
, Maybe Int
, Maybe T.Text
)
]
head <$> mapM head <$> mapM
(generateProductOverview conn) (generateProductOverview conn)
prods (Prelude.filter (\(p, _, _, _, _, _, _, _, _, _, _) -> p == pid) prods)
productShortOverviewSelect productShortOverviewSelect
@ -220,37 +240,24 @@ productShortOverviewSelect
-> PGS.Connection -> PGS.Connection
-> MateHandler [ProductShortOverview] -> MateHandler [ProductShortOverview]
productShortOverviewSelect refine conn = do productShortOverviewSelect refine conn = do
prods <- liftIO $ runSelect conn prods <- liftIO $ runSelect conn (produceProductOverviews refine)
( proc () -> do :: MateHandler [
(i1, i2, i6, i7, i8, i9, i11, i12, i13) <- queryTable productTable -< () ( Int
(a1, _, a3, _, _) <- , Text
limit 1 ( , Int
orderBy (desc (\(_, ts, _, _, _) -> ts)) (queryTable amountTable)) , Maybe Int
-< () , Maybe Int
restrict -< a1 .== i1 , Int
restrict -< case refine of , Int
AllProducts -> C.constant True , Maybe Int
AvailableProducts -> a3 ./= C.constant (0 :: Int) , Maybe Text
DepletedProducts -> a3 .== C.constant (0 :: Int) , Int
returnA -< (i1, i2, i6, i7, i8, i9, i11, i12, i13) , Int
) :: MateHandler )]
[ ( Int
, T.Text
, Int
, Maybe Int
, Maybe Int
, Int
, Int
, Maybe Int
, Maybe T.Text
)
]
mapM mapM
(\(i1, i2, i3, i4, _, _, _, _, _) -> do (\(i1, i2, i3, i4, _, _, _, _, _, a3, a4) -> do
amounts <- liftIO $ queryAmounts conn i1
(ii3, ii4) <- return $ (\(_, _, y, x, _) -> (x, y)) $ head amounts
return $ ProductShortOverview return $ ProductShortOverview
i1 i2 ii3 ii4 i3 i4 i1 i2 a4 a3 i3 i4
) )
prods prods