2019-04-15 20:23:25 +00:00
|
|
|
{-# LANGUAGE DeriveGeneric #-}
|
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-20 16:36:47 +00:00
|
|
|
import Servant.Server
|
|
|
|
|
2019-07-21 13:02:59 +00:00
|
|
|
import Data.Text as T hiding (head, foldl)
|
2019-04-15 20:23:25 +00:00
|
|
|
import Data.Time.Calendar (Day)
|
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
|
|
|
|
|
|
|
import Data.Aeson
|
|
|
|
import Data.Aeson.Types
|
|
|
|
|
2019-07-18 14:58:22 +00:00
|
|
|
import Data.Int (Int64)
|
|
|
|
|
2019-07-20 16:36:47 +00:00
|
|
|
import Control.Monad (when)
|
2019-07-18 12:57:35 +00:00
|
|
|
import Control.Monad.IO.Class (liftIO)
|
2019-07-20 16:36:47 +00:00
|
|
|
import Control.Monad.Error.Class (throwError)
|
2019-07-18 12:57:35 +00:00
|
|
|
|
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
|
|
|
|
|
2019-04-15 20:23:25 +00:00
|
|
|
import GHC.Generics
|
|
|
|
|
2019-08-05 16:11:10 +00:00
|
|
|
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
|
|
|
|
:: PGS.Connection
|
|
|
|
-> MateHandler [ProductOverview]
|
|
|
|
productOverviewSelect conn = do
|
2019-08-06 18:15:54 +00:00
|
|
|
prods <- liftIO $ runSelect conn
|
2019-07-28 09:55:22 +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
|
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)
|
2019-08-05 16:11:10 +00:00
|
|
|
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-07-18 14:58:22 +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-08-10 09:37:24 +00:00
|
|
|
(\(i1, i2, i3, i4, i5, i6, i7, i8, i9) -> 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
|
|
|
|
ii5 <- return $ (\(_, x) -> x) $
|
2019-08-03 07:30:18 +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-03 07:30:18 +00:00
|
|
|
if ver
|
|
|
|
then (amo, tot)
|
|
|
|
else (amo, tot + (bef - amo))
|
|
|
|
)
|
|
|
|
(0, 0)
|
|
|
|
(Prelude.reverse amounts)
|
|
|
|
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
|
|
|
|
insertProduct (ProductSubmit ident price ml ava sup max apc ppc artnr) conn =
|
|
|
|
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
|
|
|
|
, C.constant max
|
|
|
|
, 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
|
|
|
|
}
|