{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}

{-# OPTIONS_GHC -Wno-orphans #-}

module DMQ.Configuration.Topology where

import Control.Exception (Exception (..), IOException, try)
import Data.Aeson
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as LBS
import Data.Text (Text)
import Data.Text qualified as Text
import Ouroboros.Network.Diffusion.Topology (NetworkTopology (..))
import Ouroboros.Network.OrphanInstances (localRootPeersGroupsFromJSON,
           networkTopologyFromJSON, networkTopologyToJSON)
import Ouroboros.Network.PeerSelection.LedgerPeers.Type (LedgerPeerSnapshot)

data NoExtraConfig = NoExtraConfig
  deriving Int -> NoExtraConfig -> ShowS
[NoExtraConfig] -> ShowS
NoExtraConfig -> [Char]
(Int -> NoExtraConfig -> ShowS)
-> (NoExtraConfig -> [Char])
-> ([NoExtraConfig] -> ShowS)
-> Show NoExtraConfig
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NoExtraConfig -> ShowS
showsPrec :: Int -> NoExtraConfig -> ShowS
$cshow :: NoExtraConfig -> [Char]
show :: NoExtraConfig -> [Char]
$cshowList :: [NoExtraConfig] -> ShowS
showList :: [NoExtraConfig] -> ShowS
Show
data NoExtraFlags  = NoExtraFlags
  deriving (NoExtraFlags -> NoExtraFlags -> Bool
(NoExtraFlags -> NoExtraFlags -> Bool)
-> (NoExtraFlags -> NoExtraFlags -> Bool) -> Eq NoExtraFlags
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NoExtraFlags -> NoExtraFlags -> Bool
== :: NoExtraFlags -> NoExtraFlags -> Bool
$c/= :: NoExtraFlags -> NoExtraFlags -> Bool
/= :: NoExtraFlags -> NoExtraFlags -> Bool
Eq, Int -> NoExtraFlags -> ShowS
[NoExtraFlags] -> ShowS
NoExtraFlags -> [Char]
(Int -> NoExtraFlags -> ShowS)
-> (NoExtraFlags -> [Char])
-> ([NoExtraFlags] -> ShowS)
-> Show NoExtraFlags
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NoExtraFlags -> ShowS
showsPrec :: Int -> NoExtraFlags -> ShowS
$cshow :: NoExtraFlags -> [Char]
show :: NoExtraFlags -> [Char]
$cshowList :: [NoExtraFlags] -> ShowS
showList :: [NoExtraFlags] -> ShowS
Show)

instance ToJSON NoExtraFlags where
  toJSON :: NoExtraFlags -> Value
toJSON NoExtraFlags
_ = Value
Null
  omitField :: NoExtraFlags -> Bool
omitField NoExtraFlags
_ = Bool
True

instance FromJSON (NetworkTopology NoExtraConfig NoExtraFlags) where
  parseJSON :: Value -> Parser (NetworkTopology NoExtraConfig NoExtraFlags)
parseJSON = (Value -> Parser (LocalRootPeersGroups NoExtraFlags))
-> (Object -> Parser NoExtraConfig)
-> Value
-> Parser (NetworkTopology NoExtraConfig NoExtraFlags)
forall extraFlags extraConfig.
(Value -> Parser (LocalRootPeersGroups extraFlags))
-> (Object -> Parser extraConfig)
-> Value
-> Parser (NetworkTopology extraConfig extraFlags)
networkTopologyFromJSON
                ((Object -> Parser NoExtraFlags)
-> Value -> Parser (LocalRootPeersGroups NoExtraFlags)
forall extraFlags.
(Object -> Parser extraFlags)
-> Value -> Parser (LocalRootPeersGroups extraFlags)
localRootPeersGroupsFromJSON (\Object
_ -> NoExtraFlags -> Parser NoExtraFlags
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NoExtraFlags
NoExtraFlags))
                (\Object
_ -> NoExtraConfig -> Parser NoExtraConfig
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NoExtraConfig
NoExtraConfig)

instance ToJSON (NetworkTopology NoExtraConfig NoExtraFlags) where
  toJSON :: NetworkTopology NoExtraConfig NoExtraFlags -> Value
toJSON = (NoExtraConfig -> Maybe (Key, Value))
-> (NoExtraFlags -> Maybe (Key, Value))
-> NetworkTopology NoExtraConfig NoExtraFlags
-> Value
forall extraConfig extraFlags.
(extraConfig -> Maybe (Key, Value))
-> (extraFlags -> Maybe (Key, Value))
-> NetworkTopology extraConfig extraFlags
-> Value
networkTopologyToJSON (Maybe (Key, Value) -> NoExtraConfig -> Maybe (Key, Value)
forall a b. a -> b -> a
const Maybe (Key, Value)
forall a. Maybe a
Nothing) (Maybe (Key, Value) -> NoExtraFlags -> Maybe (Key, Value)
forall a b. a -> b -> a
const Maybe (Key, Value)
forall a. Maybe a
Nothing)

-- | Read the `NetworkTopology` configuration from the specified file.
--
readTopologyFile
  :: FilePath
  -> IO (Either Text (NetworkTopology NoExtraConfig NoExtraFlags))
readTopologyFile :: [Char]
-> IO (Either Text (NetworkTopology NoExtraConfig NoExtraFlags))
readTopologyFile [Char]
nc = do
  eBs <- IO ByteString -> IO (Either IOException ByteString)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO ByteString -> IO (Either IOException ByteString))
-> IO ByteString -> IO (Either IOException ByteString)
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ByteString
BS.readFile [Char]
nc

  case eBs of
    Left IOException
e -> Either Text (NetworkTopology NoExtraConfig NoExtraFlags)
-> IO (Either Text (NetworkTopology NoExtraConfig NoExtraFlags))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text (NetworkTopology NoExtraConfig NoExtraFlags)
 -> IO (Either Text (NetworkTopology NoExtraConfig NoExtraFlags)))
-> (Text
    -> Either Text (NetworkTopology NoExtraConfig NoExtraFlags))
-> Text
-> IO (Either Text (NetworkTopology NoExtraConfig NoExtraFlags))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text (NetworkTopology NoExtraConfig NoExtraFlags)
forall a b. a -> Either a b
Left (Text
 -> IO (Either Text (NetworkTopology NoExtraConfig NoExtraFlags)))
-> Text
-> IO (Either Text (NetworkTopology NoExtraConfig NoExtraFlags))
forall a b. (a -> b) -> a -> b
$ IOException -> Text
handler IOException
e
    Right ByteString
bs ->
      let bs' :: LazyByteString
bs' = ByteString -> LazyByteString
LBS.fromStrict ByteString
bs in
        case LazyByteString
-> Either [Char] (NetworkTopology NoExtraConfig NoExtraFlags)
forall a. FromJSON a => LazyByteString -> Either [Char] a
eitherDecode LazyByteString
bs' of
          Left [Char]
err -> Either Text (NetworkTopology NoExtraConfig NoExtraFlags)
-> IO (Either Text (NetworkTopology NoExtraConfig NoExtraFlags))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text (NetworkTopology NoExtraConfig NoExtraFlags)
 -> IO (Either Text (NetworkTopology NoExtraConfig NoExtraFlags)))
-> Either Text (NetworkTopology NoExtraConfig NoExtraFlags)
-> IO (Either Text (NetworkTopology NoExtraConfig NoExtraFlags))
forall a b. (a -> b) -> a -> b
$ Text -> Either Text (NetworkTopology NoExtraConfig NoExtraFlags)
forall a b. a -> Either a b
Left ([Char] -> Text
handlerJSON [Char]
err)
          Right NetworkTopology NoExtraConfig NoExtraFlags
t  -> Either Text (NetworkTopology NoExtraConfig NoExtraFlags)
-> IO (Either Text (NetworkTopology NoExtraConfig NoExtraFlags))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text (NetworkTopology NoExtraConfig NoExtraFlags)
 -> IO (Either Text (NetworkTopology NoExtraConfig NoExtraFlags)))
-> Either Text (NetworkTopology NoExtraConfig NoExtraFlags)
-> IO (Either Text (NetworkTopology NoExtraConfig NoExtraFlags))
forall a b. (a -> b) -> a -> b
$ NetworkTopology NoExtraConfig NoExtraFlags
-> Either Text (NetworkTopology NoExtraConfig NoExtraFlags)
forall a b. b -> Either a b
Right NetworkTopology NoExtraConfig NoExtraFlags
t
  where
    handler :: IOException -> Text
    handler :: IOException -> Text
handler IOException
e = [Char] -> Text
Text.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [Char]
"DMQ.Topology.readTopologyFile: "
                          [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ IOException -> [Char]
forall e. Exception e => e -> [Char]
displayException IOException
e
    handlerJSON :: String -> Text
    handlerJSON :: [Char] -> Text
handlerJSON [Char]
err = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
      [ Text
"Is your topology file formatted correctly? "
      , Text
"Expecting P2P Topology file format. "
      , Text
"The port and valency fields should be numerical. "
      , [Char] -> Text
Text.pack [Char]
err
      ]

readTopologyFileOrError
  :: FilePath
  -> IO (NetworkTopology NoExtraConfig NoExtraFlags)
readTopologyFileOrError :: [Char] -> IO (NetworkTopology NoExtraConfig NoExtraFlags)
readTopologyFileOrError [Char]
nc =
      [Char]
-> IO (Either Text (NetworkTopology NoExtraConfig NoExtraFlags))
readTopologyFile [Char]
nc
  IO (Either Text (NetworkTopology NoExtraConfig NoExtraFlags))
-> (Either Text (NetworkTopology NoExtraConfig NoExtraFlags)
    -> IO (NetworkTopology NoExtraConfig NoExtraFlags))
-> IO (NetworkTopology NoExtraConfig NoExtraFlags)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Text -> IO (NetworkTopology NoExtraConfig NoExtraFlags))
-> (NetworkTopology NoExtraConfig NoExtraFlags
    -> IO (NetworkTopology NoExtraConfig NoExtraFlags))
-> Either Text (NetworkTopology NoExtraConfig NoExtraFlags)
-> IO (NetworkTopology NoExtraConfig NoExtraFlags)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\Text
err -> [Char] -> IO (NetworkTopology NoExtraConfig NoExtraFlags)
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO (NetworkTopology NoExtraConfig NoExtraFlags))
-> [Char] -> IO (NetworkTopology NoExtraConfig NoExtraFlags)
forall a b. (a -> b) -> a -> b
$ [Char]
"DMQ.Topology.readTopologyFile: "
                           [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
Text.unpack Text
err)
             NetworkTopology NoExtraConfig NoExtraFlags
-> IO (NetworkTopology NoExtraConfig NoExtraFlags)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

readPeerSnapshotFile :: FilePath -> IO (Either Text LedgerPeerSnapshot)
readPeerSnapshotFile :: [Char] -> IO (Either Text LedgerPeerSnapshot)
readPeerSnapshotFile [Char]
psf = do
  eBs <- IO ByteString -> IO (Either IOException ByteString)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO ByteString -> IO (Either IOException ByteString))
-> IO ByteString -> IO (Either IOException ByteString)
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ByteString
BS.readFile [Char]
psf
  case eBs of
    Left IOException
e -> Either Text LedgerPeerSnapshot
-> IO (Either Text LedgerPeerSnapshot)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text LedgerPeerSnapshot
 -> IO (Either Text LedgerPeerSnapshot))
-> (Text -> Either Text LedgerPeerSnapshot)
-> Text
-> IO (Either Text LedgerPeerSnapshot)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text LedgerPeerSnapshot
forall a b. a -> Either a b
Left (Text -> IO (Either Text LedgerPeerSnapshot))
-> Text -> IO (Either Text LedgerPeerSnapshot)
forall a b. (a -> b) -> a -> b
$ IOException -> Text
handler IOException
e
    Right ByteString
bs ->
      let bs' :: LazyByteString
bs' = ByteString -> LazyByteString
LBS.fromStrict ByteString
bs in
        case LazyByteString -> Either [Char] LedgerPeerSnapshot
forall a. FromJSON a => LazyByteString -> Either [Char] a
eitherDecode LazyByteString
bs' of
          Left [Char]
err -> Either Text LedgerPeerSnapshot
-> IO (Either Text LedgerPeerSnapshot)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text LedgerPeerSnapshot
 -> IO (Either Text LedgerPeerSnapshot))
-> Either Text LedgerPeerSnapshot
-> IO (Either Text LedgerPeerSnapshot)
forall a b. (a -> b) -> a -> b
$ Text -> Either Text LedgerPeerSnapshot
forall a b. a -> Either a b
Left ([Char] -> Text
handlerJSON [Char]
err)
          Right LedgerPeerSnapshot
t  -> Either Text LedgerPeerSnapshot
-> IO (Either Text LedgerPeerSnapshot)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text LedgerPeerSnapshot
 -> IO (Either Text LedgerPeerSnapshot))
-> Either Text LedgerPeerSnapshot
-> IO (Either Text LedgerPeerSnapshot)
forall a b. (a -> b) -> a -> b
$ LedgerPeerSnapshot -> Either Text LedgerPeerSnapshot
forall a b. b -> Either a b
Right LedgerPeerSnapshot
t
  where
    handler :: IOException -> Text
    handler :: IOException -> Text
handler IOException
e = [Char] -> Text
Text.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [Char]
"DMQ.Topology.readLedgerPeerSnapshotFile: "
                          [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ IOException -> [Char]
forall e. Exception e => e -> [Char]
displayException IOException
e
    handlerJSON :: String -> Text
    handlerJSON :: [Char] -> Text
handlerJSON [Char]
err = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
      [ Text
"Is your snapshot file formatted correctly? "
      , [Char] -> Text
Text.pack [Char]
err
      ]

readPeerSnapshotFileOrError :: FilePath -> IO LedgerPeerSnapshot
readPeerSnapshotFileOrError :: [Char] -> IO LedgerPeerSnapshot
readPeerSnapshotFileOrError [Char]
psf =
      [Char] -> IO (Either Text LedgerPeerSnapshot)
readPeerSnapshotFile [Char]
psf
  IO (Either Text LedgerPeerSnapshot)
-> (Either Text LedgerPeerSnapshot -> IO LedgerPeerSnapshot)
-> IO LedgerPeerSnapshot
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Text -> IO LedgerPeerSnapshot)
-> (LedgerPeerSnapshot -> IO LedgerPeerSnapshot)
-> Either Text LedgerPeerSnapshot
-> IO LedgerPeerSnapshot
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\Text
err -> [Char] -> IO LedgerPeerSnapshot
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO LedgerPeerSnapshot)
-> [Char] -> IO LedgerPeerSnapshot
forall a b. (a -> b) -> a -> b
$ [Char]
"DMQ.Topology.readLedgerPeerSnapshotFile: "
                           [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
Text.unpack Text
err)
             LedgerPeerSnapshot -> IO LedgerPeerSnapshot
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure