From e908d9dd8e8e86d4020b439d0e3ad277e88834e3 Mon Sep 17 00:00:00 2001 From: Paul Brinkmeier Date: Fri, 2 Dec 2022 17:11:42 +0100 Subject: [PATCH] Add swagger endpoint --- jon.cabal | 12 ++++ nix/haskell-deps.nix | 3 + package.yaml | 4 ++ src/Jon/Garfield/Queries.hs | 9 ++- src/Jon/Main.hs | 13 ++++- src/Jon/Server.hs | 109 ++++++++++++++++++++++++++++++------ 6 files changed, 127 insertions(+), 23 deletions(-) diff --git a/jon.cabal b/jon.cabal index 89d89f4..0a050d5 100644 --- a/jon.cabal +++ b/jon.cabal @@ -36,10 +36,14 @@ library , beam-core , beam-postgres , bytestring + , lens , postgresql-simple , scientific , servant , servant-server + , servant-swagger + , servant-swagger-ui + , swagger2 , text , time , warp @@ -57,10 +61,14 @@ executable jon-exe , beam-postgres , bytestring , jon + , lens , postgresql-simple , scientific , servant , servant-server + , servant-swagger + , servant-swagger-ui + , swagger2 , text , time , warp @@ -81,10 +89,14 @@ test-suite jon-test , beam-postgres , bytestring , jon + , lens , postgresql-simple , scientific , servant , servant-server + , servant-swagger + , servant-swagger-ui + , swagger2 , text , time , warp diff --git a/nix/haskell-deps.nix b/nix/haskell-deps.nix index 48604a1..02beee4 100644 --- a/nix/haskell-deps.nix +++ b/nix/haskell-deps.nix @@ -3,11 +3,14 @@ haskellPackages: with haskellPackages; [ beam-core beam-postgres bytestring + lens postgresql-simple servant servant-server + servant-swagger servant-swagger-ui scientific + swagger2 text time warp diff --git a/package.yaml b/package.yaml index 9bde67f..b176ffe 100644 --- a/package.yaml +++ b/package.yaml @@ -17,10 +17,14 @@ dependencies: - beam-core - beam-postgres - bytestring +- lens - postgresql-simple - servant - servant-server +- servant-swagger +- servant-swagger-ui - scientific +- swagger2 - text - time - warp diff --git a/src/Jon/Garfield/Queries.hs b/src/Jon/Garfield/Queries.hs index 1bea614..16c523a 100644 --- a/src/Jon/Garfield/Queries.hs +++ b/src/Jon/Garfield/Queries.hs @@ -57,12 +57,15 @@ unsoundBarcodes loc = activeItems :: Text -- barcode -> LocationId - -> Q Postgres GarfieldDb s (OverviewT (QExpr Postgres s)) + -> Q Postgres GarfieldDb s (OverviewT (QExpr Postgres s), InventoryItemT (QExpr Postgres s)) activeItems barcode loc = do (ov, it) <- overviewItemsByLocation loc guard_ $ it.barcode ==. val_ barcode - guard_ $ it.available ==. val_ True - pure ov + pure (ov, it) + +locations + :: Q Postgres GarfieldDb s (LocationT (QExpr Postgres s)) +locations = all_ garfieldDb.locations -- Inserts diff --git a/src/Jon/Main.hs b/src/Jon/Main.hs index 9a90d97..66f076f 100644 --- a/src/Jon/Main.hs +++ b/src/Jon/Main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} module Jon.Main @@ -10,16 +11,22 @@ module Jon.Main import Control.Exception (bracket) import Database.Beam import Database.Beam.Postgres -import Servant (Proxy(..), serve) +import Servant +import Servant.Swagger +import Servant.Swagger.UI import System.Environment import Network.Wai.Handler.Warp (run) import qualified Data.ByteString.Char8 as BS8 -import Jon.Server (JonAPI, server) +import Jon.Server (JonAPI, jonSwaggerDoc, server) main :: IO () -main = withGarfieldConn (run 8080 . serve (Proxy :: Proxy JonAPI) . server) +main = withGarfieldConn $ \conn -> + run 8080 $ serve p $ server conn :<|> swaggerSchemaUIServer jonSwaggerDoc + where + p :: Proxy (JonAPI :<|> SwaggerSchemaUI "swagger" "swagger.json") + p = Proxy withGarfieldConn = bracket (do pass <- getEnv "JON_PASS" diff --git a/src/Jon/Server.hs b/src/Jon/Server.hs index e72f8bf..2f54a58 100644 --- a/src/Jon/Server.hs +++ b/src/Jon/Server.hs @@ -2,16 +2,22 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -module Jon.Server where +module Jon.Server (JonAPI, jonSwaggerDoc, server) where +import Control.Lens import Control.Monad.IO.Class (liftIO) -import Data.Aeson (FromJSON, ToJSON) +import Data.Aeson (FromJSON, ToJSON(toJSON)) import Data.Text (Text) import Data.Int (Int32) +import Data.Swagger import Database.PostgreSQL.Simple (Connection) import GHC.Generics (Generic) import Servant +import Servant.Swagger (toSwagger) import Jon.Garfield.Types @@ -19,31 +25,100 @@ import qualified Jon.Garfield.Queries as Queries -- API and types -type JonAPI = "getUnsoundBarcodes" :> ReqBody '[JSON] GetUnsoundBarcodesP :> Post '[JSON] GetUnsoundBarcodesR +type JonAPI = + "rpc" :> + ( "getUnsoundBarcodes" :> ReqBody '[JSON] GetUnsoundBarcodesP + :> Post '[JSON] [UnsoundBarcodeDTO] + :<|> "getOverviewItems" :> ReqBody '[JSON] GetOverviewItemsP + :> Post '[JSON] [OverviewItemDTO] + :<|> "getActiveItems" :> ReqBody '[JSON] GetActiveItemsP + :> Post '[JSON] [OverviewItemDTO] + :<|> "getLocations" :> Post '[JSON] [Location] + ) data GetUnsoundBarcodesP = GetUnsoundBarcodesP { location :: Int32 - } deriving (Show, Generic, FromJSON) + } deriving (Generic, FromJSON, ToSchema) -data GetUnsoundBarcodesR = GetUnsoundBarcodesR - { unsoundBarcodes :: [UnsoundBarcode] - } deriving (Show, Generic, ToJSON) - -data UnsoundBarcode = UnsoundBarcode - { barcode :: Text - , name :: Text - , entries :: Int +data UnsoundBarcodeDTO = UnsoundBarcodeDTO + { barcode :: Text + , name :: Text + , entries :: Int , unitsLeft :: Int - } deriving (Show, Generic, ToJSON) + } deriving (Generic, ToJSON, ToSchema) + +data GetOverviewItemsP = GetOverviewItemsP + { location :: Int32 + } deriving (Generic, FromJSON, ToSchema) + +data OverviewItemDTO = OverviewItemDTO + { overview :: Overview + , item :: InventoryItem + } deriving (Generic, ToJSON, ToSchema) + +mkOverviewItemDTO = uncurry OverviewItemDTO + +data GetActiveItemsP = GetActiveItemsP + { barcode :: Text + , location :: Int32 + } deriving (Generic, FromJSON, ToSchema) + +-- Orphan instances for database types + +instance ToJSON InventoryItemId where + toJSON = toJSON . (.unInventoryItemId) +instance ToSchema InventoryItemId where + declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Int32) + +instance ToJSON InventoryItemGroupId where + toJSON = toJSON . (.unInventoryItemGroupId) +instance ToSchema InventoryItemGroupId where + declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Int32) + +instance ToJSON TaxGroupId where + toJSON = toJSON . (.unTaxGroupId) +instance ToSchema TaxGroupId where + declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Int32) + +instance ToJSON LocationId where + toJSON = toJSON . (.unLocationId) +instance ToSchema LocationId where + declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Int32) + +deriving instance ToJSON Overview +deriving instance ToSchema Overview + +deriving instance ToJSON InventoryItem +deriving instance ToSchema InventoryItem + +deriving instance ToJSON Location +deriving instance ToSchema Location -- server server :: Connection -> Server JonAPI -server conn = getUnsoundBarcodes +server conn = getUnsoundBarcodes :<|> getOverviewItems :<|> getActiveItems :<|> getLocations where - getUnsoundBarcodes :: GetUnsoundBarcodesP -> Handler GetUnsoundBarcodesR + getUnsoundBarcodes :: GetUnsoundBarcodesP -> Handler [UnsoundBarcodeDTO] getUnsoundBarcodes params = do rows <- liftIO $ Queries.runSelect conn $ Queries.unsoundBarcodes $ mkLocationId params.location - pure $ GetUnsoundBarcodesR $ map mkUnsoundBarcode rows + pure $ map mkUnsoundBarcodeDTO rows where - mkUnsoundBarcode (a, b, c, d) = UnsoundBarcode a b (fromIntegral c) (fromIntegral d) + mkUnsoundBarcodeDTO (a, b, c, d) = UnsoundBarcodeDTO a b (fromIntegral c) (fromIntegral d) + + getOverviewItems :: GetOverviewItemsP -> Handler [OverviewItemDTO] + getOverviewItems params = do + rows <- liftIO $ Queries.runSelect conn $ Queries.overviewItemsByLocation $ mkLocationId params.location + pure $ map mkOverviewItemDTO rows + + getActiveItems :: GetActiveItemsP -> Handler [OverviewItemDTO] + getActiveItems params = do + rows <- liftIO $ Queries.runSelect conn $ Queries.activeItems params.barcode $ mkLocationId params.location + pure $ map mkOverviewItemDTO rows + + getLocations :: Handler [Location] + getLocations = do + liftIO $ Queries.runSelect conn Queries.locations + +jonSwaggerDoc = toSwagger (Proxy :: Proxy JonAPI) + & info . title .~ "jon API"