Set up some tables and basic queries
This commit is contained in:
Binary file not shown.
@@ -0,0 +1,101 @@
|
||||
{-# LANGUAGE OverloadedRecordDot #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module Jon.Garfield.Queries where
|
||||
|
||||
import Data.Int (Int64)
|
||||
import Data.Scientific (Scientific)
|
||||
import Data.Text (Text)
|
||||
import Database.Beam
|
||||
import Database.Beam.Postgres
|
||||
import Database.PostgreSQL.Simple
|
||||
import Text.Printf (printf)
|
||||
|
||||
import qualified Data.Text as Text
|
||||
|
||||
import Jon.Garfield.Types
|
||||
|
||||
-- Selects
|
||||
|
||||
overviewItems
|
||||
:: Q Postgres GarfieldDb s (OverviewT (QExpr Postgres s), InventoryItemT (QExpr Postgres s))
|
||||
overviewItems = do
|
||||
ov <- all_ garfieldDb.overview
|
||||
it <- related_ garfieldDb.inventoryItems ov.itemId
|
||||
pure (ov, it)
|
||||
|
||||
overviewItemsByLocation
|
||||
:: LocationId
|
||||
-> Q Postgres GarfieldDb s (OverviewT (QExpr Postgres s), InventoryItemT (QExpr Postgres s))
|
||||
overviewItemsByLocation loc = do
|
||||
row@(_, it) <- overviewItems
|
||||
guard_ $ it.location ==. val_ loc
|
||||
pure row
|
||||
|
||||
unsoundBarcodes
|
||||
:: LocationId
|
||||
-> Q Postgres GarfieldDb s (QExpr Postgres s Text, QExpr Postgres s Text, QExpr Postgres s Int64, QExpr Postgres s Int64)
|
||||
unsoundBarcodes loc =
|
||||
filter_ (\(_, _, entries, _) -> entries >=. 2) $
|
||||
aggregate_
|
||||
(\(ov, it) ->
|
||||
( group_ it.barcode
|
||||
, fromMaybe_ "" $ max_ it.name
|
||||
, as_ @Int64 countAll_
|
||||
, as_ @Int64 $ cast_ (sum_ ov.unitsLeft) int
|
||||
))
|
||||
(overviewItemsByLocation loc)
|
||||
|
||||
activeItems
|
||||
:: Text -- barcode
|
||||
-> LocationId
|
||||
-> Q Postgres GarfieldDb s (OverviewT (QExpr Postgres s))
|
||||
activeItems barcode loc = do
|
||||
(ov, it) <- overviewItemsByLocation loc
|
||||
guard_ $ it.barcode ==. val_ barcode
|
||||
guard_ $ it.available ==. val_ True
|
||||
pure ov
|
||||
|
||||
-- Inserts
|
||||
|
||||
transfer
|
||||
:: InventoryItemId -- ^ to
|
||||
-> InventoryItemId -- ^ from
|
||||
-> Int64 -- ^ amount to transfer. If negative, acts like 'transfer b a (-amount)'
|
||||
-> SqlInsert Postgres CorrectionT
|
||||
transfer from to amount
|
||||
| amount < 0 = transfer to from (-amount)
|
||||
| otherwise = insert garfieldDb.inventoryCorrections $
|
||||
insertExpressions
|
||||
[ Correction
|
||||
(val_ from)
|
||||
default_
|
||||
(val_ $ -amount)
|
||||
(val_ $ Text.pack $ printf "Umbuchung auf %d" $ to.unInventoryItemId)
|
||||
, Correction
|
||||
(val_ to)
|
||||
default_
|
||||
(val_ amount)
|
||||
(val_ $ Text.pack $ printf "Umbuchung von %d" $ from.unInventoryItemId)
|
||||
]
|
||||
|
||||
-- Function calls
|
||||
|
||||
type SqlFunction a = Connection -> IO a
|
||||
|
||||
snackDelete :: SnackId -> SqlFunction ()
|
||||
snackDelete snack conn = do
|
||||
[Only ()] <- query conn "SELECT garfield.snack_delete(?)" (Only $ snack.unSnackId)
|
||||
pure ()
|
||||
|
||||
snackCreate :: Text -> Text -> Scientific -> TaxGroupId -> LocationId -> SqlFunction SnackId
|
||||
snackCreate name barcode price taxGroup location conn = do
|
||||
[Only rawSnackId] <- query conn "SELECT garfield.snack_create(?, ?, ?, ?, ?)"
|
||||
(name, barcode, price, taxGroup.unTaxGroupId, location.unLocationId)
|
||||
pure $ mkSnackId rawSnackId
|
||||
|
||||
inventoryMapSnack :: SnackId -> InventoryItemId -> SqlFunction ()
|
||||
inventoryMapSnack snack item conn = do
|
||||
[Only ()] <- query conn "SELECT garfield.inventory_map_snack(?, ?)" (snack.unSnackId, item.unInventoryItemId)
|
||||
pure ()
|
||||
@@ -0,0 +1,384 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE OverloadedRecordDot #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
||||
|
||||
module Jon.Garfield.Types
|
||||
( GarfieldDb(..)
|
||||
, Correction
|
||||
, CorrectionId
|
||||
, CorrectionT(..)
|
||||
, InventoryItem
|
||||
, InventoryItemId
|
||||
, InventoryItemT(..)
|
||||
, InventoryItemGroup
|
||||
, InventoryItemGroupId
|
||||
, InventoryItemGroupT(..)
|
||||
, TaxGroup
|
||||
, TaxGroupId
|
||||
, TaxGroupT(..)
|
||||
, Location
|
||||
, LocationId
|
||||
, LocationT(..)
|
||||
, Overview
|
||||
, OverviewId
|
||||
, OverviewT(..)
|
||||
, Snack
|
||||
, SnackId
|
||||
, SnackT(..)
|
||||
, Sale
|
||||
, SaleId
|
||||
, SaleT(..)
|
||||
, User
|
||||
, UserId
|
||||
, UserT(..)
|
||||
, garfieldDb
|
||||
, mkOverviewId
|
||||
, mkInventoryItemId
|
||||
, mkTaxGroupId
|
||||
, mkLocationId
|
||||
, mkSnackId
|
||||
, mkSaleId
|
||||
, mkUserId
|
||||
, unOverviewId
|
||||
, unInventoryItemId
|
||||
, unInventoryItemGroupId
|
||||
, unTaxGroupId
|
||||
, unLocationId
|
||||
, unSnackId
|
||||
, unSaleId
|
||||
, unUserId
|
||||
) where
|
||||
|
||||
import Data.Functor.Identity (Identity)
|
||||
import Data.Int (Int32, Int64)
|
||||
import Data.Scientific (Scientific)
|
||||
import Data.Text (Text)
|
||||
import Data.Time (UTCTime)
|
||||
import Database.Beam
|
||||
( Beamable
|
||||
, C
|
||||
, Database
|
||||
, DatabaseSettings
|
||||
, Nullable
|
||||
, PrimaryKey
|
||||
, Table(primaryKey)
|
||||
, TableEntity
|
||||
, TableField
|
||||
, FieldModification
|
||||
, dbModification
|
||||
, defaultDbSettings
|
||||
, fieldNamed
|
||||
, modifyTableFields
|
||||
, setEntityName
|
||||
, tableModification
|
||||
, withDbModification
|
||||
)
|
||||
import Database.Beam.Schema.Tables (setEntitySchema)
|
||||
import GHC.Generics (Generic)
|
||||
|
||||
-- Garfield
|
||||
|
||||
data GarfieldDb f = GarfieldDb
|
||||
-- views
|
||||
{ overview :: f (TableEntity OverviewT)
|
||||
-- tables
|
||||
, inventoryItems :: f (TableEntity InventoryItemT)
|
||||
, inventoryItemGroups :: f (TableEntity InventoryItemGroupT)
|
||||
, taxGroups :: f (TableEntity TaxGroupT)
|
||||
, locations :: f (TableEntity LocationT)
|
||||
, inventoryCorrections :: f (TableEntity CorrectionT)
|
||||
, snacks :: f (TableEntity SnackT)
|
||||
, sales :: f (TableEntity SaleT)
|
||||
, users :: f (TableEntity UserT)
|
||||
} deriving (Generic, Database be)
|
||||
|
||||
setGarfieldEntityName name = setEntitySchema (Just "garfield") <> setEntityName name
|
||||
|
||||
type Mod f = f (FieldModification (TableField f))
|
||||
|
||||
garfieldDb :: DatabaseSettings be GarfieldDb
|
||||
garfieldDb = defaultDbSettings `withDbModification`
|
||||
dbModification
|
||||
{ overview = setGarfieldEntityName "inventory_item_overview" <> modifyTableFields tableModification
|
||||
{ itemId = InventoryItemId "item_id"
|
||||
, salesUnits = "sales_units"
|
||||
, unitPrice = "unit_price"
|
||||
, groupName = "group_name"
|
||||
, unitsLeft = "units_left"
|
||||
, correctionDelta = "correction_delta"
|
||||
, activeMappings = "active_mappings"
|
||||
, locationName = "location_name"
|
||||
}
|
||||
, inventoryItems = setGarfieldEntityName "inventory_items" <> modifyTableFields tableModification
|
||||
{ id = "item_id"
|
||||
, group = InventoryItemGroupId "item_group"
|
||||
, bestBefore = "best_before"
|
||||
, barcode = "item_barcode"
|
||||
, unitPrice = "unit_price"
|
||||
, salesUnits = "sales_units"
|
||||
, taxGroup = TaxGroupId "tax_group"
|
||||
, location = LocationId "location"
|
||||
}
|
||||
, inventoryItemGroups = setGarfieldEntityName "inventory_item_groups" <> modifyTableFields (tableModification :: Mod InventoryItemGroupT)
|
||||
{ id = "group_id"
|
||||
, name = "group_name"
|
||||
}
|
||||
, taxGroups = setGarfieldEntityName "tax_groups" <> modifyTableFields (tableModification :: Mod TaxGroupT)
|
||||
{ id = "tax_group_id"
|
||||
}
|
||||
, locations = setGarfieldEntityName "locations" <> modifyTableFields tableModification
|
||||
{ id = "location_id"
|
||||
, name = "location_name"
|
||||
, description = "location_description"
|
||||
}
|
||||
, inventoryCorrections = setGarfieldEntityName "inventory_correction" <> modifyTableFields tableModification
|
||||
{ itemId = InventoryItemId "item_id"
|
||||
, time = "correction_time"
|
||||
, comment = "correction_comment"
|
||||
}
|
||||
, snacks = setGarfieldEntityName "snacks" <> modifyTableFields tableModification
|
||||
{ id = "snack_id"
|
||||
, name = "snack_name"
|
||||
, barcode = "snack_barcode"
|
||||
, price = "snack_price"
|
||||
, location = LocationId "location_id"
|
||||
, timestamp = "snack_timestamp"
|
||||
, taxGroup = TaxGroupId "tax_group_id"
|
||||
}
|
||||
, sales = setGarfieldEntityName "snack_sales_log" <> modifyTableFields tableModification
|
||||
{ id = "snack_sales_log_id"
|
||||
, timestamp = "snack_sales_log_timestamp"
|
||||
, snack = SnackId "snack_id"
|
||||
, location = LocationId "location_id"
|
||||
, type' = "type_id"
|
||||
, grossPrice = "gross_price"
|
||||
, inventoryItem = InventoryItemId "inventory_line"
|
||||
}
|
||||
, users = setGarfieldEntityName "users" <> modifyTableFields tableModification
|
||||
{ id = "user_id"
|
||||
, name = "user_name"
|
||||
, fullName = "user_full_name"
|
||||
, alwaysSendBalanceMail = "always_send_balance_mail"
|
||||
, sendHistoryMail = "send_history_mail"
|
||||
}
|
||||
}
|
||||
|
||||
-- Views
|
||||
|
||||
data OverviewT f = Overview
|
||||
{ itemId :: PrimaryKey InventoryItemT f
|
||||
, name :: C f Text
|
||||
, salesUnits :: C f Int64
|
||||
, unitPrice :: C f Scientific
|
||||
, sales :: C f Scientific
|
||||
, groupName :: C f Text
|
||||
, unitsLeft :: C f Scientific
|
||||
, correctionDelta :: C f Scientific
|
||||
, activeMappings :: C f Scientific
|
||||
, locationName :: C f Text
|
||||
} deriving (Beamable, Generic)
|
||||
|
||||
type Overview = OverviewT Identity
|
||||
type OverviewId = PrimaryKey OverviewT Identity
|
||||
|
||||
mkOverviewId :: Int32 -> OverviewId
|
||||
mkOverviewId = OverviewId
|
||||
|
||||
deriving instance Show Overview
|
||||
deriving instance Show OverviewId
|
||||
|
||||
instance Table OverviewT where
|
||||
data PrimaryKey OverviewT f
|
||||
= OverviewId { unOverviewId :: C f Int32 } deriving (Beamable, Generic)
|
||||
primaryKey = OverviewId . unInventoryItemId . (.itemId)
|
||||
|
||||
-- Tables
|
||||
|
||||
data InventoryItemT f = InventoryItem
|
||||
{ id :: C f Int32
|
||||
, available :: C f Bool
|
||||
, name :: C f Text
|
||||
, group :: PrimaryKey InventoryItemGroupT f
|
||||
, bought :: C f UTCTime
|
||||
, bestBefore :: C f UTCTime
|
||||
, barcode :: C f Text
|
||||
, unitPrice :: C f Scientific
|
||||
, salesUnits :: C f Int64
|
||||
, taxGroup :: PrimaryKey TaxGroupT f
|
||||
, location :: PrimaryKey LocationT f
|
||||
} deriving (Beamable, Generic)
|
||||
|
||||
type InventoryItem = InventoryItemT Identity
|
||||
type InventoryItemId = PrimaryKey InventoryItemT Identity
|
||||
|
||||
mkInventoryItemId :: Int32 -> InventoryItemId
|
||||
mkInventoryItemId = InventoryItemId
|
||||
|
||||
deriving instance Show InventoryItem
|
||||
deriving instance Show InventoryItemId
|
||||
deriving instance Show (PrimaryKey InventoryItemT (Nullable Identity))
|
||||
|
||||
instance Table InventoryItemT where
|
||||
data PrimaryKey InventoryItemT f
|
||||
= InventoryItemId { unInventoryItemId :: C f Int32 } deriving (Beamable, Generic)
|
||||
primaryKey = InventoryItemId . (.id)
|
||||
|
||||
|
||||
data InventoryItemGroupT f = InventoryItemGroup
|
||||
{ id :: C f Int32
|
||||
, name :: C f Text
|
||||
} deriving (Beamable, Generic)
|
||||
|
||||
type InventoryItemGroup = InventoryItemGroupT Identity
|
||||
type InventoryItemGroupId = PrimaryKey InventoryItemGroupT Identity
|
||||
|
||||
deriving instance Show InventoryItemGroup
|
||||
deriving instance Show InventoryItemGroupId
|
||||
|
||||
instance Table InventoryItemGroupT where
|
||||
data PrimaryKey InventoryItemGroupT f
|
||||
= InventoryItemGroupId { unInventoryItemGroupId :: C f Int32 } deriving (Beamable, Generic)
|
||||
primaryKey = InventoryItemGroupId . (.id)
|
||||
|
||||
|
||||
data TaxGroupT f = TaxGroup
|
||||
{ id :: C f Int32
|
||||
, description :: C f Text
|
||||
, active :: C f Bool
|
||||
} deriving (Beamable, Generic)
|
||||
|
||||
type TaxGroup = TaxGroupT Identity
|
||||
type TaxGroupId = PrimaryKey TaxGroupT Identity
|
||||
|
||||
mkTaxGroupId = TaxGroupId
|
||||
|
||||
deriving instance Show TaxGroup
|
||||
deriving instance Show TaxGroupId
|
||||
|
||||
instance Table TaxGroupT where
|
||||
data PrimaryKey TaxGroupT f
|
||||
= TaxGroupId { unTaxGroupId :: C f Int32 } deriving (Beamable, Generic)
|
||||
primaryKey = TaxGroupId . (.id)
|
||||
|
||||
|
||||
data LocationT f = Location
|
||||
{ id :: C f Int32
|
||||
, name :: C f Text
|
||||
, description :: C f Text
|
||||
} deriving (Beamable, Generic)
|
||||
|
||||
type Location = LocationT Identity
|
||||
type LocationId = PrimaryKey LocationT Identity
|
||||
|
||||
mkLocationId :: Int32 -> LocationId
|
||||
mkLocationId = LocationId
|
||||
|
||||
deriving instance Show Location
|
||||
deriving instance Show LocationId
|
||||
|
||||
instance Table LocationT where
|
||||
data PrimaryKey LocationT f
|
||||
= LocationId { unLocationId :: C f Int32 } deriving (Beamable, Generic)
|
||||
primaryKey = LocationId . (.id)
|
||||
|
||||
|
||||
data CorrectionT f = Correction
|
||||
{ itemId :: PrimaryKey InventoryItemT f
|
||||
, time :: C f UTCTime
|
||||
, delta :: C f Int64
|
||||
, comment :: C f Text
|
||||
} deriving (Beamable, Generic)
|
||||
|
||||
type Correction = CorrectionT Identity
|
||||
type CorrectionId = PrimaryKey CorrectionT Identity
|
||||
|
||||
deriving instance Show Correction
|
||||
deriving instance Show CorrectionId
|
||||
|
||||
instance Table CorrectionT where
|
||||
data PrimaryKey CorrectionT f
|
||||
= CorrectionId deriving (Beamable, Generic)
|
||||
primaryKey _ = CorrectionId
|
||||
|
||||
|
||||
data SnackT f = Snack
|
||||
{ id :: C f Int32
|
||||
, name :: C f Text
|
||||
, barcode :: C f Text
|
||||
, price :: C f Scientific
|
||||
, location :: PrimaryKey LocationT f
|
||||
-- , snackModifiedBy :: PrimaryKey UserT f
|
||||
, timestamp :: C f UTCTime
|
||||
, taxGroup :: PrimaryKey TaxGroupT f
|
||||
} deriving (Beamable, Generic)
|
||||
|
||||
type Snack = SnackT Identity
|
||||
type SnackId = PrimaryKey SnackT Identity
|
||||
|
||||
mkSnackId :: Int32 -> SnackId
|
||||
mkSnackId = SnackId
|
||||
|
||||
deriving instance Show Snack
|
||||
deriving instance Show SnackId
|
||||
|
||||
instance Table SnackT where
|
||||
data PrimaryKey SnackT f
|
||||
= SnackId { unSnackId :: C f Int32 } deriving (Beamable, Generic)
|
||||
primaryKey = SnackId . (.id)
|
||||
|
||||
|
||||
data SaleT f = Sale
|
||||
{ id :: C f Int32
|
||||
, timestamp :: C f UTCTime
|
||||
, snack :: PrimaryKey SnackT f
|
||||
, location :: PrimaryKey LocationT f
|
||||
, type' :: C f Text
|
||||
-- , saleSubtotal :: PrimaryKey SubtotalT f
|
||||
, grossPrice :: C f Scientific
|
||||
-- , saleTax :: PrimaryKey TaxT f
|
||||
, inventoryItem :: PrimaryKey InventoryItemT (Nullable f)
|
||||
} deriving (Beamable, Generic)
|
||||
|
||||
type Sale = SaleT Identity
|
||||
type SaleId = PrimaryKey SaleT Identity
|
||||
|
||||
mkSaleId :: Int32 -> SaleId
|
||||
mkSaleId = SaleId
|
||||
|
||||
deriving instance Show Sale
|
||||
deriving instance Show SaleId
|
||||
|
||||
instance Table SaleT where
|
||||
data PrimaryKey SaleT f
|
||||
= SaleId { unSaleId :: C f Int32 } deriving (Beamable, Generic)
|
||||
primaryKey = SaleId . (.id)
|
||||
|
||||
|
||||
data UserT f = User
|
||||
{ id :: C f Int32
|
||||
, name :: C f Text
|
||||
, fullName :: C f Text
|
||||
, alwaysSendBalanceMail :: C f Bool
|
||||
, sendHistoryMail :: C f Bool
|
||||
} deriving (Beamable, Generic)
|
||||
|
||||
type User = UserT Identity
|
||||
type UserId = PrimaryKey UserT Identity
|
||||
|
||||
mkUserId :: Int32 -> UserId
|
||||
mkUserId = UserId
|
||||
|
||||
deriving instance Show User
|
||||
deriving instance Show UserId
|
||||
|
||||
instance Table UserT where
|
||||
data PrimaryKey UserT f
|
||||
= UserId { unUserId :: C f Int32 } deriving (Beamable, Generic)
|
||||
primaryKey = UserId . (.id)
|
||||
+41
-2
@@ -1,3 +1,42 @@
|
||||
module Jon.Main (main) where
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
main = putStrLn "Jon.Main"
|
||||
module Jon.Main
|
||||
( main
|
||||
, runFunction
|
||||
, runQuery
|
||||
, runIns
|
||||
) where
|
||||
|
||||
import Database.Beam
|
||||
import Database.Beam.Postgres
|
||||
import System.Environment
|
||||
|
||||
import qualified Data.ByteString.Char8 as BS8
|
||||
|
||||
main :: IO ()
|
||||
main = pure ()
|
||||
|
||||
runQuery
|
||||
:: (FromBackendRow Postgres (QExprToIdentity e), Projectible Postgres e)
|
||||
=> Q Postgres db QBaseScope e
|
||||
-> IO [QExprToIdentity e]
|
||||
runQuery q = do
|
||||
pass <- getEnv "JON_PASS"
|
||||
conn <- connectPostgreSQL $ BS8.pack $ "host=localhost dbname=garfield password=" ++ pass
|
||||
runBeamPostgresDebug putStrLn conn $ runSelectReturningList $ select q
|
||||
|
||||
runIns
|
||||
:: SqlInsert Postgres table
|
||||
-> IO ()
|
||||
runIns i = do
|
||||
pass <- getEnv "JON_PASS"
|
||||
conn <- connectPostgreSQL $ BS8.pack $ "host=localhost dbname=garfield password=" ++ pass
|
||||
runBeamPostgresDebug putStrLn conn $ runInsert i
|
||||
|
||||
runFunction
|
||||
:: (Connection -> IO a)
|
||||
-> IO a
|
||||
runFunction f = do
|
||||
pass <- getEnv "JON_PASS"
|
||||
conn <- connectPostgreSQL $ BS8.pack $ "host=localhost dbname=garfield password=" ++ pass
|
||||
f conn
|
||||
|
||||
Reference in New Issue
Block a user