Add healthcheck to marlowe-tx

input-output-hk · Mar 16, 2023 · 49c9028 · 49c9028
1 parent 6b8a8e6
commit 49c9028
Show file tree

Hide file tree

Showing 3 changed files with 35 additions and 5 deletions.
diff --git a/marlowe-runtime/marlowe-tx/Main.hs b/marlowe-runtime/marlowe-tx/Main.hs
@@ -90,6 +90,7 @@ run = runComponent_ proc Options{..} -> do
     , loadWalletContext = Query.loadWalletContext $ queryChainSync . GetUTxOs
     , eventBackend = narrowEventBackend (injectSelector App) eventBackend
     , getCurrentScripts = ScriptRegistry.getCurrentScripts
+    , httpPort = fromIntegral httpPort
     , ..
     }
 
@@ -102,6 +103,7 @@ data Options = Options
   , host :: HostName
   , logConfigFile :: Maybe FilePath
   , submitConfirmationBlocks :: BlockNo
+  , httpPort :: PortNumber
   }
 
 getOptions :: IO Options
@@ -116,6 +118,7 @@ getOptions = execParser $ info (helper <*> parser) infoMod
       <*> hostParser
       <*> logConfigFileParser
       <*> submitConfirmationBlocksParser
+      <*> httpPortParser
 
     chainSeekPortParser = option auto $ mconcat
       [ long "chain-sync-port"
@@ -172,6 +175,14 @@ getOptions = execParser $ info (helper <*> parser) infoMod
       , help "The logging configuration JSON file."
       ]
 
+    httpPortParser = option auto $ mconcat
+      [ long "http-port"
+      , metavar "PORT_NUMBER"
+      , help "Port number to serve the http healthcheck API on"
+      , value 8080
+      , showDefault
+      ]
+
     submitConfirmationBlocksParser = option (BlockNo <$> auto) $ mconcat
       [ long "submit-confirmation-blocks"
       , value 0

diff --git a/marlowe-runtime/tx/Language/Marlowe/Runtime/Transaction.hs b/marlowe-runtime/tx/Language/Marlowe/Runtime/Transaction.hs
@@ -9,7 +9,8 @@ import Cardano.Api (Tx)
 import qualified Cardano.Api as C
 import Cardano.Api.Byron (BabbageEra)
 import Control.Concurrent.Component
-import Control.Concurrent.STM (STM)
+import Control.Concurrent.Component.Probes
+import Control.Concurrent.STM (STM, atomically)
 import Data.Text (Text)
 import Data.Void
 import Language.Marlowe.Runtime.ChainSync.Api (ChainSyncQuery, RuntimeChainSeekClient)
@@ -43,12 +44,21 @@ data TransactionDependencies r = TransactionDependencies
   , queryChainSync :: forall e a. ChainSyncQuery Void e a -> IO a
   , eventBackend :: EventBackend IO r TransactionServerSelector
   , getCurrentScripts :: forall v. MarloweVersion v -> MarloweScripts
+  , httpPort :: Int
   }
 
 transaction :: Component IO (TransactionDependencies r) ()
 transaction = proc TransactionDependencies{..} -> do
-  getTip <- transactionChainClient -< TransactionChainClientDependencies{..}
+  (connected, getTip) <- transactionChainClient -< TransactionChainClientDependencies{..}
   transactionServer -< TransactionServerDependencies{..}
+  probeServer -< ProbeServerDependencies
+    { probes = Probes
+        { startup = pure True
+        , liveness = atomically connected
+        , readiness = atomically connected
+        }
+    , port = httpPort
+    }
 
 getTransactionSererSelectorConfig :: GetSelectorConfig TransactionServerSelector
 getTransactionSererSelectorConfig = \case

diff --git a/marlowe-runtime/tx/Language/Marlowe/Runtime/Transaction/Chain.hs b/marlowe-runtime/tx/Language/Marlowe/Runtime/Transaction/Chain.hs
@@ -6,6 +6,7 @@ module Language.Marlowe.Runtime.Transaction.Chain
 import Control.Concurrent (threadDelay)
 import Control.Concurrent.Component
 import Control.Concurrent.STM (STM, atomically, newTVar, readTVar, writeTVar)
+import Control.Exception (finally)
 import Data.Functor (($>))
 import Data.Void (absurd)
 import Language.Marlowe.Runtime.ChainSync.Api (Move(..), RuntimeChainSeekClient)
@@ -18,12 +19,20 @@ newtype TransactionChainClientDependencies = TransactionChainClientDependencies
   { chainSyncConnector :: SomeClientConnector RuntimeChainSeekClient IO
   }
 
-transactionChainClient :: Component IO TransactionChainClientDependencies (STM Chain.ChainPoint)
+transactionChainClient :: Component IO TransactionChainClientDependencies (STM Bool, STM Chain.ChainPoint)
 transactionChainClient = component \TransactionChainClientDependencies{..} -> do
   tipVar <- newTVar Chain.Genesis
-  pure (runSomeConnector chainSyncConnector $ client tipVar, readTVar tipVar)
+  connectedVar <- newTVar False
+  pure
+    ( flip finally (atomically $ writeTVar connectedVar False)
+        $ runSomeConnector chainSyncConnector
+        $ client connectedVar tipVar
+    , (readTVar connectedVar, readTVar tipVar)
+    )
   where
-  client tipVar = ChainSeekClient $ pure clientIdle
+  client connectedVar tipVar = ChainSeekClient do
+    atomically $ writeTVar connectedVar True
+    pure clientIdle
     where
     clientIdle = SendMsgQueryNext AdvanceToTip clientNext
     clientNext = ClientStNext