From 1c0c1457bd4861e456437431ee6b528fa1a4859d Mon Sep 17 00:00:00 2001 From: Paul Brinkmeier Date: Fri, 2 Dec 2022 15:55:23 +0100 Subject: [PATCH] Add getUnsoundBarcodes route --- jon.cabal | 16 +++++++++--- nix/haskell-deps.nix | 4 +++ package.yaml | 3 +++ src/Jon/Garfield/Queries.hs | 7 ++++++ src/Jon/Main.hs | 27 ++++++++++---------- src/Jon/Server.hs | 49 +++++++++++++++++++++++++++++++++++++ 6 files changed, 90 insertions(+), 16 deletions(-) create mode 100644 src/Jon/Server.hs diff --git a/jon.cabal b/jon.cabal index 81a96b9..89d89f4 100644 --- a/jon.cabal +++ b/jon.cabal @@ -24,21 +24,25 @@ library Jon.Garfield.Queries Jon.Garfield.Types Jon.Main + Jon.Server other-modules: Paths_jon hs-source-dirs: src ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints build-depends: - base >=4.7 && <5 + aeson + , base >=4.7 && <5 , beam-core , beam-postgres , bytestring , postgresql-simple , scientific + , servant , servant-server , text , time + , warp default-language: Haskell2010 executable jon-exe @@ -47,16 +51,19 @@ executable jon-exe app ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N build-depends: - base >=4.7 && <5 + aeson + , base >=4.7 && <5 , beam-core , beam-postgres , bytestring , jon , postgresql-simple , scientific + , servant , servant-server , text , time + , warp default-language: Haskell2010 test-suite jon-test @@ -68,14 +75,17 @@ test-suite jon-test test ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N build-depends: - base >=4.7 && <5 + aeson + , base >=4.7 && <5 , beam-core , beam-postgres , bytestring , jon , postgresql-simple , scientific + , servant , servant-server , text , time + , warp default-language: Haskell2010 diff --git a/nix/haskell-deps.nix b/nix/haskell-deps.nix index c9691c8..48604a1 100644 --- a/nix/haskell-deps.nix +++ b/nix/haskell-deps.nix @@ -1,10 +1,14 @@ haskellPackages: with haskellPackages; [ + aeson beam-core beam-postgres bytestring postgresql-simple + servant servant-server + servant-swagger-ui scientific text time + warp ] diff --git a/package.yaml b/package.yaml index a1cc073..9bde67f 100644 --- a/package.yaml +++ b/package.yaml @@ -13,14 +13,17 @@ extra-source-files: dependencies: - base >= 4.7 && < 5 +- aeson - beam-core - beam-postgres - bytestring - postgresql-simple +- servant - servant-server - scientific - text - time +- warp ghc-options: - -Wall diff --git a/src/Jon/Garfield/Queries.hs b/src/Jon/Garfield/Queries.hs index f375d79..1bea614 100644 --- a/src/Jon/Garfield/Queries.hs +++ b/src/Jon/Garfield/Queries.hs @@ -18,6 +18,13 @@ import Jon.Garfield.Types -- Selects +runSelect + :: (FromBackendRow Postgres (QExprToIdentity e), Projectible Postgres e) + => Connection + -> Q Postgres db QBaseScope e + -> IO [QExprToIdentity e] +runSelect conn q = runBeamPostgresDebug putStrLn conn $ runSelectReturningList $ select q + overviewItems :: Q Postgres GarfieldDb s (OverviewT (QExpr Postgres s), InventoryItemT (QExpr Postgres s)) overviewItems = do diff --git a/src/Jon/Main.hs b/src/Jon/Main.hs index faf29ea..9a90d97 100644 --- a/src/Jon/Main.hs +++ b/src/Jon/Main.hs @@ -7,36 +7,37 @@ module Jon.Main , runIns ) where +import Control.Exception (bracket) import Database.Beam import Database.Beam.Postgres +import Servant (Proxy(..), serve) import System.Environment +import Network.Wai.Handler.Warp (run) import qualified Data.ByteString.Char8 as BS8 +import Jon.Server (JonAPI, server) + main :: IO () -main = pure () +main = withGarfieldConn (run 8080 . serve (Proxy :: Proxy JonAPI) . server) + +withGarfieldConn = bracket + (do pass <- getEnv "JON_PASS" + connectPostgreSQL $ BS8.pack $ "host=localhost dbname=garfield password=" ++ pass) + close runQuery :: (FromBackendRow Postgres (QExprToIdentity e), Projectible Postgres e) => Q Postgres db QBaseScope e -> IO [QExprToIdentity e] -runQuery q = do - pass <- getEnv "JON_PASS" - conn <- connectPostgreSQL $ BS8.pack $ "host=localhost dbname=garfield password=" ++ pass - runBeamPostgresDebug putStrLn conn $ runSelectReturningList $ select q +runQuery q = withGarfieldConn $ \conn -> runBeamPostgresDebug putStrLn conn $ runSelectReturningList $ select q runIns :: SqlInsert Postgres table -> IO () -runIns i = do - pass <- getEnv "JON_PASS" - conn <- connectPostgreSQL $ BS8.pack $ "host=localhost dbname=garfield password=" ++ pass - runBeamPostgresDebug putStrLn conn $ runInsert i +runIns i = withGarfieldConn $ \conn -> runBeamPostgresDebug putStrLn conn $ runInsert i runFunction :: (Connection -> IO a) -> IO a -runFunction f = do - pass <- getEnv "JON_PASS" - conn <- connectPostgreSQL $ BS8.pack $ "host=localhost dbname=garfield password=" ++ pass - f conn +runFunction = withGarfieldConn diff --git a/src/Jon/Server.hs b/src/Jon/Server.hs new file mode 100644 index 0000000..e72f8bf --- /dev/null +++ b/src/Jon/Server.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedRecordDot #-} + +module Jon.Server where + +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import Data.Int (Int32) +import Database.PostgreSQL.Simple (Connection) +import GHC.Generics (Generic) +import Servant + +import Jon.Garfield.Types + +import qualified Jon.Garfield.Queries as Queries + +-- API and types + +type JonAPI = "getUnsoundBarcodes" :> ReqBody '[JSON] GetUnsoundBarcodesP :> Post '[JSON] GetUnsoundBarcodesR + +data GetUnsoundBarcodesP = GetUnsoundBarcodesP + { location :: Int32 + } deriving (Show, Generic, FromJSON) + +data GetUnsoundBarcodesR = GetUnsoundBarcodesR + { unsoundBarcodes :: [UnsoundBarcode] + } deriving (Show, Generic, ToJSON) + +data UnsoundBarcode = UnsoundBarcode + { barcode :: Text + , name :: Text + , entries :: Int + , unitsLeft :: Int + } deriving (Show, Generic, ToJSON) + +-- server + +server :: Connection -> Server JonAPI +server conn = getUnsoundBarcodes + where + getUnsoundBarcodes :: GetUnsoundBarcodesP -> Handler GetUnsoundBarcodesR + getUnsoundBarcodes params = do + rows <- liftIO $ Queries.runSelect conn $ Queries.unsoundBarcodes $ mkLocationId params.location + pure $ GetUnsoundBarcodesR $ map mkUnsoundBarcode rows + where + mkUnsoundBarcode (a, b, c, d) = UnsoundBarcode a b (fromIntegral c) (fromIntegral d)