paul/jon
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Add a few things

Browse Source
This commit is contained in:
paul
2022-12-08 18:06:15 +01:00
parent 5bd3832d27
commit 9ce0f974fb
5 changed files with 406 additions and 133 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Jon/Garfield/Queries.hs
+19
View File
@@ -68,6 +68,17 @@ locations
:: Q Postgres GarfieldDb s (LocationT (QExpr Postgres s))
locations = all_ garfieldDb.locations
getSnacksByItemId
:: InventoryItemId
-> Q Postgres GarfieldDb s (SnackT (QExpr Postgres s))
getSnacksByItemId item = do
im <- all_ garfieldDb.inventoryMap
sn <- related_ garfieldDb.snacks im.snackId
sa <- oneToOne_ garfieldDb.snacksAvailable (.snackId) sn
guard_ $ im.inventoryId ==. val_ item
guard_ $ sa.available
pure sn
-- Inserts
runInserts
@@ -76,6 +87,14 @@ runInserts
-> IO ()
runInserts conn is = runBeamPostgresDebug putStrLn conn $ mapM_ runInsert is
adjustInventory
:: InventoryItemId
-> Int64
-> Text
-> SqlInsert Postgres CorrectionT
adjustInventory item amount desc = insert garfieldDb.inventoryCorrections $
insertExpressions [Correction (val_ item) default_ (val_ amount) (val_ desc)]
transfer
:: InventoryItemId -- ^ to
-> InventoryItemId -- ^ from
src/Jon/Garfield/Types.hs
+59 -4
View File
@@ -20,6 +20,9 @@ module Jon.Garfield.Types
, InventoryItemGroup
, InventoryItemGroupId
, InventoryItemGroupT(..)
, InventoryMap
, InventoryMapId
, InventoryMapT(..)
, TaxGroup
, TaxGroupId
, TaxGroupT(..)
@@ -32,6 +35,9 @@ module Jon.Garfield.Types
, Snack
, SnackId
, SnackT(..)
, SnackAvailable
, SnackAvailableId
, SnackAvailableT(..)
, Sale
, SaleId
, SaleT(..)
@@ -43,16 +49,18 @@ module Jon.Garfield.Types
, mkInventoryItemId
, mkTaxGroupId
, mkLocationId
, mkSnackId
, mkSaleId
, mkSnackId
, mkSnackAvailableId
, mkUserId
, unOverviewId
, unInventoryItemId
, unInventoryItemGroupId
, unTaxGroupId
, unLocationId
, unSnackId
, unSaleId
, unSnackId
, unSnackAvailableId
, unUserId
) where
@@ -97,6 +105,8 @@ data GarfieldDb f = GarfieldDb
, snacks :: f (TableEntity SnackT)
, sales :: f (TableEntity SaleT)
, users :: f (TableEntity UserT)
, inventoryMap :: f (TableEntity InventoryMapT)
, snacksAvailable :: f (TableEntity SnackAvailableT)
} deriving (Generic, Database be)
setGarfieldEntityName name = setEntitySchema (Just "garfield") <> setEntityName name
@@ -168,6 +178,14 @@ garfieldDb = defaultDbSettings `withDbModification`
, alwaysSendBalanceMail = "always_send_balance_mail"
, sendHistoryMail = "send_history_mail"
}
, inventoryMap = setGarfieldEntityName "inventory_map" <> modifyTableFields tableModification
{ inventoryId = InventoryItemId "inventory_id"
, snackId = SnackId "snack_id"
}
, snacksAvailable = setGarfieldEntityName "snacks_available" <> modifyTableFields tableModification
{ snackId = SnackId "snack_id"
, available = "snack_available"
}
}
-- Views
@@ -311,11 +329,11 @@ instance Table CorrectionT where
data SnackT f = Snack
{ id :: C f Int32
, name :: C f Text
, barcode :: C f Text
, barcode :: C (Nullable f) Text
, price :: C f Scientific
, location :: PrimaryKey LocationT f
-- , snackModifiedBy :: PrimaryKey UserT f
, timestamp :: C f UTCTime
, timestamp :: C (Nullable f) UTCTime
, taxGroup :: PrimaryKey TaxGroupT f
} deriving (Beamable, Generic)
@@ -382,3 +400,40 @@ instance Table UserT where
data PrimaryKey UserT f
= UserId { unUserId :: C f Int32 } deriving (Beamable, Generic)
primaryKey = UserId . (.id)
data InventoryMapT f = InventoryMap
{ inventoryId :: PrimaryKey InventoryItemT f
, snackId :: PrimaryKey SnackT f
} deriving (Beamable, Generic)
type InventoryMap = InventoryMapT Identity
type InventoryMapId = PrimaryKey InventoryMapT Identity
deriving instance Show InventoryMap
deriving instance Show InventoryMapId
instance Table InventoryMapT where
data PrimaryKey InventoryMapT f
= InventoryMapId deriving (Beamable, Generic)
primaryKey _ = InventoryMapId
data SnackAvailableT f = SnackAvailable
{ snackId :: PrimaryKey SnackT f
, available :: C f Bool
} deriving (Beamable, Generic)
type SnackAvailable = SnackAvailableT Identity
type SnackAvailableId = PrimaryKey SnackAvailableT Identity
mkSnackAvailableId :: SnackId -> SnackAvailableId
mkSnackAvailableId = SnackAvailableId
deriving instance Show SnackAvailable
deriving instance Show SnackAvailableId
instance Table SnackAvailableT where
data PrimaryKey SnackAvailableT f
= SnackAvailableId { unSnackAvailableId :: PrimaryKey SnackT f } deriving (Beamable, Generic)
primaryKey = SnackAvailableId . (.snackId)
src/Jon/Server.hs
+30 -2
View File
@@ -45,6 +45,8 @@ type JonAPI =
:> Post '[JSON] [OverviewItemDTO]
:<|> "getLocations" :> Summary "Get a list of all locations"
:> Post '[JSON] [Location]
:<|> "adjustInventory" :> ReqBody '[JSON] AdjustInventoryP
:> PostNoContent
:<|> "transferInventory" :> Summary "Transfer inventory between items"
:> Description "If `amount` is negative, its absolute value is transferred in the opposite direction."
:> ReqBody '[JSON] TransferInventoryP
@@ -59,6 +61,9 @@ type SnackAPI =
"createSnack" :> Summary "Create a snack"
:> ReqBody '[JSON] CreateSnackP
:> Post '[JSON] SnackId
:<|> "getSnacksByItemId" :> Summary "Get active snacks by item id"
:> ReqBody '[JSON] GetSnacksByItemIdP
:> Post '[JSON] [Snack]
:<|> "updateSnack" :> Summary "Update a snack"
:> ReqBody '[JSON] UpdateSnackP
:> Post '[JSON] SnackId
@@ -90,6 +95,12 @@ data GetActiveItemsP = GetActiveItemsP
, location :: LocationId
} deriving (Generic, FromJSON, ToSchema)
data AdjustInventoryP = AdjustInventoryP
{ item :: InventoryItemId
, amount :: Int64
, description :: Text
} deriving (Generic, FromJSON, ToSchema)
data TransferInventoryP = TransferInventoryP
{ transfers :: [InventoryTransferDTO]
} deriving (Generic, FromJSON, ToSchema)
@@ -112,6 +123,10 @@ data CreateSnackP = CreateSnackP
, location :: LocationId
} deriving (Generic, FromJSON, ToSchema)
data GetSnacksByItemIdP = GetSnacksByItemIdP
{ item :: InventoryItemId
} deriving (Generic, FromJSON, ToSchema)
data UpdateSnackP = UpdateSnackP
{ snack :: SnackId
, name :: Text
@@ -165,6 +180,9 @@ deriving instance ToSchema InventoryItem
deriving instance ToJSON Location
deriving instance ToSchema Location
deriving instance ToJSON Snack
deriving instance ToSchema Snack
-- server
server :: Connection -> Server JonAPI
@@ -173,9 +191,11 @@ server conn =
:<|> getOverviewItems
:<|> getActiveItems
:<|> getLocations
:<|> adjustInventory
:<|> transferInventory
:<|> disableItems
:<|> createSnack
:<|> getSnacksByItemId
:<|> updateSnack
where
getUnsoundBarcodes :: GetUnsoundBarcodesP -> Handler [UnsoundBarcodeDTO]
@@ -199,6 +219,10 @@ server conn =
getLocations = do
liftIO $ Queries.runSelect conn Queries.locations
adjustInventory params = do
liftIO $ Queries.runInserts conn [Queries.adjustInventory params.item params.amount params.description]
pure NoContent
transferInventory :: TransferInventoryP -> Handler NoContent
transferInventory params = do
liftIO $ Queries.runInserts conn $ map (\t -> Queries.transfer t.from t.to t.amount) params.transfers
@@ -217,6 +241,9 @@ server conn =
params.taxGroup
params.location
getSnacksByItemId params = do
liftIO $ Queries.runSelect conn $ Queries.getSnacksByItemId params.item
updateSnack params = do
liftIO $ Queries.runFunction conn $ Queries.snackUpdate
params.snack
@@ -229,5 +256,6 @@ jonSwaggerDoc :: Swagger
jonSwaggerDoc = toSwagger (Proxy :: Proxy JonAPI)
& info . title .~ "jon API"
& info . version .~ "0.1.1"
-- & applyTags [Tag "jon RPC" (Just "Crudely improvised Garfield API") Nothing]
& applyTagsFor (operationsOf $ toSwagger (Proxy :: Proxy SnackAPI)) [Tag "Snacks" Nothing Nothing]
& applyTags [Tag "jon RPC" (Just "Crudely improvised Garfield API") Nothing]
-- Doesn't work :(
-- & applyTagsFor (operationsOf $ toSwagger (Proxy :: Proxy SnackAPI)) [Tag "Snacks" Nothing Nothing]