mateamt/src/Model/Product.hs

272 lines
6.4 KiB
Haskell

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
module Model.Product where
import Servant.Server
import Data.Text as T hiding (head)
import Data.Time.Calendar (Day)
import Data.Profunctor.Product (p13)
import Data.Aeson
import Data.Aeson.Types
import Data.Int (Int64)
import Control.Monad (when)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Error.Class (throwError)
import Control.Arrow ((<<<))
import qualified Database.PostgreSQL.Simple as PGS
import GHC.Generics
import Opaleye as O
import Opaleye.Constant as C
-- internal imports
import Types
initProduct :: PGS.Query
initProduct = "create Table if not exists \"product\" (product_id serial primary key, product_ident varchar(128) not null, product_price integer not null, product_amount integer not null, product_vanish integer not null, product_ml integer not null, product_avatar integer, product_supplier integer, product_max_amount integer not null, product_total_bought integer not null, product_amount_per_crate integer not null, product_price_per_crate integer, product_art_nr varchar(128))"
productTable :: Table
( Maybe (Field SqlInt4)
, Field SqlText
, Field SqlInt4
, Field SqlInt4
, Field SqlInt4
, Field SqlInt4
, FieldNullable SqlInt4
, FieldNullable SqlInt4
, Field SqlInt4
, Field SqlInt4
, Field SqlInt4
, FieldNullable SqlInt4
, FieldNullable SqlText
)
( Field SqlInt4
, Field SqlText
, Field SqlInt4
, Field SqlInt4
, Field SqlInt4
, Field SqlInt4
, FieldNullable SqlInt4
, FieldNullable SqlInt4
, Field SqlInt4
, Field SqlInt4
, Field SqlInt4
, FieldNullable SqlInt4
, FieldNullable SqlText
)
productTable = table "product" (
p13
( tableField "product_id"
, tableField "product_ident"
, tableField "product_price"
, tableField "product_amount"
, tableField "product_vanish"
, tableField "product_ml"
, tableField "product_avatar"
, tableField "product_supplier"
, tableField "product_max_amount"
, tableField "product_total_bought"
, tableField "product_amount_per_crate"
, tableField "product_price_per_crate"
, tableField "product_art_nr"
)
)
productSelect
:: PGS.Connection
-> MateHandler [Product]
productSelect conn = do
bevs <- liftIO $ runSelect conn
( keepWhen (\_ -> C.constant True) <<< queryTable productTable
) :: 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) -> return $
Product i1 i2 i3 i4 i5 i6 i7 i8 i9 i10 i11 i12 i13
)
bevs
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
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
insertProduct
:: ProductSubmit
-> Insert [Int]
insertProduct (ProductSubmit ident price ml ava sup max apc ppc artnr) = 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
}
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
}
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
}