diff --git a/src/Jon/Garfield/Queries.hs b/src/Jon/Garfield/Queries.hs index 16c523a..45167a6 100644 --- a/src/Jon/Garfield/Queries.hs +++ b/src/Jon/Garfield/Queries.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} @@ -69,6 +70,12 @@ locations = all_ garfieldDb.locations -- Inserts +runIns + :: Connection + -> SqlInsert Postgres table + -> IO () +runIns conn i = runBeamPostgresDebug putStrLn conn $ runInsert i + transfer :: InventoryItemId -- ^ to -> InventoryItemId -- ^ from @@ -94,6 +101,9 @@ transfer from to amount type SqlFunction a = Connection -> IO a +runFunction :: Connection -> SqlFunction a -> IO a +runFunction conn f = f conn + snackDelete :: SnackId -> SqlFunction () snackDelete snack conn = do [Only ()] <- query conn "SELECT garfield.snack_delete(?)" (Only $ snack.unSnackId) @@ -105,6 +115,18 @@ snackCreate name barcode price taxGroup location conn = do (name, barcode, price, taxGroup.unTaxGroupId, location.unLocationId) pure $ mkSnackId rawSnackId +snackUpdate + :: SnackId + -> Text -- Name + -> Text -- Barcode + -> Scientific + -> TaxGroupId + -> SqlFunction SnackId +snackUpdate snack name barcode price taxGroup conn = do + [Only rawSnackId] <- query conn "SELECT garfield.snack_update(?, ?, ?, ?, ?)" + (snack.unSnackId, name, barcode, price, taxGroup.unTaxGroupId) + pure $ mkSnackId rawSnackId + inventoryMapSnack :: SnackId -> InventoryItemId -> SqlFunction () inventoryMapSnack snack item conn = do [Only ()] <- query conn "SELECT garfield.inventory_map_snack(?, ?)" (snack.unSnackId, item.unInventoryItemId) diff --git a/src/Jon/Main.hs b/src/Jon/Main.hs index 66f076f..db854f1 100644 --- a/src/Jon/Main.hs +++ b/src/Jon/Main.hs @@ -1,5 +1,7 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} module Jon.Main ( main @@ -12,7 +14,6 @@ import Control.Exception (bracket) import Database.Beam import Database.Beam.Postgres import Servant -import Servant.Swagger import Servant.Swagger.UI import System.Environment import Network.Wai.Handler.Warp (run) @@ -28,6 +29,7 @@ main = withGarfieldConn $ \conn -> p :: Proxy (JonAPI :<|> SwaggerSchemaUI "swagger" "swagger.json") p = Proxy +withGarfieldConn :: (Connection -> IO a) -> IO a withGarfieldConn = bracket (do pass <- getEnv "JON_PASS" connectPostgreSQL $ BS8.pack $ "host=localhost dbname=garfield password=" ++ pass) diff --git a/src/Jon/Server.hs b/src/Jon/Server.hs index 2f54a58..67c09ec 100644 --- a/src/Jon/Server.hs +++ b/src/Jon/Server.hs @@ -1,9 +1,15 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Jon.Server (JonAPI, jonSwaggerDoc, server) where @@ -12,7 +18,8 @@ import Control.Lens import Control.Monad.IO.Class (liftIO) import Data.Aeson (FromJSON, ToJSON(toJSON)) import Data.Text (Text) -import Data.Int (Int32) +import Data.Int (Int32, Int64) +import Data.Scientific (Scientific) import Data.Swagger import Database.PostgreSQL.Simple (Connection) import GHC.Generics (Generic) @@ -27,13 +34,24 @@ import qualified Jon.Garfield.Queries as Queries type JonAPI = "rpc" :> - ( "getUnsoundBarcodes" :> ReqBody '[JSON] GetUnsoundBarcodesP + ( "getUnsoundBarcodes" :> Summary "Get information on barcodes with at least two items" + :> ReqBody '[JSON] GetUnsoundBarcodesP :> Post '[JSON] [UnsoundBarcodeDTO] - :<|> "getOverviewItems" :> ReqBody '[JSON] GetOverviewItemsP + :<|> "getOverviewItems" :> Summary "Get overview of all active items" + :> ReqBody '[JSON] GetOverviewItemsP :> Post '[JSON] [OverviewItemDTO] - :<|> "getActiveItems" :> ReqBody '[JSON] GetActiveItemsP + :<|> "getActiveItems" :> Summary "Get currently active items for a barcode" + :> ReqBody '[JSON] GetActiveItemsP :> Post '[JSON] [OverviewItemDTO] - :<|> "getLocations" :> Post '[JSON] [Location] + :<|> "getLocations" :> Summary "Get a list of all locations" + :> Post '[JSON] [Location] + :<|> "transferInventory" :> Summary "Transfer inventory between items" + :> Description "If `amount` is negative, its absolute value is transferred in the opposite direction." + :> ReqBody '[JSON] TransferInventoryP + :> PostNoContent + :<|> "updateSnack" :> Summary "Update a snack" + :> ReqBody '[JSON] UpdateSnackP + :> Post '[JSON] SnackId ) data GetUnsoundBarcodesP = GetUnsoundBarcodesP @@ -63,7 +81,22 @@ data GetActiveItemsP = GetActiveItemsP , location :: Int32 } deriving (Generic, FromJSON, ToSchema) +data TransferInventoryP = TransferInventoryP + { from :: Int32 + , to :: Int32 + , amount :: Int64 + } deriving (Generic, FromJSON, ToSchema) + +data UpdateSnackP = UpdateSnackP + { snack :: Int32 + , name :: Text + , barcode :: Text + , price :: Scientific + , taxGroup :: Int32 + } deriving (Generic, FromJSON, ToSchema) + -- Orphan instances for database types +-- needed for serialization and swagger doc instance ToJSON InventoryItemId where toJSON = toJSON . (.unInventoryItemId) @@ -85,6 +118,11 @@ instance ToJSON LocationId where instance ToSchema LocationId where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Int32) +instance ToJSON SnackId where + toJSON = toJSON . (.unSnackId) +instance ToSchema SnackId where + declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Int32) + deriving instance ToJSON Overview deriving instance ToSchema Overview @@ -97,7 +135,7 @@ deriving instance ToSchema Location -- server server :: Connection -> Server JonAPI -server conn = getUnsoundBarcodes :<|> getOverviewItems :<|> getActiveItems :<|> getLocations +server conn = getUnsoundBarcodes :<|> getOverviewItems :<|> getActiveItems :<|> getLocations :<|> transferInventory :<|> updateSnack where getUnsoundBarcodes :: GetUnsoundBarcodesP -> Handler [UnsoundBarcodeDTO] getUnsoundBarcodes params = do @@ -119,6 +157,24 @@ server conn = getUnsoundBarcodes :<|> getOverviewItems :<|> getActiveItems :<|> getLocations :: Handler [Location] getLocations = do liftIO $ Queries.runSelect conn Queries.locations + + transferInventory params = do + liftIO $ Queries.runIns conn $ Queries.transfer + (mkInventoryItemId params.from) + (mkInventoryItemId params.to) + params.amount + pure NoContent + + updateSnack params = do + liftIO $ Queries.runFunction conn $ Queries.snackUpdate + (mkSnackId params.snack) + params.name + params.barcode + params.price + (mkTaxGroupId params.taxGroup) +jonSwaggerDoc :: Swagger jonSwaggerDoc = toSwagger (Proxy :: Proxy JonAPI) - & info . title .~ "jon API" + & info . title .~ "jon API" + & info . version .~ "0.1.1" + & applyTags [Tag "jon RPC" (Just "Crudely improvised Garfield API") Nothing]