Set up some tables and basic queries

.gitignore

@@ -1,2 +1,3 @@
 .stack-work/
 .vscode/
+.setjonpass

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
+```

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

nix/haskell-deps.nix

@@ -1,3 +1,10 @@
 haskellPackages: with haskellPackages; [
+  beam-core
+  beam-postgres
+  bytestring
   postgresql-simple
+  servant-server
+  scientific
+  text
+  time
 ]

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/<owner>/<repo>/archive/<rev>.tar.gz"
     }
 }

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

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 ()

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)

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