mateamt/src/Model/Product.hs

296 lines
7.7 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-07-18 15:09:26 +00:00
module Model.Product where
2019-04-15 20:23:25 +00:00
2019-07-21 13:02:59 +00:00
import Data.Text as T hiding (head, foldl)
2019-07-28 09:55:22 +00:00
import Data.Time.Clock (UTCTime)
import Data.Profunctor.Product (p9)
2019-04-15 20:23:25 +00:00
2019-07-18 12:57:35 +00:00
import Control.Monad.IO.Class (liftIO)
2019-07-28 09:55:22 +00:00
import Control.Arrow ((<<<), returnA)
2019-07-18 12:57:35 +00:00
2019-04-16 12:02:41 +00:00
import qualified Database.PostgreSQL.Simple as PGS
import Opaleye as O hiding (max)
2019-07-18 12:57:35 +00:00
import Opaleye.Constant as C
-- internal imports
import Types
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,"
, "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
, 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
2019-04-15 20:23:25 +00:00
, FieldNullable SqlInt4
, FieldNullable SqlText
)
2019-07-18 15:09:26 +00:00
productTable = table "product" (
2019-07-28 09:55:22 +00:00
p9
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"
, 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
2019-08-06 18:15:54 +00:00
prods <- liftIO $ runSelect conn
2019-07-18 15:09:26 +00:00
( keepWhen (\_ -> C.constant True) <<< queryTable productTable
2019-07-18 12:57:35 +00:00
) :: MateHandler
[ ( Int
, T.Text
, Int
, Maybe Int
, Maybe Int
, Int
2019-07-28 09:55:22 +00:00
, Int
, Maybe Int
, Maybe T.Text
)
]
mapM
2019-08-10 09:37:24 +00:00
(\(i1, i2, i3, i4, i5, i6, i7, i8, i9) -> return $
Product i1 i2 i3 i4 i5 i6 i7 i8 i9
2019-07-28 09:55:22 +00:00
)
2019-08-06 18:15:54 +00:00
prods
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-08-06 18:15:54 +00:00
prods <- liftIO $ runSelect conn
2019-07-28 09:55:22 +00:00
( proc () -> do
2019-09-11 02:03:25 +00:00
(pid, i2, i6, i7, i8, i9, i11, i12, i13) <- queryTable productTable -< ()
(a1, a2, a3, a4, a5) <-
limit 1 (
orderBy (desc (\(_, ts, _, _, _) -> ts)) (queryTable amountTable))
-< ()
restrict -< a1 .== pid
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)
2019-07-28 09:55:22 +00:00
) :: MateHandler
[ ( Int
, T.Text
, Int
, Maybe Int
, Maybe Int
2019-07-18 12:57:35 +00:00
, Int
, Int
, Maybe Int
, Maybe T.Text
)
]
mapM
2019-08-10 09:37:24 +00:00
(\(i1, i2, i3, i4, i5, i6, i7, i8, i9) -> do
2019-07-28 09:55:22 +00:00
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
)
]
2019-08-10 09:37:24 +00:00
(ii3, ii4) <- return $ (\(_, _, y, x, _) -> (x, y)) $ head amounts
ii5 <- return $ (\(_, x) -> x) $
2019-07-28 09:55:22 +00:00
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)
2019-08-10 09:37:24 +00:00
ii10 <- return $ snd $ foldl (\(bef, tot) (_, _, amo, _, ver) ->
2019-07-28 09:55:22 +00:00
if ver
then (amo, tot)
else (amo, tot + max 0 (bef - amo))
2019-07-28 09:55:22 +00:00
)
(0, 0)
(Prelude.reverse amounts)
return $ ProductOverview
2019-08-10 09:37:24 +00:00
i1 i2 ii3 ii4 ii5 i3 i4 i5 i6 ii10 i7 i8 i9
2019-07-18 12:57:35 +00:00
)
2019-08-06 18:15:54 +00:00
prods
productOverviewSelectSingle
:: Int
-> PGS.Connection
-> MateHandler ProductOverview
productOverviewSelectSingle pid conn = do
prods <- liftIO $ runSelect conn
( 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
2019-08-10 09:37:24 +00:00
(\(i1, i2, i3, i4, i5, i6, i7, i8, i9) -> do
2019-08-06 18:15:54 +00:00
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
)
]
2019-08-10 09:37:24 +00:00
(ii3, ii4) <- return $ (\(_, _, y, x, _) -> (x, y)) $ head amounts
ii5 <- return $ (\(_, x) -> x) $
2019-08-06 18:15:54 +00:00
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)
2019-08-10 09:37:24 +00:00
ii10 <- return $ snd $ foldl (\(bef, tot) (_, _, amo, _, ver) ->
2019-08-06 18:15:54 +00:00
if ver
then (amo, tot)
else (amo, tot + max 0 (bef - amo))
)
(0, 0)
(Prelude.reverse amounts)
return $ ProductOverview
2019-08-10 09:37:24 +00:00
i1 i2 ii3 ii4 ii5 i3 i4 i5 i6 ii10 i7 i8 i9
2019-08-06 18:15:54 +00:00
)
prods
2019-07-18 12:57:35 +00:00
2019-08-03 07:30:18 +00:00
productShortOverviewSelect
:: PGS.Connection
-> MateHandler [ProductShortOverview]
productShortOverviewSelect conn = do
2019-08-06 18:15:54 +00:00
prods <- liftIO $ runSelect conn
2019-08-03 07:30:18 +00:00
( 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
, Maybe Int
, Maybe Int
, Int
, Int
, Maybe Int
, Maybe T.Text
)
]
mapM
2019-09-07 00:48:16 +00:00
(\(i1, i2, i3, i4, _, _, _, _, _) -> do
2019-08-03 07:30:18 +00:00
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
)
]
2019-08-10 09:37:24 +00:00
(ii3, ii4) <- return $ (\(_, _, y, x, _) -> (x, y)) $ head amounts
2019-08-03 07:30:18 +00:00
return $ ProductShortOverview
2019-08-10 09:37:24 +00:00
i1 i2 ii3 ii4 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
2019-09-07 00:48:16 +00:00
insertProduct (ProductSubmit ident _ ml ava sup maxi apc ppc artnr) conn =
2019-07-28 09:55:22 +00:00
fmap head $ liftIO $ runInsert_ conn $ Insert
{ iTable = productTable
, iRows =
[
( C.constant (Nothing :: Maybe Int)
, C.constant ident
, C.constant ml
, C.constant ava
, C.constant sup
2019-09-07 00:48:16 +00:00
, C.constant maxi
2019-07-28 09:55:22 +00:00
, C.constant apc
, C.constant ppc
, C.constant artnr
)
]
2019-08-09 18:56:04 +00:00
, iReturning = rReturning (\(id_, _, _, _, _, _, _, _, _) -> id_)
2019-07-28 09:55:22 +00:00
, iOnConflict = Nothing
}