-- | Mithril client to bootstrap cardano nodes in the hydra-cluster.
module Hydra.Cluster.Mithril where

import Hydra.Prelude

import Control.Tracer (Tracer, traceWith)
import Data.Aeson (Value)
import Data.Aeson qualified as Aeson
import Data.ByteString qualified as BS
import Hydra.Cluster.Fixture (KnownNetwork (..))
import Network.HTTP.Simple (getResponseBody, httpBS, parseRequest)
import System.IO.Error (isEOFError)
import System.Process.Typed (createPipe, getStderr, proc, setStderr, withProcessWait_)

data MithrilLog
  = StartSnapshotDownload {MithrilLog -> KnownNetwork
network :: KnownNetwork, MithrilLog -> String
directory :: FilePath}
  | -- | Output captured directly from mithril-client stderr.
    StdErr {MithrilLog -> Value
output :: Value}
  deriving stock (MithrilLog -> MithrilLog -> Bool
(MithrilLog -> MithrilLog -> Bool)
-> (MithrilLog -> MithrilLog -> Bool) -> Eq MithrilLog
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MithrilLog -> MithrilLog -> Bool
== :: MithrilLog -> MithrilLog -> Bool
$c/= :: MithrilLog -> MithrilLog -> Bool
/= :: MithrilLog -> MithrilLog -> Bool
Eq, Int -> MithrilLog -> ShowS
[MithrilLog] -> ShowS
MithrilLog -> String
(Int -> MithrilLog -> ShowS)
-> (MithrilLog -> String)
-> ([MithrilLog] -> ShowS)
-> Show MithrilLog
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MithrilLog -> ShowS
showsPrec :: Int -> MithrilLog -> ShowS
$cshow :: MithrilLog -> String
show :: MithrilLog -> String
$cshowList :: [MithrilLog] -> ShowS
showList :: [MithrilLog] -> ShowS
Show, (forall x. MithrilLog -> Rep MithrilLog x)
-> (forall x. Rep MithrilLog x -> MithrilLog) -> Generic MithrilLog
forall x. Rep MithrilLog x -> MithrilLog
forall x. MithrilLog -> Rep MithrilLog x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. MithrilLog -> Rep MithrilLog x
from :: forall x. MithrilLog -> Rep MithrilLog x
$cto :: forall x. Rep MithrilLog x -> MithrilLog
to :: forall x. Rep MithrilLog x -> MithrilLog
Generic)
  deriving anyclass ([MithrilLog] -> Value
[MithrilLog] -> Encoding
MithrilLog -> Bool
MithrilLog -> Value
MithrilLog -> Encoding
(MithrilLog -> Value)
-> (MithrilLog -> Encoding)
-> ([MithrilLog] -> Value)
-> ([MithrilLog] -> Encoding)
-> (MithrilLog -> Bool)
-> ToJSON MithrilLog
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: MithrilLog -> Value
toJSON :: MithrilLog -> Value
$ctoEncoding :: MithrilLog -> Encoding
toEncoding :: MithrilLog -> Encoding
$ctoJSONList :: [MithrilLog] -> Value
toJSONList :: [MithrilLog] -> Value
$ctoEncodingList :: [MithrilLog] -> Encoding
toEncodingList :: [MithrilLog] -> Encoding
$comitField :: MithrilLog -> Bool
omitField :: MithrilLog -> Bool
ToJSON, Maybe MithrilLog
Value -> Parser [MithrilLog]
Value -> Parser MithrilLog
(Value -> Parser MithrilLog)
-> (Value -> Parser [MithrilLog])
-> Maybe MithrilLog
-> FromJSON MithrilLog
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser MithrilLog
parseJSON :: Value -> Parser MithrilLog
$cparseJSONList :: Value -> Parser [MithrilLog]
parseJSONList :: Value -> Parser [MithrilLog]
$comittedField :: Maybe MithrilLog
omittedField :: Maybe MithrilLog
FromJSON)

-- | Downloads and unpacks latest snapshot for given network in db/ of given
-- directory.
downloadLatestSnapshotTo :: Tracer IO MithrilLog -> KnownNetwork -> FilePath -> IO ()
downloadLatestSnapshotTo :: Tracer IO MithrilLog -> KnownNetwork -> String -> IO ()
downloadLatestSnapshotTo Tracer IO MithrilLog
tracer KnownNetwork
network String
directory = do
  Tracer IO MithrilLog -> MithrilLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO MithrilLog
tracer StartSnapshotDownload{KnownNetwork
network :: KnownNetwork
network :: KnownNetwork
network, String
directory :: String
directory :: String
directory}
  ByteString
genesisKey <- String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest String
genesisKeyURL IO Request
-> (Request -> IO (Response ByteString))
-> IO (Response ByteString)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Request -> IO (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
Request -> m (Response ByteString)
httpBS IO (Response ByteString)
-> (Response ByteString -> ByteString) -> IO ByteString
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Response ByteString -> ByteString
forall a. Response a -> a
getResponseBody
  let cmd :: ProcessConfig () () Handle
cmd =
        StreamSpec 'STOutput Handle
-> ProcessConfig () () () -> ProcessConfig () () Handle
forall stderr stdin stdout stderr0.
StreamSpec 'STOutput stderr
-> ProcessConfig stdin stdout stderr0
-> ProcessConfig stdin stdout stderr
setStderr StreamSpec 'STOutput Handle
forall (anyStreamType :: StreamType).
StreamSpec anyStreamType Handle
createPipe (ProcessConfig () () () -> ProcessConfig () () Handle)
-> ProcessConfig () () () -> ProcessConfig () () Handle
forall a b. (a -> b) -> a -> b
$
          String -> [String] -> ProcessConfig () () ()
proc String
"mithril-client" ([String] -> ProcessConfig () () ())
-> [String] -> ProcessConfig () () ()
forall a b. (a -> b) -> a -> b
$
            [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
              [ [String
"--aggregator-endpoint", String
aggregatorEndpoint]
              , [String
"cardano-db", String
"download", String
"latest"]
              , [String
"--genesis-verification-key", ByteString -> String
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 ByteString
genesisKey]
              , [String
"--download-dir", String
directory]
              , [String
"--json"]
              ]
  ProcessConfig () () Handle
-> (Process () () Handle -> IO ()) -> IO ()
forall (m :: * -> *) stdin stdout stderr a.
MonadUnliftIO m =>
ProcessConfig stdin stdout stderr
-> (Process stdin stdout stderr -> m a) -> m a
withProcessWait_ ProcessConfig () () Handle
cmd Process () () Handle -> IO ()
traceStderr
 where
  traceStderr :: Process () () Handle -> IO ()
traceStderr Process () () Handle
p =
    IO () -> IO ()
ignoreEOFErrors (IO () -> IO ()) -> (IO () -> IO ()) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      ByteString
bytes <- Handle -> IO ByteString
BS.hGetLine (Process () () Handle -> Handle
forall stdin stdout stderr. Process stdin stdout stderr -> stderr
getStderr Process () () Handle
p)
      case ByteString -> Either String Value
forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecodeStrict ByteString
bytes of
        Left String
err -> Text -> IO ()
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"failed to decode: \n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
forall b a. (Show a, IsString b) => a -> b
show ByteString
bytes Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\nerror: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall b a. (Show a, IsString b) => a -> b
show String
err
        Right Value
output -> Tracer IO MithrilLog -> MithrilLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO MithrilLog
tracer StdErr{Value
output :: Value
output :: Value
output}

  ignoreEOFErrors :: IO () -> IO ()
ignoreEOFErrors =
    (IOError -> Maybe ()) -> (() -> IO ()) -> IO () -> IO ()
forall e b a.
Exception e =>
(e -> Maybe b) -> (b -> IO a) -> IO a -> IO a
forall (m :: * -> *) e b a.
(MonadCatch m, Exception e) =>
(e -> Maybe b) -> (b -> m a) -> m a -> m a
handleJust (Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> (IOError -> Bool) -> IOError -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> Bool
isEOFError) (IO () -> () -> IO ()
forall a b. a -> b -> a
const (IO () -> () -> IO ()) -> IO () -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

  genesisKeyURL :: String
genesisKeyURL = case KnownNetwork
network of
    KnownNetwork
Mainnet -> String
"https://raw.githubusercontent.com/input-output-hk/mithril/main/mithril-infra/configuration/release-mainnet/genesis.vkey"
    KnownNetwork
Preproduction -> String
"https://raw.githubusercontent.com/input-output-hk/mithril/main/mithril-infra/configuration/release-preprod/genesis.vkey"
    KnownNetwork
Preview -> String
"https://raw.githubusercontent.com/input-output-hk/mithril/main/mithril-infra/configuration/pre-release-preview/genesis.vkey"
    KnownNetwork
Sanchonet -> String
"https://raw.githubusercontent.com/input-output-hk/mithril/main/mithril-infra/configuration/testing-sanchonet/genesis.vkey"

  aggregatorEndpoint :: String
aggregatorEndpoint = case KnownNetwork
network of
    KnownNetwork
Mainnet -> String
"https://aggregator.release-mainnet.api.mithril.network/aggregator"
    KnownNetwork
Preproduction -> String
"https://aggregator.release-preprod.api.mithril.network/aggregator"
    KnownNetwork
Preview -> String
"https://aggregator.pre-release-preview.api.mithril.network/aggregator"
    KnownNetwork
Sanchonet -> String
"https://aggregator.testing-sanchonet.api.mithril.network/aggregator"