From b673f4dcf54edc01901fbbbc79128238fbbece73 Mon Sep 17 00:00:00 2001 From: Paul Brinkmeier Date: Fri, 2 Dec 2022 15:20:05 +0100 Subject: [PATCH] Set up some tables and basic queries --- .gitignore | 1 + README.md | 7 + jon.cabal | 23 +++ nix/haskell-deps.nix | 7 + nix/sources.json | 6 +- package.yaml | 7 + src/Jon/.Main.hs.swp | Bin 12288 -> 0 bytes src/Jon/Garfield/Queries.hs | 101 ++++++++++ src/Jon/Garfield/Types.hs | 384 ++++++++++++++++++++++++++++++++++++ src/Jon/Main.hs | 43 +++- 10 files changed, 574 insertions(+), 5 deletions(-) delete mode 100644 src/Jon/.Main.hs.swp create mode 100644 src/Jon/Garfield/Queries.hs create mode 100644 src/Jon/Garfield/Types.hs diff --git a/.gitignore b/.gitignore index 60da784..bf51462 100644 --- a/.gitignore +++ b/.gitignore @@ -1,2 +1,3 @@ .stack-work/ .vscode/ +.setjonpass diff --git a/README.md b/README.md index 22c8d2a..21d55ce 100644 --- a/README.md +++ b/README.md @@ -1 +1,8 @@ # jon + +> the tamer of garfield +## fsmi-db forward + +``` +ssh -nNTvL 5432:fsmi-db.fsmi.uni-karlsruhe.de:5432 fsmi-login +``` diff --git a/jon.cabal b/jon.cabal index e16f65a..81a96b9 100644 --- a/jon.cabal +++ b/jon.cabal @@ -21,6 +21,8 @@ source-repository head library exposed-modules: + Jon.Garfield.Queries + Jon.Garfield.Types Jon.Main other-modules: Paths_jon @@ -29,7 +31,14 @@ library ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints build-depends: base >=4.7 && <5 + , beam-core + , beam-postgres + , bytestring , postgresql-simple + , scientific + , servant-server + , text + , time default-language: Haskell2010 executable jon-exe @@ -39,8 +48,15 @@ executable jon-exe ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.7 && <5 + , beam-core + , beam-postgres + , bytestring , jon , postgresql-simple + , scientific + , servant-server + , text + , time default-language: Haskell2010 test-suite jon-test @@ -53,6 +69,13 @@ test-suite jon-test ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.7 && <5 + , beam-core + , beam-postgres + , bytestring , jon , postgresql-simple + , scientific + , servant-server + , text + , time default-language: Haskell2010 diff --git a/nix/haskell-deps.nix b/nix/haskell-deps.nix index 2aa1dfc..c9691c8 100644 --- a/nix/haskell-deps.nix +++ b/nix/haskell-deps.nix @@ -1,3 +1,10 @@ haskellPackages: with haskellPackages; [ + beam-core + beam-postgres + bytestring postgresql-simple + servant-server + scientific + text + time ] diff --git a/nix/sources.json b/nix/sources.json index 66339e2..14b5a04 100644 --- a/nix/sources.json +++ b/nix/sources.json @@ -17,10 +17,10 @@ "homepage": "", "owner": "NixOS", "repo": "nixpkgs", - "rev": "8e8b5f3b1e899bf5d250279578c0283705b8cdb4", - "sha256": "1vf7g02syz8fbqvcx3wzfq53xvyw9z6xpyzfh5ijxryx2g2msdq2", + "rev": "227de2b3bbec142f912c09d5e8a1b4e778aa54fb", + "sha256": "04is77q4msyqi51q8zxialyl378hzv47ldml5hnycg42zvnzpi24", "type": "tarball", - "url": "https://github.com/NixOS/nixpkgs/archive/8e8b5f3b1e899bf5d250279578c0283705b8cdb4.tar.gz", + "url": "https://github.com/NixOS/nixpkgs/archive/227de2b3bbec142f912c09d5e8a1b4e778aa54fb.tar.gz", "url_template": "https://github.com///archive/.tar.gz" } } diff --git a/package.yaml b/package.yaml index 9851a05..a1cc073 100644 --- a/package.yaml +++ b/package.yaml @@ -13,7 +13,14 @@ extra-source-files: dependencies: - base >= 4.7 && < 5 +- beam-core +- beam-postgres +- bytestring - postgresql-simple +- servant-server +- scientific +- text +- time ghc-options: - -Wall diff --git a/src/Jon/.Main.hs.swp b/src/Jon/.Main.hs.swp deleted file mode 100644 index c5e581b29f7cc3d10349ea2e5c72ea80987ead5c..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 12288 zcmeI&L2AN46oBEUh3-Vr3ykTeU6`l^apM6j%}VS(jS(%Hgd{_EcGn)Gr|1>hD|Fo+ zz$G~$I3Bd^{ySOcSN?yLT@5?SnKS diff --git a/src/Jon/Garfield/Queries.hs b/src/Jon/Garfield/Queries.hs new file mode 100644 index 0000000..f375d79 --- /dev/null +++ b/src/Jon/Garfield/Queries.hs @@ -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 () diff --git a/src/Jon/Garfield/Types.hs b/src/Jon/Garfield/Types.hs new file mode 100644 index 0000000..f1f64a4 --- /dev/null +++ b/src/Jon/Garfield/Types.hs @@ -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) diff --git a/src/Jon/Main.hs b/src/Jon/Main.hs index d9de134..faf29ea 100644 --- a/src/Jon/Main.hs +++ b/src/Jon/Main.hs @@ -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