diff --git a/coop-extras/json-fact-statement-store/app/FactStatementStoreGrpc.hs b/coop-extras/json-fact-statement-store/app/FactStatementStoreGrpc.hs index 0ff3f14..879b669 100644 --- a/coop-extras/json-fact-statement-store/app/FactStatementStoreGrpc.hs +++ b/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,10 +77,8 @@ 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 @@ -87,7 +86,7 @@ handleReq dbPath _ req = do 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 diff --git a/coop-extras/json-fact-statement-store/app/Genesis.hs b/coop-extras/json-fact-statement-store/app/Genesis.hs index 51ff311..c689ddc 100644 --- a/coop-extras/json-fact-statement-store/app/Genesis.hs +++ b/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) diff --git a/coop-extras/json-fact-statement-store/app/InsertFs.hs b/coop-extras/json-fact-statement-store/app/InsertFs.hs index bf2baad..517f925 100644 --- a/coop-extras/json-fact-statement-store/app/InsertFs.hs +++ b/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 diff --git a/coop-extras/json-fact-statement-store/json-fact-statement-store.cabal b/coop-extras/json-fact-statement-store/json-fact-statement-store.cabal index 9741044..9e85d46 100644 --- a/coop-extras/json-fact-statement-store/json-fact-statement-store.cabal +++ b/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 diff --git a/coop-publisher/app/Coop/Cli/PublisherGrpc.hs b/coop-publisher/app/Coop/Cli/PublisherGrpc.hs index 2899be7..9f7899a 100644 --- a/coop-publisher/app/Coop/Cli/PublisherGrpc.hs +++ b/coop-publisher/app/Coop/Cli/PublisherGrpc.hs @@ -2,14 +2,17 @@ module Coop.Cli.PublisherGrpc (publisherService, PublisherGrpcOpts (..)) where -import Control.Lens (makeLenses, (&), (.~), (^.)) +import Control.Exception (bracket) +import Control.Lens (both, makeLenses, traverseOf_, (&), (.~), (^.)) +import Control.Monad (void) import Data.Map qualified as Map import Data.ProtoLens (Message (defMessage)) import Data.Text (Text) import Data.Text qualified as Text +import Data.Word (Word16) import GHC.Exts (fromString) import Network.GRPC.Client (RawReply) -import Network.GRPC.Client.Helpers (GrpcClient, GrpcClientConfig (_grpcClientConfigCompression), grpcClientConfigSimple, rawUnary, setupGrpcClient) +import Network.GRPC.Client.Helpers (GrpcClient, GrpcClientConfig (_grpcClientConfigCompression), close, grpcClientConfigSimple, rawUnary, setupGrpcClient) import Network.GRPC.HTTP2.Encoding as Encoding ( GRPCInput, GRPCOutput, @@ -24,7 +27,7 @@ import Network.GRPC.Server as Server ( runGrpc, unary, ) -import Network.HTTP2.Client (ClientIO, HostName, PortNumber, TooMuchConcurrency, runClientIO) +import Network.HTTP2.Client (ClientIO, HostName, TooMuchConcurrency, runClientIO) import Network.Wai.Handler.Warp qualified as Warp import Network.Wai.Handler.WarpTLS (tlsSettings) import Proto.FactStatementStoreService (FactStatementStore, GetFactStatementResponse) @@ -45,126 +48,131 @@ import Proto.TxBuilderService_Fields (factStatements, fs) data PublisherGrpcOpts = PublisherGrpcOpts { _grpcAddress :: String - , _grpcPort :: Int + , _grpcPort :: Word16 , _tlsCertFile :: FilePath , _tlsKeyFile :: FilePath , _fsStoreAddress :: String - , _fsStorePort :: Int + , _fsStorePort :: Word16 , _txBuilderAddress :: String - , _txBuilderPort :: Int + , _txBuilderPort :: Word16 } deriving stock (Show, Eq) makeLenses ''PublisherGrpcOpts publisherService :: PublisherGrpcOpts -> IO () -publisherService opts = do - let handleCreateMintFsTx :: Server.UnaryHandler IO CreateMintFsTxRequest CreateMintFsTxResponse - handleCreateMintFsTx _ req = do - print ("Got from user: " <> show req) - getFsRespOrErr <- - call' - (opts ^. fsStoreAddress) - (fromInteger . toInteger $ opts ^. fsStorePort) - (RPC :: RPC FactStatementStore "getFactStatement") - (defMessage & fsIds .~ ((^. fsId) <$> req ^. fsInfos)) - either - (\err -> return $ defMessage & PublisherService.error .~ err) - ( \(getFsResp :: GetFactStatementResponse) -> do - print ("Got from FactStatementStore: " <> show getFsResp) - case getFsResp ^. maybe'error of - Nothing -> do - let fsIdToGcAfter = Map.fromList [(fsI ^. fsId, fsI ^. gcAfter) | fsI <- req ^. fsInfos] - fsInfos' = - [ (defMessage :: FactStatementInfo) - & fsId .~ fsI ^. fsId - & fs .~ fsI ^. plutusData - & gcAfter .~ gcAf - | fsI <- getFsResp ^. success . fsIdsWithPlutus - , gcAf <- maybe [] return $ Map.lookup (fsI ^. fsId) fsIdToGcAfter - ] - let crMintFsTxReq :: TxBuilder.CreateMintFsTxReq - crMintFsTxReq = - defMessage - & factStatements .~ fsInfos' - & submitter .~ req ^. submitter - print ("Sending CreateMintFsTxReq to TxBuilder: " <> show crMintFsTxReq) - createMintFsRespOrErr <- - call' - (opts ^. txBuilderAddress) - (fromInteger . toInteger $ opts ^. txBuilderPort) - (RPC :: RPC TxBuilder "createMintFsTx") - crMintFsTxReq - either - (\err -> return $ defMessage & PublisherService.error .~ err) - ( \(createMintFsResp :: TxBuilder.CreateMintFsTxResp) -> do - print ("Got from TxBuilder: " <> show getFsResp) - case createMintFsResp ^. maybe'error of - Nothing -> - return $ - (defMessage :: CreateMintFsTxResponse) - & mintFsTx .~ createMintFsResp ^. success . mintFsTx - & info . txBuilderInfo .~ createMintFsResp ^. info - Just er -> - return $ - (defMessage :: CreateMintFsTxResponse) - & PublisherService.error . txBuilderErr .~ er - & info . txBuilderInfo .~ createMintFsResp ^. info - ) - createMintFsRespOrErr - Just er -> return $ (defMessage :: CreateMintFsTxResponse) & PublisherService.error . fsStoreErr .~ er - ) - getFsRespOrErr - - handleCreateGcFsTx :: Server.UnaryHandler IO CreateGcFsTxRequest CreateGcFsTxResponse - handleCreateGcFsTx _ req = do - print ("Got from user: " <> show req) - let txBuilderReq :: TxBuilder.CreateGcFsTxReq - txBuilderReq = - defMessage - & fsIds .~ req ^. fsIds - & submitter .~ req ^. submitter - print ("Sending CreateGcFsTxRequest to TxBuilder: " <> show txBuilderReq) - createGcFsRespOrErr <- - call' - (opts ^. txBuilderAddress) - (fromInteger . toInteger $ opts ^. txBuilderPort) - (RPC :: RPC TxBuilder "createGcFsTx") - txBuilderReq - either - (\err -> return $ defMessage & PublisherService.error .~ err) - ( \(createGcFsResp :: TxBuilder.CreateGcFsTxResp) -> do - print ("Got from TxBuilder: " <> show createGcFsResp) - case createGcFsResp ^. maybe'error of - Nothing -> - return $ - (defMessage :: CreateGcFsTxResponse) - & gcFsTx .~ createGcFsResp ^. success . gcFsTx - & info . txBuilderInfo .~ createGcFsResp ^. info - Just er -> - return $ - (defMessage :: CreateGcFsTxResponse) - & PublisherService.error . txBuilderErr .~ er - & info . txBuilderInfo .~ createGcFsResp ^. info - ) - createGcFsRespOrErr - - routes :: [ServiceHandler] - routes = - [ Server.unary (RPC :: RPC Publisher "createMintFsTx") handleCreateMintFsTx - , Server.unary (RPC :: RPC Publisher "createGcFsTx") handleCreateGcFsTx - ] - - runServer - routes - (fromString $ opts ^. grpcAddress, opts ^. grpcPort) - (opts ^. tlsCertFile, opts ^. tlsKeyFile) +publisherService opts = + let setup = + (,) + <$> mkClient (opts ^. fsStoreAddress) (opts ^. fsStorePort) + <*> mkClient (opts ^. txBuilderAddress) (opts ^. txBuilderPort) + + cleanup = traverseOf_ both closeClient + + serve fsStoreClient txBuilderClient = + let handleCreateMintFsTx :: Server.UnaryHandler IO CreateMintFsTxRequest CreateMintFsTxResponse + handleCreateMintFsTx _ req = do + print ("Got from user: " <> show req) + getFsRespOrErr <- + call' + fsStoreClient + (RPC :: RPC FactStatementStore "getFactStatement") + (defMessage & fsIds .~ ((^. fsId) <$> req ^. fsInfos)) + either + (\err -> return $ defMessage & PublisherService.error .~ err) + ( \(getFsResp :: GetFactStatementResponse) -> do + print ("Got from FactStatementStore: " <> show getFsResp) + case getFsResp ^. maybe'error of + Nothing -> do + let fsIdToGcAfter = Map.fromList [(fsI ^. fsId, fsI ^. gcAfter) | fsI <- req ^. fsInfos] + fsInfos' = + [ (defMessage :: FactStatementInfo) + & fsId .~ fsI ^. fsId + & fs .~ fsI ^. plutusData + & gcAfter .~ gcAf + | fsI <- getFsResp ^. success . fsIdsWithPlutus + , gcAf <- maybe [] return $ Map.lookup (fsI ^. fsId) fsIdToGcAfter + ] + let crMintFsTxReq :: TxBuilder.CreateMintFsTxReq + crMintFsTxReq = + defMessage + & factStatements .~ fsInfos' + & submitter .~ req ^. submitter + print ("Sending CreateMintFsTxReq to TxBuilder: " <> show crMintFsTxReq) + createMintFsRespOrErr <- + call' + txBuilderClient + (RPC :: RPC TxBuilder "createMintFsTx") + crMintFsTxReq + either + (\err -> return $ defMessage & PublisherService.error .~ err) + ( \(createMintFsResp :: TxBuilder.CreateMintFsTxResp) -> do + print ("Got from TxBuilder: " <> show getFsResp) + case createMintFsResp ^. maybe'error of + Nothing -> + return $ + (defMessage :: CreateMintFsTxResponse) + & mintFsTx .~ createMintFsResp ^. success . mintFsTx + & info . txBuilderInfo .~ createMintFsResp ^. info + Just er -> + return $ + (defMessage :: CreateMintFsTxResponse) + & PublisherService.error . txBuilderErr .~ er + & info . txBuilderInfo .~ createMintFsResp ^. info + ) + createMintFsRespOrErr + Just er -> return $ (defMessage :: CreateMintFsTxResponse) & PublisherService.error . fsStoreErr .~ er + ) + getFsRespOrErr -runServer :: [ServiceHandler] -> (Warp.HostPreference, Int) -> (FilePath, FilePath) -> IO () + handleCreateGcFsTx :: Server.UnaryHandler IO CreateGcFsTxRequest CreateGcFsTxResponse + handleCreateGcFsTx _ req = do + print ("Got from user: " <> show req) + let txBuilderReq :: TxBuilder.CreateGcFsTxReq + txBuilderReq = + defMessage + & fsIds .~ req ^. fsIds + & submitter .~ req ^. submitter + print ("Sending CreateGcFsTxRequest to TxBuilder: " <> show txBuilderReq) + createGcFsRespOrErr <- + call' + txBuilderClient + (RPC :: RPC TxBuilder "createGcFsTx") + txBuilderReq + either + (\err -> return $ defMessage & PublisherService.error .~ err) + ( \(createGcFsResp :: TxBuilder.CreateGcFsTxResp) -> do + print ("Got from TxBuilder: " <> show createGcFsResp) + case createGcFsResp ^. maybe'error of + Nothing -> + return $ + (defMessage :: CreateGcFsTxResponse) + & gcFsTx .~ createGcFsResp ^. success . gcFsTx + & info . txBuilderInfo .~ createGcFsResp ^. info + Just er -> + return $ + (defMessage :: CreateGcFsTxResponse) + & PublisherService.error . txBuilderErr .~ er + & info . txBuilderInfo .~ createGcFsResp ^. info + ) + createGcFsRespOrErr + + routes :: [ServiceHandler] + routes = + [ Server.unary (RPC :: RPC Publisher "createMintFsTx") handleCreateMintFsTx + , Server.unary (RPC :: RPC Publisher "createGcFsTx") handleCreateGcFsTx + ] + in runServer + routes + (fromString $ opts ^. grpcAddress, opts ^. grpcPort) + (opts ^. tlsCertFile, opts ^. tlsKeyFile) + in bracket setup cleanup $ uncurry serve + +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) @@ -198,17 +206,29 @@ call r grpc req = parseRet <$> rawUnary r grpc req rawRep ) -call' :: (GRPCOutput r b, GRPCInput r i) => HostName -> PortNumber -> r -> i -> IO (Either PublisherService.Error b) -call' addr port r req = do - ret <- runClientIO do - cli <- mkClient addr port - call r cli req +call' :: (GRPCOutput r b, GRPCInput r i) => GrpcClient -> r -> i -> IO (Either PublisherService.Error b) +call' client r req = do + ret <- runClientIO $ call r client req return $ either (\err -> Left $ defMessage & otherErr . msg .~ formatRpcError r err) (either Left Right) ret -mkClient :: HostName -> PortNumber -> ClientIO GrpcClient -mkClient host port = - setupGrpcClient ((grpcClientConfigSimple host port True) {_grpcClientConfigCompression = uncompressed}) +mkClient :: HostName -> Word16 -> IO GrpcClient +mkClient host port = do + result <- + runClientIO $ + setupGrpcClient + ( (grpcClientConfigSimple host (fromIntegral port) True) + { _grpcClientConfigCompression = uncompressed + } + ) + + either + (fail . mappend "Error while connecting to grpc server: " . show) + pure + result + +closeClient :: GrpcClient -> IO () +closeClient = void . runClientIO . close diff --git a/coop-publisher/coop-publisher.cabal b/coop-publisher/coop-publisher.cabal index 01b90ce..150a0f4 100644 --- a/coop-publisher/coop-publisher.cabal +++ b/coop-publisher/coop-publisher.cabal @@ -86,6 +86,7 @@ executable coop-publisher-cli main-is: Main.hs hs-source-dirs: app other-modules: Coop.Cli.PublisherGrpc + ghc-options: -threaded build-depends: , base , containers