274 lines
9.9 KiB
Haskell
274 lines
9.9 KiB
Haskell
{-# 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
|
|
|
|
import Control.Lens
|
|
import Control.Monad.IO.Class (liftIO)
|
|
import Data.Aeson (FromJSON(parseJSON), ToJSON(toJSON))
|
|
import Data.Text (Text)
|
|
import Data.Int (Int32, Int64)
|
|
import Data.Scientific (Scientific)
|
|
import Data.Swagger
|
|
import Database.PostgreSQL.Simple (Connection)
|
|
import GHC.Generics (Generic)
|
|
import Servant
|
|
import Servant.Swagger (toSwagger)
|
|
|
|
import Jon.Garfield.Types
|
|
|
|
import qualified Jon.Garfield.Queries as Queries
|
|
|
|
-- API and types
|
|
|
|
type JonAPI =
|
|
"rpc" :>
|
|
( "getUnsoundBarcodes" :> Summary "Get information on barcodes with at least two items"
|
|
:> ReqBody '[JSON] GetUnsoundBarcodesP
|
|
:> Post '[JSON] [UnsoundBarcodeDTO]
|
|
:<|> "getOverviewItems" :> Summary "Get overview of all active items"
|
|
:> ReqBody '[JSON] GetOverviewItemsP
|
|
:> Post '[JSON] [OverviewItemDTO]
|
|
:<|> "getActiveItems" :> Summary "Get currently active items for a barcode"
|
|
:> ReqBody '[JSON] GetActiveItemsP
|
|
:> 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
|
|
:> PostNoContent
|
|
:<|> "disableItems" :> Summary "Disable inventory items"
|
|
:> ReqBody '[JSON] DisableItemsP
|
|
:> PostNoContent
|
|
:<|> SnackAPI
|
|
)
|
|
|
|
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
|
|
:<|> "deleteSnack" :> Summary "Delete a snack"
|
|
:> ReqBody '[JSON] DeleteSnackP
|
|
:> PostNoContent
|
|
|
|
data GetUnsoundBarcodesP = GetUnsoundBarcodesP
|
|
{ location :: LocationId
|
|
} deriving (Generic, FromJSON, ToSchema)
|
|
|
|
data UnsoundBarcodeDTO = UnsoundBarcodeDTO
|
|
{ barcode :: Text
|
|
, name :: Text
|
|
, entries :: Int
|
|
, unitsLeft :: Int
|
|
} deriving (Generic, ToJSON, ToSchema)
|
|
|
|
data GetOverviewItemsP = GetOverviewItemsP
|
|
{ location :: LocationId
|
|
} deriving (Generic, FromJSON, ToSchema)
|
|
|
|
data OverviewItemDTO = OverviewItemDTO
|
|
{ overview :: Overview
|
|
, item :: InventoryItem
|
|
} deriving (Generic, ToJSON, ToSchema)
|
|
|
|
mkOverviewItemDTO = uncurry OverviewItemDTO
|
|
|
|
data GetActiveItemsP = GetActiveItemsP
|
|
{ barcode :: Text
|
|
, 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)
|
|
|
|
data InventoryTransferDTO = InventoryTransfer
|
|
{ from :: InventoryItemId
|
|
, to :: InventoryItemId
|
|
, amount :: Int64
|
|
} deriving (Generic, FromJSON, ToSchema)
|
|
|
|
data DisableItemsP = DisableItemsP
|
|
{ items :: [InventoryItemId]
|
|
} deriving (Generic, FromJSON, ToSchema)
|
|
|
|
data CreateSnackP = CreateSnackP
|
|
{ name :: Text
|
|
, barcode :: Text
|
|
, price :: Scientific
|
|
, taxGroup :: TaxGroupId
|
|
, location :: LocationId
|
|
} deriving (Generic, FromJSON, ToSchema)
|
|
|
|
data GetSnacksByItemIdP = GetSnacksByItemIdP
|
|
{ item :: InventoryItemId
|
|
} deriving (Generic, FromJSON, ToSchema)
|
|
|
|
data UpdateSnackP = UpdateSnackP
|
|
{ snack :: SnackId
|
|
, name :: Text
|
|
, barcode :: Text
|
|
, price :: Scientific
|
|
, taxGroup :: TaxGroupId
|
|
} deriving (Generic, FromJSON, ToSchema)
|
|
|
|
data DeleteSnackP = DeleteSnackP
|
|
{ snack :: SnackId
|
|
} deriving (Generic, FromJSON, ToSchema)
|
|
|
|
-- Orphan instances for database types
|
|
-- needed for serialization and swagger doc
|
|
|
|
instance ToJSON InventoryItemId where
|
|
toJSON = toJSON . (.unInventoryItemId)
|
|
instance FromJSON InventoryItemId where
|
|
parseJSON = fmap mkInventoryItemId . parseJSON
|
|
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 FromJSON TaxGroupId where
|
|
parseJSON = fmap mkTaxGroupId . parseJSON
|
|
instance ToSchema TaxGroupId where
|
|
declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Int32)
|
|
|
|
instance ToJSON LocationId where
|
|
toJSON = toJSON . (.unLocationId)
|
|
instance FromJSON LocationId where
|
|
parseJSON = fmap mkLocationId . parseJSON
|
|
instance ToSchema LocationId where
|
|
declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Int32)
|
|
|
|
instance ToJSON SnackId where
|
|
toJSON = toJSON . (.unSnackId)
|
|
instance FromJSON SnackId where
|
|
parseJSON = fmap mkSnackId . parseJSON
|
|
instance ToSchema SnackId 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
|
|
|
|
deriving instance ToJSON Snack
|
|
deriving instance ToSchema Snack
|
|
|
|
-- server
|
|
|
|
server :: Connection -> Server JonAPI
|
|
server conn =
|
|
getUnsoundBarcodes
|
|
:<|> getOverviewItems
|
|
:<|> getActiveItems
|
|
:<|> getLocations
|
|
:<|> adjustInventory
|
|
:<|> transferInventory
|
|
:<|> disableItems
|
|
:<|> createSnack
|
|
:<|> getSnacksByItemId
|
|
:<|> updateSnack
|
|
:<|> deleteSnack
|
|
where
|
|
getUnsoundBarcodes :: GetUnsoundBarcodesP -> Handler [UnsoundBarcodeDTO]
|
|
getUnsoundBarcodes params = do
|
|
rows <- liftIO $ Queries.runSelect conn $ Queries.unsoundBarcodes params.location
|
|
pure $ map mkUnsoundBarcodeDTO rows
|
|
where
|
|
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 params.location
|
|
pure $ map mkOverviewItemDTO rows
|
|
|
|
getActiveItems :: GetActiveItemsP -> Handler [OverviewItemDTO]
|
|
getActiveItems params = do
|
|
rows <- liftIO $ Queries.runSelect conn $ Queries.activeItems params.barcode params.location
|
|
pure $ map mkOverviewItemDTO rows
|
|
|
|
getLocations :: Handler [Location]
|
|
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
|
|
pure NoContent
|
|
|
|
disableItems :: DisableItemsP -> Handler NoContent
|
|
disableItems params = do
|
|
liftIO $ Queries.runUpdates conn $ map Queries.disableItem params.items
|
|
pure NoContent
|
|
|
|
createSnack params = do
|
|
liftIO $ Queries.runFunction conn $ Queries.snackCreate
|
|
params.name
|
|
params.barcode
|
|
params.price
|
|
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
|
|
params.name
|
|
params.barcode
|
|
params.price
|
|
params.taxGroup
|
|
|
|
deleteSnack params = do
|
|
liftIO $ Queries.runFunction conn $ Queries.snackDelete params.snack
|
|
pure NoContent
|
|
|
|
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]
|
|
-- Doesn't work :(
|
|
-- & applyTagsFor (operationsOf $ toSwagger (Proxy :: Proxy SnackAPI)) [Tag "Snacks" Nothing Nothing]
|