Add getUnsoundBarcodes route

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

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
 ]

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

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

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
+runQuery q = withGarfieldConn $ \conn -> runBeamPostgresDebug putStrLn conn $ runSelectReturningList $ select q
-    pass <- getEnv "JON_PASS"
-    conn <- connectPostgreSQL $ BS8.pack $ "host=localhost dbname=garfield password=" ++ pass
-    runBeamPostgresDebug putStrLn conn $ runSelectReturningList $ select q
 
 runIns
     :: SqlInsert Postgres table
     -> IO ()
-runIns i = do
+runIns i = withGarfieldConn $ \conn -> runBeamPostgresDebug putStrLn conn $ runInsert i
-    pass <- getEnv "JON_PASS"
-    conn <- connectPostgreSQL $ BS8.pack $ "host=localhost dbname=garfield password=" ++ pass
-    runBeamPostgresDebug putStrLn conn $ runInsert i
 
 runFunction
     :: (Connection -> IO a)
     -> IO a
-runFunction f = do
+runFunction = withGarfieldConn
-    pass <- getEnv "JON_PASS"
-    conn <- connectPostgreSQL $ BS8.pack $ "host=localhost dbname=garfield password=" ++ pass
-    f conn

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)