Fix for fd leakage

coop-extras/json-fact-statement-store/app/FactStatementStoreGrpc.hs

@@ -15,10 +15,11 @@ import Data.String (IsString (fromString))
 import Data.Text (Text)
 import Data.Text qualified as Text
 import Data.Traversable (for)
+import Data.Word (Word16)
 import Database.Beam (SqlValable (val_), runSelectReturningOne)
 import Database.Beam.Query (SqlEq ((==.)), all_, filter_, select)
 import Database.Beam.Sqlite (runBeamSqliteDebug)
-import Database.SQLite.Simple (open)
+import Database.SQLite.Simple (Connection, withConnection)
 import Network.GRPC.HTTP2.Encoding as Encoding (
   gzip,
   uncompressed,
@@ -41,7 +42,7 @@ import Prelude hiding (error, succ)
 data FactStatementStoreGrpcOpts = FactStatementStoreGrpcOpts
   { _db :: FilePath
   , _grpcAddress :: String
-  , _grpcPort :: Int
+  , _grpcPort :: Word16
   , _tlsCertFile :: FilePath
   , _tlsKeyFile :: FilePath
   }
@@ -50,21 +51,21 @@ data FactStatementStoreGrpcOpts = FactStatementStoreGrpcOpts
 makeLenses ''FactStatementStoreGrpcOpts
 
 factStatementStoreService :: FactStatementStoreGrpcOpts -> IO ()
-factStatementStoreService opts = do
-  let routes :: [ServiceHandler]
-      routes =
-        [Server.unary (RPC :: RPC FactStatementStore "getFactStatement") (handleReq $ opts ^. db)]
+factStatementStoreService opts =
+  withConnection (opts ^. db) $ \dbConn ->
+    let routes :: [ServiceHandler]
+        routes =
+          [Server.unary (RPC :: RPC FactStatementStore "getFactStatement") (handleReq dbConn)]
+     in runServer
+          routes
+          (fromString $ opts ^. grpcAddress, opts ^. grpcPort)
+          (opts ^. tlsCertFile, opts ^. tlsKeyFile)
 
-  runServer
-    routes
-    (fromString $ opts ^. grpcAddress, opts ^. grpcPort)
-    (opts ^. tlsCertFile, opts ^. tlsKeyFile)
-
-runServer :: [ServiceHandler] -> (Warp.HostPreference, Int) -> (FilePath, FilePath) -> IO ()
+runServer :: [ServiceHandler] -> (Warp.HostPreference, Word16) -> (FilePath, FilePath) -> IO ()
 runServer routes (h, p) (certFile, keyFile) = do
   let warpSettings =
         Warp.defaultSettings
-          & Warp.setPort p
+          & Warp.setPort (fromIntegral p)
           & Warp.setHost h
   Server.runGrpc
     (tlsSettings certFile keyFile)
@@ -76,18 +77,16 @@ runServer routes (h, p) (certFile, keyFile) = do
 
 type FsT = FactStatementT Identity
 
-handleReq :: FilePath -> Server.UnaryHandler IO GetFactStatementRequest GetFactStatementResponse
-handleReq dbPath _ req = do
-  putStrLn $ "Establishing the database connection to: " <> dbPath
-  fsDb <- open dbPath
+handleReq :: Connection -> Server.UnaryHandler IO GetFactStatementRequest GetFactStatementResponse
+handleReq dbConn _ req = do
   let fsTbl' = fsTbl fsStoreSettings
       ids = nub $ req ^. fsIds
 
   idsWithRes :: [Either Text Success'FsIdAndPlutus] <-
     for
       ids
       ( \i -> do
-          (mayFsT :: Maybe FsT) <- runBeamSqliteDebug Prelude.putStrLn fsDb $ runSelectReturningOne (select $ filter_ (\fs -> _factStatementId fs ==. val_ i) (all_ fsTbl'))
+          (mayFsT :: Maybe FsT) <- runBeamSqliteDebug Prelude.putStrLn dbConn $ runSelectReturningOne (select $ filter_ (\fs -> _factStatementId fs ==. val_ i) (all_ fsTbl'))
           maybe
             (return (Left $ Text.pack "Not found requested Fact Statement with ID " <> (Text.pack . show $ i)))
             ( \fs -> do

coop-extras/json-fact-statement-store/app/Genesis.hs

@@ -6,7 +6,7 @@ import BeamConfig (factStatementsCreateTable)
 import Cardano.Proto.Aux ()
 import Control.Lens (makeLenses, (^.))
 import Data.String (IsString (fromString))
-import Database.SQLite.Simple (execute_, open)
+import Database.SQLite.Simple (execute_, withConnection)
 
 newtype GenesisOpts = GenesisOpts
   { _db :: FilePath
@@ -16,6 +16,5 @@ newtype GenesisOpts = GenesisOpts
 makeLenses ''GenesisOpts
 
 genesis :: GenesisOpts -> IO ()
-genesis opts = do
-  conn <- open (opts ^. db)
-  execute_ conn (fromString factStatementsCreateTable)
+genesis opts = withConnection (opts ^. db) $ \dbConn ->
+  execute_ dbConn (fromString factStatementsCreateTable)

coop-extras/json-fact-statement-store/app/InsertFs.hs

@@ -10,7 +10,7 @@ import Data.Text (Text)
 import Data.Text.Encoding (encodeUtf8)
 import Database.Beam.Query (insert, insertValues, runInsert)
 import Database.Beam.Sqlite (runBeamSqliteDebug)
-import Database.SQLite.Simple (open)
+import Database.SQLite.Simple (withConnection)
 
 data InsertFsOpts = InsertFsOpts
   { _db :: FilePath
@@ -22,9 +22,8 @@ data InsertFsOpts = InsertFsOpts
 makeLenses ''InsertFsOpts
 
 insertFs :: InsertFsOpts -> IO ()
-insertFs opts = do
-  conn <- open (opts ^. db)
-  runBeamSqliteDebug putStrLn conn $ do
+insertFs opts = withConnection (opts ^. db) $ \dbConn ->
+  runBeamSqliteDebug putStrLn dbConn $
     runInsert $
       insert (fsTbl fsStoreSettings) $
         insertValues

coop-extras/json-fact-statement-store/json-fact-statement-store.cabal

@@ -84,6 +84,7 @@ executable json-fs-store-cli
   import:         common-language
   main-is:        Main.hs
   hs-source-dirs: app
+  ghc-options:    -threaded
   other-modules:
     BeamConfig
     FactStatementStoreGrpc