fix product overview queries

mateamt.cabal

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

src/Model/Product.hs

@@ -10,11 +10,15 @@ import Data.Profunctor.Product (p9)
 
 import Control.Monad.IO.Class (liftIO)
 
-import Control.Arrow ((<<<), returnA, arr)
+import Control.Arrow
 
 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
 
 -- internal imports
@@ -103,55 +107,76 @@ productOverviewSelect
   -> PGS.Connection
   -> MateHandler [ProductOverview]
 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
     (generateProductOverview conn)
     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
   :: PGS.Connection
   -> Int
@@ -164,9 +189,20 @@ queryAmounts conn pid = runSelect conn $ proc () -> do
 
 generateProductOverview
   :: 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
-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
   (ii3, ii4) <- return $ (\(_, _, y, x, _) -> (x, y)) $ head amounts
   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) ->
         if ver
         then (amo, tot)
-        else (amo, tot + max 0 (bef - amo))
+        else (amo, tot + Prelude.max 0 (bef - amo))
         )
         (0, 0)
         (Prelude.reverse amounts)
   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
   :: Int
   -> PGS.Connection
   -> MateHandler ProductOverview
 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
     (generateProductOverview conn)
-    prods
+    (Prelude.filter (\(p, _, _, _, _, _, _, _, _, _, _) -> p == pid) prods)
 
 
 productShortOverviewSelect
@@ -220,37 +240,24 @@ productShortOverviewSelect
   -> PGS.Connection
   -> MateHandler [ProductShortOverview]
 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
-    (\(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
-        i1 i2 ii3 ii4 i3 i4
+        i1 i2 a4 a3 i3 i4
       )
     prods