{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}

-- | Unversioned protocol, used in tests and demo applications.
--
module Ouroboros.Network.Protocol.Handshake.Unversioned
  ( UnversionedProtocol (..)
  , UnversionedProtocolData (..)
  , unversionedHandshakeCodec
  , unversionedProtocolDataCodec
  , unversionedProtocol
  , DataFlowProtocolData (..)
  , dataFlowProtocolDataCodec
  , dataFlowProtocol
  ) where

import Control.Monad.Class.MonadST

import Codec.CBOR.Read qualified as CBOR
import Codec.CBOR.Term qualified as CBOR

import Data.ByteString.Lazy (ByteString)
import Data.Text (Text)
import Data.Text qualified as T

import Network.TypedProtocol.Codec

import Ouroboros.Network.CodecCBORTerm
import Ouroboros.Network.ConnectionManager.Types (DataFlow (..))
import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..))
import Ouroboros.Network.Protocol.Handshake.Codec
import Ouroboros.Network.Protocol.Handshake.Type
import Ouroboros.Network.Protocol.Handshake.Version


-- | Version negotiation for an unversioned protocol. We only use this for
-- tests and demos where proper versioning is excessive.
--
data UnversionedProtocol = UnversionedProtocol
  deriving (UnversionedProtocol -> UnversionedProtocol -> Bool
(UnversionedProtocol -> UnversionedProtocol -> Bool)
-> (UnversionedProtocol -> UnversionedProtocol -> Bool)
-> Eq UnversionedProtocol
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UnversionedProtocol -> UnversionedProtocol -> Bool
== :: UnversionedProtocol -> UnversionedProtocol -> Bool
$c/= :: UnversionedProtocol -> UnversionedProtocol -> Bool
/= :: UnversionedProtocol -> UnversionedProtocol -> Bool
Eq, Eq UnversionedProtocol
Eq UnversionedProtocol =>
(UnversionedProtocol -> UnversionedProtocol -> Ordering)
-> (UnversionedProtocol -> UnversionedProtocol -> Bool)
-> (UnversionedProtocol -> UnversionedProtocol -> Bool)
-> (UnversionedProtocol -> UnversionedProtocol -> Bool)
-> (UnversionedProtocol -> UnversionedProtocol -> Bool)
-> (UnversionedProtocol
    -> UnversionedProtocol -> UnversionedProtocol)
-> (UnversionedProtocol
    -> UnversionedProtocol -> UnversionedProtocol)
-> Ord UnversionedProtocol
UnversionedProtocol -> UnversionedProtocol -> Bool
UnversionedProtocol -> UnversionedProtocol -> Ordering
UnversionedProtocol -> UnversionedProtocol -> UnversionedProtocol
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: UnversionedProtocol -> UnversionedProtocol -> Ordering
compare :: UnversionedProtocol -> UnversionedProtocol -> Ordering
$c< :: UnversionedProtocol -> UnversionedProtocol -> Bool
< :: UnversionedProtocol -> UnversionedProtocol -> Bool
$c<= :: UnversionedProtocol -> UnversionedProtocol -> Bool
<= :: UnversionedProtocol -> UnversionedProtocol -> Bool
$c> :: UnversionedProtocol -> UnversionedProtocol -> Bool
> :: UnversionedProtocol -> UnversionedProtocol -> Bool
$c>= :: UnversionedProtocol -> UnversionedProtocol -> Bool
>= :: UnversionedProtocol -> UnversionedProtocol -> Bool
$cmax :: UnversionedProtocol -> UnversionedProtocol -> UnversionedProtocol
max :: UnversionedProtocol -> UnversionedProtocol -> UnversionedProtocol
$cmin :: UnversionedProtocol -> UnversionedProtocol -> UnversionedProtocol
min :: UnversionedProtocol -> UnversionedProtocol -> UnversionedProtocol
Ord, Int -> UnversionedProtocol -> ShowS
[UnversionedProtocol] -> ShowS
UnversionedProtocol -> [Char]
(Int -> UnversionedProtocol -> ShowS)
-> (UnversionedProtocol -> [Char])
-> ([UnversionedProtocol] -> ShowS)
-> Show UnversionedProtocol
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UnversionedProtocol -> ShowS
showsPrec :: Int -> UnversionedProtocol -> ShowS
$cshow :: UnversionedProtocol -> [Char]
show :: UnversionedProtocol -> [Char]
$cshowList :: [UnversionedProtocol] -> ShowS
showList :: [UnversionedProtocol] -> ShowS
Show)


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

instance Acceptable UnversionedProtocolData where
  acceptableVersion :: UnversionedProtocolData
-> UnversionedProtocolData -> Accept UnversionedProtocolData
acceptableVersion UnversionedProtocolData
UnversionedProtocolData
                    UnversionedProtocolData
UnversionedProtocolData = UnversionedProtocolData -> Accept UnversionedProtocolData
forall vData. vData -> Accept vData
Accept UnversionedProtocolData
UnversionedProtocolData

instance Queryable UnversionedProtocolData where
  queryVersion :: UnversionedProtocolData -> Bool
queryVersion UnversionedProtocolData
UnversionedProtocolData = Bool
False


unversionedProtocolDataCodec :: VersionDataCodec CBOR.Term UnversionedProtocol
                                                           UnversionedProtocolData
unversionedProtocolDataCodec :: VersionDataCodec Term UnversionedProtocol UnversionedProtocolData
unversionedProtocolDataCodec = (UnversionedProtocol -> CodecCBORTerm Text UnversionedProtocolData)
-> VersionDataCodec
     Term UnversionedProtocol UnversionedProtocolData
forall vNumber vData.
(vNumber -> CodecCBORTerm Text vData)
-> VersionDataCodec Term vNumber vData
cborTermVersionDataCodec
                                 (CodecCBORTerm Text UnversionedProtocolData
-> UnversionedProtocol
-> CodecCBORTerm Text UnversionedProtocolData
forall a b. a -> b -> a
const CodecCBORTerm {UnversionedProtocolData -> Term
encodeTerm :: UnversionedProtocolData -> Term
encodeTerm :: UnversionedProtocolData -> Term
encodeTerm, Term -> Either Text UnversionedProtocolData
decodeTerm :: Term -> Either Text UnversionedProtocolData
decodeTerm :: Term -> Either Text UnversionedProtocolData
decodeTerm})
    where
      encodeTerm :: UnversionedProtocolData -> CBOR.Term
      encodeTerm :: UnversionedProtocolData -> Term
encodeTerm UnversionedProtocolData
UnversionedProtocolData = Term
CBOR.TNull

      decodeTerm :: CBOR.Term -> Either Text UnversionedProtocolData
      decodeTerm :: Term -> Either Text UnversionedProtocolData
decodeTerm Term
CBOR.TNull = UnversionedProtocolData -> Either Text UnversionedProtocolData
forall a b. b -> Either a b
Right UnversionedProtocolData
UnversionedProtocolData
      decodeTerm Term
t          = Text -> Either Text UnversionedProtocolData
forall a b. a -> Either a b
Left (Text -> Either Text UnversionedProtocolData)
-> Text -> Either Text UnversionedProtocolData
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [Char]
"unexpected term: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Term -> [Char]
forall a. Show a => a -> [Char]
show Term
t

-- | Make a 'Versions' for an unversioned protocol. Only use this for
-- tests and demos where proper versioning is excessive.
--
unversionedProtocol :: app
                    -> Versions UnversionedProtocol
                                UnversionedProtocolData
                                app
unversionedProtocol :: forall app.
app -> Versions UnversionedProtocol UnversionedProtocolData app
unversionedProtocol = UnversionedProtocol
-> UnversionedProtocolData
-> app
-> Versions UnversionedProtocol UnversionedProtocolData app
forall vNum vData r. vNum -> vData -> r -> Versions vNum vData r
simpleSingletonVersions UnversionedProtocol
UnversionedProtocol UnversionedProtocolData
UnversionedProtocolData


-- | Alternative for 'UnversionedProtocolData' which contains 'DataFlow'.
--
data DataFlowProtocolData =
    DataFlowProtocolData {
      DataFlowProtocolData -> DataFlow
getProtocolDataFlow    :: DataFlow,
      DataFlowProtocolData -> PeerSharing
getProtocolPeerSharing :: PeerSharing
    }
  deriving (DataFlowProtocolData -> DataFlowProtocolData -> Bool
(DataFlowProtocolData -> DataFlowProtocolData -> Bool)
-> (DataFlowProtocolData -> DataFlowProtocolData -> Bool)
-> Eq DataFlowProtocolData
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DataFlowProtocolData -> DataFlowProtocolData -> Bool
== :: DataFlowProtocolData -> DataFlowProtocolData -> Bool
$c/= :: DataFlowProtocolData -> DataFlowProtocolData -> Bool
/= :: DataFlowProtocolData -> DataFlowProtocolData -> Bool
Eq, Int -> DataFlowProtocolData -> ShowS
[DataFlowProtocolData] -> ShowS
DataFlowProtocolData -> [Char]
(Int -> DataFlowProtocolData -> ShowS)
-> (DataFlowProtocolData -> [Char])
-> ([DataFlowProtocolData] -> ShowS)
-> Show DataFlowProtocolData
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DataFlowProtocolData -> ShowS
showsPrec :: Int -> DataFlowProtocolData -> ShowS
$cshow :: DataFlowProtocolData -> [Char]
show :: DataFlowProtocolData -> [Char]
$cshowList :: [DataFlowProtocolData] -> ShowS
showList :: [DataFlowProtocolData] -> ShowS
Show)

instance Acceptable DataFlowProtocolData where
  acceptableVersion :: DataFlowProtocolData
-> DataFlowProtocolData -> Accept DataFlowProtocolData
acceptableVersion (DataFlowProtocolData DataFlow
local PeerSharing
lps) (DataFlowProtocolData DataFlow
remote PeerSharing
rps) =
    DataFlowProtocolData -> Accept DataFlowProtocolData
forall vData. vData -> Accept vData
Accept (DataFlow -> PeerSharing -> DataFlowProtocolData
DataFlowProtocolData (DataFlow
local DataFlow -> DataFlow -> DataFlow
forall a. Ord a => a -> a -> a
`min` DataFlow
remote) (PeerSharing
lps PeerSharing -> PeerSharing -> PeerSharing
forall a. Semigroup a => a -> a -> a
<> PeerSharing
rps))

instance Queryable DataFlowProtocolData where
  queryVersion :: DataFlowProtocolData -> Bool
queryVersion (DataFlowProtocolData DataFlow
_ PeerSharing
_) = Bool
False

dataFlowProtocolDataCodec :: UnversionedProtocol -> CodecCBORTerm Text DataFlowProtocolData
dataFlowProtocolDataCodec :: UnversionedProtocol -> CodecCBORTerm Text DataFlowProtocolData
dataFlowProtocolDataCodec UnversionedProtocol
_ = CodecCBORTerm {DataFlowProtocolData -> Term
encodeTerm :: DataFlowProtocolData -> Term
encodeTerm :: DataFlowProtocolData -> Term
encodeTerm, Term -> Either Text DataFlowProtocolData
decodeTerm :: Term -> Either Text DataFlowProtocolData
decodeTerm :: Term -> Either Text DataFlowProtocolData
decodeTerm}
    where
      encodeTerm :: DataFlowProtocolData -> CBOR.Term
      encodeTerm :: DataFlowProtocolData -> Term
encodeTerm (DataFlowProtocolData DataFlow
Unidirectional PeerSharing
ps) =
        let peerSharing :: Int
peerSharing = case PeerSharing
ps of
              PeerSharing
PeerSharingDisabled -> Int
0
              PeerSharing
PeerSharingEnabled  -> Int
1
         in [Term] -> Term
CBOR.TList [Bool -> Term
CBOR.TBool Bool
False, Int -> Term
CBOR.TInt Int
peerSharing]
      encodeTerm (DataFlowProtocolData DataFlow
Duplex PeerSharing
ps) =
        let peerSharing :: Int
peerSharing = case PeerSharing
ps of
              PeerSharing
PeerSharingDisabled -> Int
0
              PeerSharing
PeerSharingEnabled  -> Int
1
         in [Term] -> Term
CBOR.TList [Bool -> Term
CBOR.TBool Bool
True, Int -> Term
CBOR.TInt Int
peerSharing]

      toPeerSharing :: Int -> Either Text PeerSharing
      toPeerSharing :: Int -> Either Text PeerSharing
toPeerSharing Int
0 = PeerSharing -> Either Text PeerSharing
forall a b. b -> Either a b
Right PeerSharing
PeerSharingDisabled
      toPeerSharing Int
1 = PeerSharing -> Either Text PeerSharing
forall a b. b -> Either a b
Right PeerSharing
PeerSharingEnabled
      toPeerSharing Int
_ = Text -> Either Text PeerSharing
forall a b. a -> Either a b
Left Text
"toPeerSharing: out of bounds"

      decodeTerm :: CBOR.Term -> Either Text DataFlowProtocolData
      decodeTerm :: Term -> Either Text DataFlowProtocolData
decodeTerm (CBOR.TList [CBOR.TBool Bool
False, CBOR.TInt Int
a]) = DataFlow -> PeerSharing -> DataFlowProtocolData
DataFlowProtocolData DataFlow
Unidirectional (PeerSharing -> DataFlowProtocolData)
-> Either Text PeerSharing -> Either Text DataFlowProtocolData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Either Text PeerSharing
toPeerSharing Int
a)
      decodeTerm (CBOR.TList [CBOR.TBool Bool
True, CBOR.TInt Int
a])  = DataFlow -> PeerSharing -> DataFlowProtocolData
DataFlowProtocolData DataFlow
Duplex (PeerSharing -> DataFlowProtocolData)
-> Either Text PeerSharing -> Either Text DataFlowProtocolData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Either Text PeerSharing
toPeerSharing Int
a)
      decodeTerm Term
t                  = Text -> Either Text DataFlowProtocolData
forall a b. a -> Either a b
Left (Text -> Either Text DataFlowProtocolData)
-> Text -> Either Text DataFlowProtocolData
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [Char]
"unexpected term: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Term -> [Char]
forall a. Show a => a -> [Char]
show Term
t

dataFlowProtocol :: DataFlow
                 -> app
                 -> Versions UnversionedProtocol
                             DataFlowProtocolData
                             app
dataFlowProtocol :: forall app.
DataFlow
-> app -> Versions UnversionedProtocol DataFlowProtocolData app
dataFlowProtocol DataFlow
dataFlow =
    UnversionedProtocol
-> DataFlowProtocolData
-> app
-> Versions UnversionedProtocol DataFlowProtocolData app
forall vNum vData r. vNum -> vData -> r -> Versions vNum vData r
simpleSingletonVersions UnversionedProtocol
UnversionedProtocol (DataFlow -> PeerSharing -> DataFlowProtocolData
DataFlowProtocolData DataFlow
dataFlow PeerSharing
PeerSharingDisabled)

-- | 'Handshake' codec used in various tests.
--
unversionedHandshakeCodec :: MonadST m
                          => Codec (Handshake UnversionedProtocol CBOR.Term)
                                    CBOR.DeserialiseFailure m ByteString
unversionedHandshakeCodec :: forall (m :: * -> *).
MonadST m =>
Codec
  (Handshake UnversionedProtocol Term)
  DeserialiseFailure
  m
  ByteString
unversionedHandshakeCodec = CodecCBORTerm ([Char], Maybe Int) UnversionedProtocol
-> Codec
     (Handshake UnversionedProtocol Term)
     DeserialiseFailure
     m
     ByteString
forall vNumber (m :: * -> *) failure.
(MonadST m, Ord vNumber, Show failure) =>
CodecCBORTerm (failure, Maybe Int) vNumber
-> Codec (Handshake vNumber Term) DeserialiseFailure m ByteString
codecHandshake CodecCBORTerm ([Char], Maybe Int) UnversionedProtocol
unversionedProtocolCodec
  where
    unversionedProtocolCodec :: CodecCBORTerm (String, Maybe Int) UnversionedProtocol
    unversionedProtocolCodec :: CodecCBORTerm ([Char], Maybe Int) UnversionedProtocol
unversionedProtocolCodec = CodecCBORTerm { UnversionedProtocol -> Term
encodeTerm :: UnversionedProtocol -> Term
encodeTerm :: UnversionedProtocol -> Term
encodeTerm, Term -> Either ([Char], Maybe Int) UnversionedProtocol
forall {a}.
IsString a =>
Term -> Either (a, Maybe Int) UnversionedProtocol
decodeTerm :: Term -> Either ([Char], Maybe Int) UnversionedProtocol
decodeTerm :: forall {a}.
IsString a =>
Term -> Either (a, Maybe Int) UnversionedProtocol
decodeTerm }
      where
        encodeTerm :: UnversionedProtocol -> Term
encodeTerm UnversionedProtocol
UnversionedProtocol = Int -> Term
CBOR.TInt Int
1
        decodeTerm :: Term -> Either (a, Maybe Int) UnversionedProtocol
decodeTerm (CBOR.TInt Int
1) = UnversionedProtocol -> Either (a, Maybe Int) UnversionedProtocol
forall a b. b -> Either a b
Right UnversionedProtocol
UnversionedProtocol
        decodeTerm (CBOR.TInt Int
n) = (a, Maybe Int) -> Either (a, Maybe Int) UnversionedProtocol
forall a b. a -> Either a b
Left (a
"decode UnversionedProtocol: unknown tag", Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n)
        decodeTerm Term
_             = (a, Maybe Int) -> Either (a, Maybe Int) UnversionedProtocol
forall a b. a -> Either a b
Left (a
"decode UnversionedProtocol: deserialisation failure", Maybe Int
forall a. Maybe a
Nothing)