{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Arrows #-} {-# LANGUAGE ScopedTypeVariables #-} module Model.Product where import Data.Text (Text) import qualified Data.Text as T hiding (head, foldl, map) import Data.Time (getCurrentTime) import Data.Profunctor.Product (p10) import Data.Maybe import Control.Monad.IO.Class (liftIO) import Control.Arrow import qualified Database.PostgreSQL.Simple as PGS import qualified Data.Profunctor as P import Opaleye as O -- internal imports import Types import Classes import Model.Amount initProduct :: PGS.Query initProduct = mconcat [ "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_min_amount INTEGER NOT NULL," , "product_amount_per_crate INTEGER NOT NULL," , "product_price_per_crate INTEGER," , "product_art_nr TEXT" , ")" ] productTable :: Table ( Maybe (Field SqlInt4) , Field SqlText , Field SqlInt4 , FieldNullable SqlInt4 , FieldNullable SqlInt4 , Field SqlInt4 , Field SqlInt4 , Field SqlInt4 , FieldNullable SqlInt4 , FieldNullable SqlText ) ( Field SqlInt4 , Field SqlText , Field SqlInt4 , FieldNullable SqlInt4 , FieldNullable SqlInt4 , Field SqlInt4 , Field SqlInt4 , Field SqlInt4 , FieldNullable SqlInt4 , FieldNullable SqlText ) productTable = table "product" ( p10 ( tableField "product_id" , tableField "product_ident" , tableField "product_ml" , tableField "product_avatar" , tableField "product_supplier" , tableField "product_max_amount" , tableField "product_min_amount" , tableField "product_amount_per_crate" , tableField "product_price_per_crate" , tableField "product_art_nr" ) ) productSelect :: PGS.Connection -> MateHandler [Product] productSelect conn = do liftIO $ map fromDatabase <$> runSelect conn (selectTable productTable) productSelectSingle :: Int -> PGS.Connection -> MateHandler (Maybe Product) productSelectSingle pid conn = do prods <- liftIO $ map fromDatabase <$> runSelect conn ( proc () -> do stuff@(id_, _, _, _, _, _, _, _, _, _) <- limit 1 (selectTable productTable) -< () restrict -< id_ .== toFields pid returnA -< stuff) case prods of p:_ -> return (Just p) _ -> return Nothing productOverviewSelect :: ProductRefine -> PGS.Connection -> MateHandler [ProductOverview] productOverviewSelect refine conn = do prods <- liftIO $ runSelect conn (produceProductOverviews refine) mapM (generateProductOverview conn) prods produceProductOverviews :: ProductRefine -> Select ( Column SqlInt4 , Column SqlText , Column SqlInt4 , Column (Nullable SqlInt4) , Column (Nullable SqlInt4) , Column SqlInt4 , Column SqlInt4 , Column SqlInt4 , Column (Nullable SqlInt4) , Column (Nullable SqlText) , Column SqlInt4 , Column SqlInt4 ) produceProductOverviews refine = proc () -> do (p, i2, i6, i6a, i7, i8, i9, i11, i12, i13) <- selectTable productTable -< () (_, _, a3, a4, _) <- do (a1, a2, a3, a4, a5) <- selectTable amountTable -< () (b1, b2) <- do (ib1, ib2, _, _, _) <- selectTable amountTable -< () (laterally . aggregate) ( (,) <$> P.lmap fst O.groupBy <*> P.lmap snd O.max ) (arr (\(ib1, ib2, _, _, _) -> (ib1, ib2)) <<< selectTable amountTable ) -< () returnA -< (ib1, ib2) restrict -< a1 .== b1 .&& a2 .== b2 returnA -< (b1, b2, a3, a4, a5) restrict -< case refine of AllProducts -> toFields True AvailableProducts -> a3 ./= (toFields (0 :: Int) :: Column SqlInt4) DepletedProducts -> a3 .== (toFields (0 :: Int) :: Column SqlInt4) returnA -< (p, i2, i6, i6a, i7, i8, i9, i11, i12, i13, a3, a4) queryAmounts :: PGS.Connection -> Int -> IO [Amount] queryAmounts conn pid = map fromDatabase <$> runSelect conn (proc () -> do stuff@(a1, _, _, _, _) <- orderBy (desc (\(_, ts, _, _, _) -> ts)) (selectTable amountTable) -< () restrict -< toFields pid .== a1 returnA -< stuff ) generateProductOverview :: PGS.Connection -> ( Int , Text , Int , Maybe Int , Maybe Int , Int , Int , Int , Maybe Int , Maybe Text , Int , Int ) -> MateHandler ProductOverview generateProductOverview conn (i1, i2, i3, i4, i5, i6, i6a, i7, i8, i9, a3, a4) = do amounts <- liftIO $ queryAmounts conn i1 let ii5 = snd $ foldl (\(bef, van) (Amount _ _ amo _ ver) -> if ver then (amo, if amo < bef then van + (bef - amo) else van) else (amo, van) ) (0, 0) (reverse amounts) ii10 = snd $ foldl (\(bef, tot) (Amount _ _ amo _ ver) -> if ver then (amo, tot) else (amo, tot + Prelude.max 0 (bef - amo)) ) (0, 0) (Prelude.reverse amounts) return $ ProductOverview i1 i2 a4 a3 ii5 i3 i4 i5 i6 i6a ii10 i7 i8 i9 productOverviewSelectSingle :: Int -> PGS.Connection -> MateHandler ProductOverview productOverviewSelectSingle pid conn = do prods <- liftIO $ runSelect conn (produceProductOverviews AllProducts) head <$> mapM (generateProductOverview conn) (Prelude.filter (\(p, _, _, _, _, _, _, _, _, _, _, _) -> p == pid) prods) productShortOverviewSelect :: ProductRefine -> PGS.Connection -> MateHandler [ProductShortOverview] productShortOverviewSelect refine conn = do prods <- liftIO $ runSelect conn (produceProductOverviews refine) :: MateHandler [( Int , Text , Int , Maybe Int , Maybe Int , Int , Int , Int , Maybe Int , Maybe Text , Int , Int )] mapM (\(i1, i2, i3, i4, _, _, _, _, _, _, a3, a4) -> return $ ProductShortOverview i1 i2 a4 a3 i3 i4 ) prods insertProduct :: ProductSubmit -> PGS.Connection -> MateHandler Int insertProduct (ProductSubmit ident _ ml ava sup maxi mini apc ppc artnr) conn = fmap head $ liftIO $ runInsert_ conn $ Insert { iTable = productTable , iRows = [ ( toFields (Nothing :: Maybe Int) , toFields ident , toFields ml , toFields ava , toFields sup , toFields maxi , toFields mini , toFields apc , toFields ppc , toFields artnr ) ] , iReturning = rReturning (\(id_, _, _, _, _, _, _, _, _, _) -> id_) , iOnConflict = Nothing } manualProductAmountRefill :: [AmountRefill] -> PGS.Connection -> MateHandler [Int] manualProductAmountRefill aups conn = mapM (\(AmountRefill pid amountSingles amountCrates) -> do oldamount <- getLatestAmountByProductId pid conn oldprice <- getLatestPriceByProductId pid conn perCrate <- productAmountPerCrate . fromJust <$> productSelectSingle pid conn head <$> liftIO (do now <- getCurrentTime runInsert_ conn $ Insert { iTable = amountTable , iRows = [ ( toFields pid , toFields now , toFields (oldamount + (amountSingles + (perCrate * amountCrates))) , toFields oldprice , toFields False ) ] , iReturning = rReturning (\(id_, _, _, _, _) -> id_) , iOnConflict = Nothing } ) ) aups