Add swagger endpoint

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

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

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

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, it)
-    pure ov
+
+locations
+    :: Q Postgres GarfieldDb s (LocationT (QExpr Postgres s))
+locations = all_ garfieldDb.locations
 
 -- Inserts
 

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"

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
+data UnsoundBarcodeDTO = UnsoundBarcodeDTO
-    { unsoundBarcodes :: [UnsoundBarcode]
+    { barcode   :: Text
-    } deriving (Show, Generic, ToJSON)
+    , name      :: Text
-
+    , entries   :: Int
-data UnsoundBarcode = UnsoundBarcode
-    { 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"