{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}

{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Node.Orphans () where

import           Cardano.Prelude
import           Prelude (fail)

import           Cardano.Api.Orphans ()

import           Data.Aeson.Types
import qualified Data.Text as Text

import           Cardano.BM.Data.Tracer (TracingVerbosity (..))
import qualified Cardano.Chain.Update as Update
import           Cardano.Ledger.Crypto (StandardCrypto)
import qualified Cardano.Ledger.CompactAddress as Ledger
import           Ouroboros.Network.NodeToNode (AcceptedConnectionsLimit (..))

instance FromJSON TracingVerbosity where
  parseJSON :: Value -> Parser TracingVerbosity
parseJSON (String Text
str) = case Text
str of
    Text
"MinimalVerbosity" -> TracingVerbosity -> Parser TracingVerbosity
forall (f :: * -> *) a. Applicative f => a -> f a
pure TracingVerbosity
MinimalVerbosity
    Text
"MaximalVerbosity" -> TracingVerbosity -> Parser TracingVerbosity
forall (f :: * -> *) a. Applicative f => a -> f a
pure TracingVerbosity
MaximalVerbosity
    Text
"NormalVerbosity" -> TracingVerbosity -> Parser TracingVerbosity
forall (f :: * -> *) a. Applicative f => a -> f a
pure TracingVerbosity
NormalVerbosity
    Text
err -> String -> Parser TracingVerbosity
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser TracingVerbosity)
-> String -> Parser TracingVerbosity
forall a b. (a -> b) -> a -> b
$ String
"Parsing of TracingVerbosity failed, "
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack Text
err String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" is not a valid TracingVerbosity"
  parseJSON Value
invalid  = String -> Parser TracingVerbosity
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser TracingVerbosity)
-> String -> Parser TracingVerbosity
forall a b. (a -> b) -> a -> b
$ String
"Parsing of TracingVerbosity failed due to type mismatch. "
                           String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"Encountered: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall a b. (Show a, ConvertText String b) => a -> b
show Value
invalid

deriving instance Show TracingVerbosity

instance ToJSON (Ledger.CompactAddr StandardCrypto) where
  toJSON :: CompactAddr StandardCrypto -> Value
toJSON = Addr StandardCrypto -> Value
forall a. ToJSON a => a -> Value
toJSON (Addr StandardCrypto -> Value)
-> (CompactAddr StandardCrypto -> Addr StandardCrypto)
-> CompactAddr StandardCrypto
-> Value
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. CompactAddr StandardCrypto -> Addr StandardCrypto
forall crypto. Crypto crypto => CompactAddr crypto -> Addr crypto
Ledger.decompactAddr

--Not currently needed, but if we do need it, this is the general instance.
--instance (ToJSON a, Ledger.Compactible a) => ToJSON (Ledger.CompactForm a) where
--  toJSON = toJSON  . Ledger.fromCompact

instance FromJSON Update.ApplicationName where
  parseJSON :: Value -> Parser ApplicationName
parseJSON (String Text
x) = ApplicationName -> Parser ApplicationName
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ApplicationName -> Parser ApplicationName)
-> ApplicationName -> Parser ApplicationName
forall a b. (a -> b) -> a -> b
$ Text -> ApplicationName
Update.ApplicationName Text
x
  parseJSON Value
invalid  =
    String -> Parser ApplicationName
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser ApplicationName)
-> String -> Parser ApplicationName
forall a b. (a -> b) -> a -> b
$ String
"Parsing of application name failed due to type mismatch. "
    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"Encountered: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall a b. (Show a, ConvertText String b) => a -> b
show Value
invalid

instance ToJSON AcceptedConnectionsLimit where
  toJSON :: AcceptedConnectionsLimit -> Value
toJSON AcceptedConnectionsLimit
          { Word32
acceptedConnectionsHardLimit :: AcceptedConnectionsLimit -> Word32
acceptedConnectionsHardLimit :: Word32
acceptedConnectionsHardLimit
          , Word32
acceptedConnectionsSoftLimit :: AcceptedConnectionsLimit -> Word32
acceptedConnectionsSoftLimit :: Word32
acceptedConnectionsSoftLimit
          , DiffTime
acceptedConnectionsDelay :: AcceptedConnectionsLimit -> DiffTime
acceptedConnectionsDelay :: DiffTime
acceptedConnectionsDelay
          } =
    [Pair] -> Value
object [ Key
"AcceptedConnectionsLimit" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.=
      [Pair] -> Value
object [ Key
"hardLimit" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.=
                  Word32 -> Value
forall a. ToJSON a => a -> Value
toJSON Word32
acceptedConnectionsHardLimit
             , Key
"softLimit" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.=
                  Word32 -> Value
forall a. ToJSON a => a -> Value
toJSON Word32
acceptedConnectionsSoftLimit
             , Key
"delay" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.=
                  DiffTime -> Value
forall a. ToJSON a => a -> Value
toJSON DiffTime
acceptedConnectionsDelay
             ]
           ]

instance FromJSON AcceptedConnectionsLimit where
  parseJSON :: Value -> Parser AcceptedConnectionsLimit
parseJSON = String
-> (Object -> Parser AcceptedConnectionsLimit)
-> Value
-> Parser AcceptedConnectionsLimit
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"AcceptedConnectionsLimit" ((Object -> Parser AcceptedConnectionsLimit)
 -> Value -> Parser AcceptedConnectionsLimit)
-> (Object -> Parser AcceptedConnectionsLimit)
-> Value
-> Parser AcceptedConnectionsLimit
forall a b. (a -> b) -> a -> b
$ \Object
v ->
    Word32 -> Word32 -> DiffTime -> AcceptedConnectionsLimit
AcceptedConnectionsLimit
      (Word32 -> Word32 -> DiffTime -> AcceptedConnectionsLimit)
-> Parser Word32
-> Parser (Word32 -> DiffTime -> AcceptedConnectionsLimit)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser Word32
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"hardLimit"
      Parser (Word32 -> DiffTime -> AcceptedConnectionsLimit)
-> Parser Word32 -> Parser (DiffTime -> AcceptedConnectionsLimit)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser Word32
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"softLimit"
      Parser (DiffTime -> AcceptedConnectionsLimit)
-> Parser DiffTime -> Parser AcceptedConnectionsLimit
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser DiffTime
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"delay"