mateamt/src/Model/Product.hs

300 lines
7.6 KiB
Haskell
Raw Normal View History

2019-04-16 12:02:41 +00:00
{-# LANGUAGE OverloadedStrings #-}
2019-07-28 09:55:22 +00:00
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE Arrows #-}
2019-10-19 19:39:41 +00:00
{-# LANGUAGE ScopedTypeVariables #-}
2019-07-18 15:09:26 +00:00
module Model.Product where
2019-04-15 20:23:25 +00:00
import Data.Text (Text)
2019-12-14 23:03:49 +00:00
import Data.Time (getCurrentTime)
2021-07-12 11:29:40 +00:00
import Data.Profunctor.Product (p10)
2019-04-15 20:23:25 +00:00
import Data.Maybe
2019-07-18 12:57:35 +00:00
import Control.Monad.IO.Class (liftIO)
2019-10-21 18:40:30 +00:00
import Control.Arrow
2019-07-18 12:57:35 +00:00
2019-04-16 12:02:41 +00:00
import qualified Database.PostgreSQL.Simple as PGS
2019-10-21 18:40:30 +00:00
import qualified Data.Profunctor as P
import Opaleye as O
2019-07-18 12:57:35 +00:00
-- internal imports
import Types
import Classes
2019-07-28 09:55:22 +00:00
import Model.Amount
2019-04-15 20:23:25 +00:00
2019-07-18 15:09:26 +00:00
initProduct :: PGS.Query
2019-07-21 14:05:05 +00:00
initProduct = mconcat
2019-08-10 09:40:01 +00:00
[ "CREATE TABLE IF NOT EXISTS \"product\" ("
, "product_id SERIAL PRIMARY KEY,"
, "product_ident TEXT NOT NULL,"
, "product_ml INTEGER NOT NULL,"
, "product_avatar INTEGER,"
, "product_supplier INTEGER,"
, "product_max_amount INTEGER NOT NULL,"
2021-07-12 11:29:40 +00:00
, "product_min_amount INTEGER NOT NULL,"
2019-08-10 09:40:01 +00:00
, "product_amount_per_crate INTEGER NOT NULL,"
, "product_price_per_crate INTEGER,"
, "product_art_nr TEXT"
2019-07-21 13:02:59 +00:00
, ")"
]
2019-04-16 12:02:41 +00:00
2019-07-18 15:09:26 +00:00
productTable :: Table
2019-04-16 12:02:41 +00:00
( Maybe (Field SqlInt4)
, Field SqlText
, Field SqlInt4
2019-04-15 20:23:25 +00:00
, FieldNullable SqlInt4
, FieldNullable SqlInt4
2019-04-16 12:02:41 +00:00
, Field SqlInt4
, Field SqlInt4
2021-07-12 11:29:40 +00:00
, Field SqlInt4
2019-04-16 12:02:41 +00:00
, FieldNullable SqlInt4
2019-04-15 20:23:25 +00:00
, FieldNullable SqlText
)
2019-04-16 12:02:41 +00:00
( Field SqlInt4
, Field SqlText
, Field SqlInt4
, FieldNullable SqlInt4
2019-04-15 20:23:25 +00:00
, FieldNullable SqlInt4
2019-04-16 12:02:41 +00:00
, Field SqlInt4
, Field SqlInt4
2021-07-12 11:29:40 +00:00
, Field SqlInt4
2019-04-15 20:23:25 +00:00
, FieldNullable SqlInt4
, FieldNullable SqlText
)
2019-07-18 15:09:26 +00:00
productTable = table "product" (
2021-07-12 11:29:40 +00:00
p10
2019-07-18 15:09:26 +00:00
( tableField "product_id"
, tableField "product_ident"
, tableField "product_ml"
, tableField "product_avatar"
, tableField "product_supplier"
, tableField "product_max_amount"
2021-07-12 11:29:40 +00:00
, tableField "product_min_amount"
2019-07-18 15:09:26 +00:00
, tableField "product_amount_per_crate"
, tableField "product_price_per_crate"
, tableField "product_art_nr"
2019-04-15 20:23:25 +00:00
)
)
2019-07-18 12:57:35 +00:00
2019-07-28 09:55:22 +00:00
2019-07-18 15:09:26 +00:00
productSelect
2019-07-18 12:57:35 +00:00
:: PGS.Connection
2019-07-18 15:09:26 +00:00
-> MateHandler [Product]
productSelect conn = do
liftIO $ map fromDatabase <$> runSelect conn
2021-07-14 01:08:58 +00:00
(selectTable productTable)
2019-07-28 09:55:22 +00:00
2019-12-14 23:03:49 +00:00
productSelectSingle
:: Int
-> PGS.Connection
-> MateHandler (Maybe Product)
2019-12-14 23:03:49 +00:00
productSelectSingle pid conn = do
2022-04-15 13:35:53 +00:00
prods <- liftIO $ map fromDatabase <$> runSelect conn ( proc () -> do
stuff@(id_, _, _, _, _, _, _, _, _, _) <- limit 1 (selectTable productTable) -< ()
restrict -< id_ .== toFields pid
returnA -< stuff)
case prods of
p:_ -> return (Just p)
_ -> return Nothing
2019-12-14 23:03:49 +00:00
2019-07-28 09:55:22 +00:00
productOverviewSelect
2019-09-09 11:17:43 +00:00
:: ProductRefine
-> PGS.Connection
2019-07-28 09:55:22 +00:00
-> MateHandler [ProductOverview]
2019-09-11 02:03:25 +00:00
productOverviewSelect refine conn = do
2019-10-21 18:40:30 +00:00
prods <- liftIO $ runSelect conn (produceProductOverviews refine)
2019-07-18 12:57:35 +00:00
mapM
2019-10-14 21:34:45 +00:00
(generateProductOverview conn)
2019-08-06 18:15:54 +00:00
prods
2019-10-21 18:40:30 +00:00
produceProductOverviews
:: ProductRefine
-> Select
2022-04-15 13:35:53 +00:00
( Column SqlInt4
, Column SqlText
, Column SqlInt4
, Column (Nullable SqlInt4)
, Column (Nullable SqlInt4)
, Column SqlInt4
, Column SqlInt4
, Column SqlInt4
, Column (Nullable SqlInt4)
, Column (Nullable SqlText)
, Column SqlInt4
, Column SqlInt4
2019-10-21 18:40:30 +00:00
)
produceProductOverviews refine =
2019-12-12 02:15:56 +00:00
proc () -> do
2022-04-15 17:09:44 +00:00
(p, i2, i6, i6a, i7, i8, i9, i11, i12, i13) <-
selectTable productTable -< ()
(_, _, a3, a4, _) <- do
(a1, a2, a3, a4, a5) <- selectTable amountTable -< ()
(b1, b2) <- do
(ib1, ib2, _, _, _) <- selectTable amountTable -< ()
(laterally . aggregate)
(
(,)
<$> P.lmap fst O.groupBy
<*> P.lmap snd O.max
)
(arr (\(ib1, ib2, _, _, _) -> (ib1, ib2)) <<< selectTable amountTable ) -< ()
returnA -< (ib1, ib2)
restrict -< a1 .== b1 .&& a2 .== b2
returnA -< (b1, b2, a3, a4, a5)
2019-12-12 02:15:56 +00:00
restrict -< case refine of
2021-07-14 01:08:58 +00:00
AllProducts -> toFields True
2022-04-15 13:35:53 +00:00
AvailableProducts -> a3 ./= (toFields (0 :: Int) :: Column SqlInt4)
DepletedProducts -> a3 .== (toFields (0 :: Int) :: Column SqlInt4)
2021-07-12 11:29:40 +00:00
returnA -< (p, i2, i6, i6a, i7, i8, i9, i11, i12, i13, a3, a4)
2019-10-21 18:40:30 +00:00
2019-10-14 21:34:45 +00:00
queryAmounts
:: PGS.Connection
-> Int
-> IO [Amount]
queryAmounts conn pid = map fromDatabase <$> runSelect conn (proc () -> do
2019-10-14 21:34:45 +00:00
stuff@(a1, _, _, _, _) <- orderBy (desc (\(_, ts, _, _, _) -> ts))
2021-07-14 01:08:58 +00:00
(selectTable amountTable) -< ()
restrict -< toFields pid .== a1
2019-10-14 21:34:45 +00:00
returnA -< stuff
)
2019-10-14 21:34:45 +00:00
generateProductOverview
:: PGS.Connection
2019-10-21 18:40:30 +00:00
-> ( Int
, Text
, Int
, Maybe Int
, Maybe Int
, Int
, Int
2021-07-12 11:29:40 +00:00
, Int
2019-10-21 18:40:30 +00:00
, Maybe Int
, Maybe Text
, Int
, Int
)
2019-10-14 21:34:45 +00:00
-> MateHandler ProductOverview
2021-07-12 11:29:40 +00:00
generateProductOverview conn (i1, i2, i3, i4, i5, i6, i6a, i7, i8, i9, a3, a4) = do
2019-10-14 21:34:45 +00:00
amounts <- liftIO $ queryAmounts conn i1
let ii5 = snd $
foldl
(\(bef, van) (Amount _ _ amo _ ver) ->
2019-10-14 21:34:45 +00:00
if ver
then (amo, if amo < bef then van + (bef - amo) else van)
else (amo, van)
)
(0, 0)
(reverse amounts)
ii10 = snd $ foldl (\(bef, tot) (Amount _ _ amo _ ver) ->
2019-10-14 21:34:45 +00:00
if ver
then (amo, tot)
2019-10-21 18:40:30 +00:00
else (amo, tot + Prelude.max 0 (bef - amo))
2019-10-14 21:34:45 +00:00
)
(0, 0)
(Prelude.reverse amounts)
return $ ProductOverview
2021-07-12 11:29:40 +00:00
i1 i2 a4 a3 ii5 i3 i4 i5 i6 i6a ii10 i7 i8 i9
2019-08-06 18:15:54 +00:00
productOverviewSelectSingle
:: Int
-> PGS.Connection
-> MateHandler ProductOverview
productOverviewSelectSingle pid conn = do
2019-10-21 18:40:30 +00:00
prods <- liftIO $ runSelect conn (produceProductOverviews AllProducts)
2019-08-06 18:15:54 +00:00
head <$> mapM
2019-10-14 21:34:45 +00:00
(generateProductOverview conn)
2021-07-12 11:29:40 +00:00
(Prelude.filter (\(p, _, _, _, _, _, _, _, _, _, _, _) -> p == pid) prods)
2019-07-18 12:57:35 +00:00
2019-08-03 07:30:18 +00:00
productShortOverviewSelect
:: ProductRefine
-> PGS.Connection
2019-08-03 07:30:18 +00:00
-> MateHandler [ProductShortOverview]
productShortOverviewSelect refine conn = do
2019-10-21 18:40:30 +00:00
prods <- liftIO $ runSelect conn (produceProductOverviews refine)
2019-10-27 21:46:07 +00:00
:: MateHandler
[( Int
2019-10-21 18:40:30 +00:00
, Text
, Int
, Maybe Int
, Maybe Int
, Int
, Int
2021-07-12 11:29:40 +00:00
, Int
2019-10-21 18:40:30 +00:00
, Maybe Int
, Maybe Text
, Int
, Int
)]
2019-08-03 07:30:18 +00:00
mapM
2021-07-12 11:29:40 +00:00
(\(i1, i2, i3, i4, _, _, _, _, _, _, a3, a4) ->
2019-08-03 07:30:18 +00:00
return $ ProductShortOverview
2019-10-21 18:40:30 +00:00
i1 i2 a4 a3 i3 i4
2019-08-03 07:30:18 +00:00
)
2019-08-06 18:15:54 +00:00
prods
2019-08-03 07:30:18 +00:00
2019-07-18 15:09:26 +00:00
insertProduct
:: ProductSubmit
2019-07-28 09:55:22 +00:00
-> PGS.Connection
-> MateHandler Int
2021-07-12 11:29:40 +00:00
insertProduct (ProductSubmit ident _ ml ava sup maxi mini apc ppc artnr) conn =
2019-07-28 09:55:22 +00:00
fmap head $ liftIO $ runInsert_ conn $ Insert
{ iTable = productTable
, iRows =
[
2021-07-14 01:08:58 +00:00
( toFields (Nothing :: Maybe Int)
, toFields ident
, toFields ml
, toFields ava
, toFields sup
, toFields maxi
, toFields mini
, toFields apc
, toFields ppc
, toFields artnr
2019-07-28 09:55:22 +00:00
)
]
2021-07-12 11:29:40 +00:00
, iReturning = rReturning (\(id_, _, _, _, _, _, _, _, _, _) -> id_)
2019-07-28 09:55:22 +00:00
, iOnConflict = Nothing
}
2019-12-14 23:03:49 +00:00
manualProductAmountRefill
:: [AmountRefill]
-> PGS.Connection
-> MateHandler [Int]
manualProductAmountRefill aups conn =
mapM
(\(AmountRefill pid amountSingles amountCrates) -> do
oldamount <- getLatestAmountByProductId pid conn
oldprice <- getLatestPriceByProductId pid conn
perCrate <- productAmountPerCrate . fromJust <$>
2019-12-14 23:03:49 +00:00
productSelectSingle pid conn
head <$> liftIO (do
2022-04-15 18:40:04 +00:00
now_ <- getCurrentTime
2019-12-14 23:03:49 +00:00
runInsert_ conn $ Insert
{ iTable = amountTable
, iRows =
[
2021-07-14 01:08:58 +00:00
( toFields pid
2022-04-15 18:40:04 +00:00
, toFields now_
2021-07-14 01:08:58 +00:00
, toFields (oldamount + (amountSingles + (perCrate * amountCrates)))
, toFields oldprice
, toFields False
2019-12-14 23:03:49 +00:00
)
]
, iReturning = rReturning (\(id_, _, _, _, _) -> id_)
, iOnConflict = Nothing
}
)
)
aups