mateamt/src/Model/Product.hs

486 lines
12 KiB
Haskell
Raw Normal View History

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
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
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-07-21 13:02:59 +00:00
[ "create table if not exists \"product\" ("
, "product_id serial primary key,"
, "product_ident varchar(128) not null,"
2019-07-27 14:34:28 +00:00
-- , "product_price integer not null,"
-- , "product_amount integer not null,"
-- , "product_vanish integer not null,"
2019-07-21 13:02:59 +00:00
, "product_ml integer not null,"
, "product_avatar integer,"
, "product_supplier integer,"
, "product_max_amount integer not null,"
2019-07-28 09:55:22 +00:00
-- , "product_total_bought integer not null,"
2019-07-21 13:02:59 +00:00
, "product_amount_per_crate integer not null,"
, "product_price_per_crate integer,"
, "product_art_nr varchar(128)"
, ")"
]
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
2019-07-27 14:34:28 +00:00
-- , Field SqlInt4
-- , Field SqlInt4
-- , Field SqlInt4
2019-04-16 12:02:41 +00:00
, Field SqlInt4
2019-04-15 20:23:25 +00:00
, FieldNullable SqlInt4
, FieldNullable SqlInt4
2019-04-16 12:02:41 +00:00
, Field SqlInt4
2019-07-28 09:55:22 +00:00
-- , Field SqlInt4
2019-04-16 12:02:41 +00:00
, 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
2019-07-27 14:34:28 +00:00
-- , Field SqlInt4
-- , Field SqlInt4
-- , Field SqlInt4
2019-04-16 12:02:41 +00:00
, Field SqlInt4
, FieldNullable SqlInt4
2019-04-15 20:23:25 +00:00
, FieldNullable SqlInt4
2019-04-16 12:02:41 +00:00
, Field SqlInt4
2019-07-28 09:55:22 +00:00
-- , Field SqlInt4
2019-04-16 12:02:41 +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" (
2019-07-28 09:55:22 +00:00
p9
2019-07-18 15:09:26 +00:00
( tableField "product_id"
, tableField "product_ident"
2019-07-27 14:34:28 +00:00
-- , tableField "product_price"
-- , tableField "product_amount"
-- , tableField "product_vanish"
2019-07-18 15:09:26 +00:00
, tableField "product_ml"
, tableField "product_avatar"
, tableField "product_supplier"
, tableField "product_max_amount"
2019-07-28 09:55:22 +00:00
-- , tableField "product_total_bought"
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
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
2019-07-27 14:34:28 +00:00
-- , Int
-- , Int
-- , Int
2019-07-18 12:57:35 +00:00
, Int
, Maybe Int
, Maybe Int
, Int
2019-07-28 09:55:22 +00:00
-- , Int
, Int
, Maybe Int
, Maybe T.Text
)
]
mapM
(\(i1, i2, {-i3, i4, i5,-} i6, i7, i8, i9, {-i10,-} i11, i12, i13) -> return $
Product i1 i2 {-i3 i4 i5-} i6 i7 i8 i9 {-i10-} i11 i12 i13
)
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
-- , Int
-- , Int
, Int
, Maybe Int
, Maybe Int
2019-07-18 12:57:35 +00:00
, Int
2019-07-28 09:55:22 +00:00
-- , Int
2019-07-18 12:57:35 +00:00
, Int
, Maybe Int
, Maybe T.Text
)
]
mapM
2019-07-28 09:55:22 +00:00
(\(i1, i2, {-i3, i4, i5,-} i6, i7, i8, i9, {-i10,-} i11, i12, i13) -> do
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
)
]
(i3, i4) <- return $ (\(_, _, y, x, _) -> (x, y)) $ head amounts
i5 <- return $ (\(_, x) -> x) $
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)
i10 <- return $ snd $ foldl (\(bef, tot) (_, _, amo, _, ver) ->
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
i1 i2 i3 i4 i5 i6 i7 i8 i9 i10 i11 i12 i13
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
-- , Int
-- , Int
, Int
, Maybe Int
, Maybe Int
, Int
-- , Int
, Int
, Maybe Int
, Maybe T.Text
)
]
head <$> mapM
(\(i1, i2, {-i3, i4, i5,-} i6, i7, i8, i9, {-i10,-} i11, i12, i13) -> do
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
)
]
(i3, i4) <- return $ (\(_, _, y, x, _) -> (x, y)) $ head amounts
i5 <- return $ (\(_, x) -> x) $
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)
i10 <- return $ snd $ foldl (\(bef, tot) (_, _, amo, _, ver) ->
if ver
then (amo, tot)
else (amo, tot + max 0 (bef - amo))
)
(0, 0)
(Prelude.reverse amounts)
return $ ProductOverview
i1 i2 i3 i4 i5 i6 i7 i8 i9 i10 i11 i12 i13
)
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
-- , Int
-- , Int
, Int
, Maybe Int
, Maybe Int
, Int
-- , Int
, Int
, Maybe Int
, Maybe T.Text
)
]
mapM
(\(i1, i2, {-i3, i4, i5,-} i6, i7, i8, i9, {-i10,-} i11, i12, i13) -> do
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
)
]
(i3, i4) <- return $ (\(_, _, y, x, _) -> (x, y)) $ head amounts
i5 <- return $ (\(_, x) -> x) $
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)
i10 <- return $ snd $ foldl (\(bef, tot) (_, _, amo, _, ver) ->
if ver
then (amo, tot)
else (amo, tot + (bef - amo))
)
(0, 0)
(Prelude.reverse amounts)
return $ ProductShortOverview
i1 i2 i3 i4 i6 i7
)
2019-08-06 18:15:54 +00:00
prods
2019-08-03 07:30:18 +00:00
2019-07-27 14:34:28 +00:00
-- getProductPrice
-- :: PurchaseDetail
-- -> PGS.Connection
-- -> MateHandler Int
-- getProductPrice (PurchaseDetail bid amount) conn = do
-- when (amount < 0) (
-- throwError $ err406
-- { errBody = "Amounts less or equal zero are not acceptable"
-- }
-- )
-- bevs <- liftIO $ runSelect conn
-- ( keepWhen
-- (\(id_, _, _, _, _, _, _, _, _, _, _) -> id_ .== C.constant bid) <<<
-- queryTable productTable
-- ) :: MateHandler
-- [ ( Int
-- , T.Text
-- -- , Int
-- -- , Int
-- , Int
-- , Int
-- , Maybe Int
-- , Maybe Int
-- , Int
-- , Int
-- , Int
-- , Maybe Int
-- , Maybe T.Text
-- )
-- ]
-- (amount *) <$> head <$> mapM
-- (\(i1, i2, {-i3, i4,-} i5, i6, i7, i8, i9, i10, i11, i12, i13) -> return $
-- i3
-- )
-- bevs
2019-07-18 17:01:49 +00:00
2019-07-27 14:34:28 +00:00
-- checkProductAvailability
-- :: PGS.Connection
-- -> PurchaseDetail
-- -> MateHandler (Maybe Int) -- | returns maybe missing amount
-- checkProductAvailability conn (PurchaseDetail bid amount) = do
-- when (amount <= 0) $
-- throwError $ err406
-- { errBody = "Amounts less or equal zero are not acceptable"
-- }
-- bevs <- liftIO $ runSelect conn
-- ( keepWhen
-- (\(id_, _, _, _, _, _, _, _, _, _, _) -> id_ .== C.constant bid) <<<
-- queryTable productTable
-- ) :: MateHandler
-- [ ( Int
-- , T.Text
-- , Int
-- -- , Int
-- -- , Int
-- , Int
-- , Maybe Int
-- , Maybe Int
-- , Int
-- , Int
-- , Int
-- , Maybe Int
-- , Maybe T.Text
-- )
-- ]
-- realamount <- head <$> mapM
-- (\(i1, i2, i3, {-i4, i5,-} i6, i7, i8, i9, i10, i11, i12, i13) -> return $
-- i4
-- )
-- bevs
-- if realamount < amount
-- then return (Just (amount - realamount))
-- else return Nothing
2019-07-20 16:36:47 +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 price
-- , C.constant (0 :: Int)
-- , C.constant (0 :: Int)
, C.constant ml
, C.constant ava
, C.constant sup
, C.constant max
-- , C.constant (0 :: Int)
, C.constant apc
, C.constant ppc
, C.constant artnr
)
]
, iReturning = rReturning (\(id, _, _, _, _, _, _, _, _) -> id)
, iOnConflict = Nothing
}
2019-07-27 14:34:28 +00:00
-- updateProduct
-- :: Int
-- -> ProductSubmit
-- -> Update Int64
-- updateProduct sid (ProductSubmit ident price ml ava sup max apc ppc artnr) = Update
-- { uTable = productTable
-- , uUpdateWith = updateEasy (\(id_, _, _, amo, van, _, _, _, _, tot, _, _, _) ->
-- ( id_
-- , C.constant ident
-- , C.constant price
-- , amo
-- , van
-- , C.constant ml
-- , C.constant ava
-- , C.constant sup
-- , C.constant max
-- , tot
-- , C.constant apc
-- , C.constant ppc
-- , C.constant artnr
-- )
-- )
-- , uWhere =
-- (\(id_, _, _, _, _, _, _, _, _, _, _, _, _) ->
-- id_ .== C.constant sid
-- )
-- , uReturning = rCount
-- }
2019-07-20 16:36:47 +00:00
2019-07-27 14:34:28 +00:00
-- reduceProductAmount
-- :: PurchaseDetail
-- -> Update Int64
-- reduceProductAmount (PurchaseDetail pid amount) = Update
-- { uTable = productTable
-- , uUpdateWith = updateEasy
-- (\(id_, ident, price, amo, van, ml, ava, sup, max, tot, apc, ppc, artnr) ->
-- ( id_
-- , ident
-- , price
-- , amo - C.constant amount
-- , van
-- , ml
-- , ava
-- , sup
-- , max
-- , tot + C.constant amount
-- , apc
-- , ppc
-- , artnr
-- )
-- )
-- , uWhere =
-- (\(id_, _, _, _, _, _, _, _, _, _, _, _, _) ->
-- id_ .== C.constant pid
-- )
-- , uReturning = rCount
-- }