2019-04-15 20:23:25 +00:00
{- # LANGUAGE DeriveGeneric # -}
2019-04-16 12:02:41 +00:00
{- # LANGUAGE OverloadedStrings # -}
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
import Data.Text as T hiding ( head )
2019-04-15 20:23:25 +00:00
import Data.Time.Calendar ( Day )
2019-04-16 12:02:41 +00:00
import Data.Profunctor.Product ( p13 )
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
import Control.Arrow ( ( <<< ) )
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
2019-07-18 12:57:35 +00:00
import Opaleye.Constant as C
-- internal imports
import Types
2019-04-15 20:23:25 +00:00
2019-07-18 15:09:26 +00:00
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)) "
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
, Field SqlInt4
, Field SqlInt4
, 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
, 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
, Field SqlInt4
, Field SqlInt4
, 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
, 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-04-16 12:02:41 +00:00
p13
2019-07-18 15:09:26 +00:00
( 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 "
2019-04-15 20:23:25 +00:00
)
)
2019-07-18 12:57:35 +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-07-18 12:57:35 +00:00
bevs <- 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
, 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 $
2019-07-18 15:09:26 +00:00
Product i1 i2 i3 i4 i5 i6 i7 i8 i9 i10 i11 i12 i13
2019-07-18 12:57:35 +00:00
)
bevs
2019-07-18 14:58:22 +00:00
2019-07-18 17:01:49 +00:00
getProductPrice
:: PurchaseDetail
-> PGS . Connection
-> MateHandler Int
2019-07-20 16:36:47 +00:00
getProductPrice ( PurchaseDetail bid amount ) conn = do
when ( amount < 0 ) (
2019-07-18 17:01:49 +00:00
throwError $ err406
{ errBody = " Amounts less or equal zero are not acceptable "
2019-07-20 16:36:47 +00:00
}
)
2019-07-18 17:01:49 +00:00
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-20 16:36:47 +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-18 15:09:26 +00:00
insertProduct
:: ProductSubmit
2019-07-18 12:57:35 +00:00
-> Insert [ Int ]
2019-07-18 15:09:26 +00:00
insertProduct ( ProductSubmit ident price ml ava sup max apc ppc artnr ) = Insert
{ iTable = productTable
2019-07-18 12:57:35 +00:00
, iRows =
[
( C . constant ( Nothing :: Maybe Int )
, C . constant ident
, C . constant price
, C . constant ( 0 :: Int )
, C . constant ( 0 :: Int )
, C . constant ml
2019-07-18 14:58:22 +00:00
, C . constant ava
2019-07-18 12:57:35 +00:00
, 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-18 14:58:22 +00:00
2019-07-18 15:09:26 +00:00
updateProduct
2019-07-18 14:58:22 +00:00
:: Int
2019-07-18 15:09:26 +00:00
-> ProductSubmit
2019-07-18 14:58:22 +00:00
-> Update Int64
2019-07-18 15:09:26 +00:00
updateProduct sid ( ProductSubmit ident price ml ava sup max apc ppc artnr ) = Update
{ uTable = productTable
2019-07-18 14:58:22 +00:00
, 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
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
}