{-# LANGUAGE NamedFieldPuns #-}

-- | 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 qualified Codec.CBOR.Read as CBOR
import qualified Codec.CBOR.Term as CBOR

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

import           Network.TypedProtocol.Codec

import           Ouroboros.Network.CodecCBORTerm
import           Ouroboros.Network.ConnectionManager.Types (DataFlow (..))
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
/= :: UnversionedProtocol -> UnversionedProtocol -> Bool
$c/= :: UnversionedProtocol -> UnversionedProtocol -> Bool
== :: UnversionedProtocol -> UnversionedProtocol -> Bool
$c== :: 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
min :: UnversionedProtocol -> UnversionedProtocol -> UnversionedProtocol
$cmin :: UnversionedProtocol -> UnversionedProtocol -> UnversionedProtocol
max :: UnversionedProtocol -> UnversionedProtocol -> UnversionedProtocol
$cmax :: UnversionedProtocol -> UnversionedProtocol -> UnversionedProtocol
>= :: UnversionedProtocol -> UnversionedProtocol -> Bool
$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
compare :: UnversionedProtocol -> UnversionedProtocol -> Ordering
$ccompare :: UnversionedProtocol -> UnversionedProtocol -> Ordering
$cp1Ord :: Eq UnversionedProtocol
Ord, Int -> UnversionedProtocol -> ShowS
[UnversionedProtocol] -> ShowS
UnversionedProtocol -> String
(Int -> UnversionedProtocol -> ShowS)
-> (UnversionedProtocol -> String)
-> ([UnversionedProtocol] -> ShowS)
-> Show UnversionedProtocol
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UnversionedProtocol] -> ShowS
$cshowList :: [UnversionedProtocol] -> ShowS
show :: UnversionedProtocol -> String
$cshow :: UnversionedProtocol -> String
showsPrec :: Int -> UnversionedProtocol -> ShowS
$cshowsPrec :: Int -> 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
/= :: UnversionedProtocolData -> UnversionedProtocolData -> Bool
$c/= :: UnversionedProtocolData -> UnversionedProtocolData -> Bool
== :: UnversionedProtocolData -> UnversionedProtocolData -> Bool
$c== :: UnversionedProtocolData -> UnversionedProtocolData -> Bool
Eq, Int -> UnversionedProtocolData -> ShowS
[UnversionedProtocolData] -> ShowS
UnversionedProtocolData -> String
(Int -> UnversionedProtocolData -> ShowS)
-> (UnversionedProtocolData -> String)
-> ([UnversionedProtocolData] -> ShowS)
-> Show UnversionedProtocolData
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UnversionedProtocolData] -> ShowS
$cshowList :: [UnversionedProtocolData] -> ShowS
show :: UnversionedProtocolData -> String
$cshow :: UnversionedProtocolData -> String
showsPrec :: Int -> UnversionedProtocolData -> ShowS
$cshowsPrec :: Int -> 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


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 :: forall fail a.
(a -> Term) -> (Term -> Either fail a) -> CodecCBORTerm fail a
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
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"unexpected term: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Term -> String
forall a. Show a => a -> String
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 :: 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'.
--
newtype DataFlowProtocolData =
    DataFlowProtocolData { DataFlowProtocolData -> DataFlow
getProtocolDataFlow :: DataFlow }
  deriving (DataFlowProtocolData -> DataFlowProtocolData -> Bool
(DataFlowProtocolData -> DataFlowProtocolData -> Bool)
-> (DataFlowProtocolData -> DataFlowProtocolData -> Bool)
-> Eq DataFlowProtocolData
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DataFlowProtocolData -> DataFlowProtocolData -> Bool
$c/= :: DataFlowProtocolData -> DataFlowProtocolData -> Bool
== :: DataFlowProtocolData -> DataFlowProtocolData -> Bool
$c== :: DataFlowProtocolData -> DataFlowProtocolData -> Bool
Eq, Int -> DataFlowProtocolData -> ShowS
[DataFlowProtocolData] -> ShowS
DataFlowProtocolData -> String
(Int -> DataFlowProtocolData -> ShowS)
-> (DataFlowProtocolData -> String)
-> ([DataFlowProtocolData] -> ShowS)
-> Show DataFlowProtocolData
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DataFlowProtocolData] -> ShowS
$cshowList :: [DataFlowProtocolData] -> ShowS
show :: DataFlowProtocolData -> String
$cshow :: DataFlowProtocolData -> String
showsPrec :: Int -> DataFlowProtocolData -> ShowS
$cshowsPrec :: Int -> DataFlowProtocolData -> ShowS
Show)

instance Acceptable DataFlowProtocolData where
  acceptableVersion :: DataFlowProtocolData
-> DataFlowProtocolData -> Accept DataFlowProtocolData
acceptableVersion (DataFlowProtocolData DataFlow
local) (DataFlowProtocolData DataFlow
remote) =
    DataFlowProtocolData -> Accept DataFlowProtocolData
forall vData. vData -> Accept vData
Accept (DataFlow -> DataFlowProtocolData
DataFlowProtocolData (DataFlow -> DataFlowProtocolData)
-> DataFlow -> DataFlowProtocolData
forall a b. (a -> b) -> a -> b
$ DataFlow
local DataFlow -> DataFlow -> DataFlow
forall a. Ord a => a -> a -> a
`min` DataFlow
remote)

dataFlowProtocolDataCodec :: UnversionedProtocol -> CodecCBORTerm Text DataFlowProtocolData
dataFlowProtocolDataCodec :: UnversionedProtocol -> CodecCBORTerm Text DataFlowProtocolData
dataFlowProtocolDataCodec UnversionedProtocol
_ = CodecCBORTerm :: forall fail a.
(a -> Term) -> (Term -> Either fail a) -> CodecCBORTerm fail a
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) = Bool -> Term
CBOR.TBool Bool
False
      encodeTerm (DataFlowProtocolData DataFlow
Duplex)         = Bool -> Term
CBOR.TBool Bool
True

      decodeTerm :: CBOR.Term -> Either Text DataFlowProtocolData
      decodeTerm :: Term -> Either Text DataFlowProtocolData
decodeTerm (CBOR.TBool Bool
False) = DataFlowProtocolData -> Either Text DataFlowProtocolData
forall a b. b -> Either a b
Right (DataFlow -> DataFlowProtocolData
DataFlowProtocolData DataFlow
Unidirectional)
      decodeTerm (CBOR.TBool Bool
True)  = DataFlowProtocolData -> Either Text DataFlowProtocolData
forall a b. b -> Either a b
Right (DataFlow -> DataFlowProtocolData
DataFlowProtocolData DataFlow
Duplex)
      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
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"unexpected term: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Term -> String
forall a. Show a => a -> String
show Term
t

dataFlowProtocol :: DataFlow
                 -> app
                 -> Versions UnversionedProtocol
                             DataFlowProtocolData
                             app
dataFlowProtocol :: 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 -> DataFlowProtocolData
DataFlowProtocolData DataFlow
dataFlow)

-- | 'Handshake' codec used in various tests.
--
unversionedHandshakeCodec :: MonadST m
                          => Codec (Handshake UnversionedProtocol CBOR.Term)
                                    CBOR.DeserialiseFailure m ByteString
unversionedHandshakeCodec :: Codec
  (Handshake UnversionedProtocol Term)
  DeserialiseFailure
  m
  ByteString
unversionedHandshakeCodec = CodecCBORTerm (String, 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 (String, Maybe Int) UnversionedProtocol
unversionedProtocolCodec
  where
    unversionedProtocolCodec :: CodecCBORTerm (String, Maybe Int) UnversionedProtocol
    unversionedProtocolCodec :: CodecCBORTerm (String, Maybe Int) UnversionedProtocol
unversionedProtocolCodec = CodecCBORTerm :: forall fail a.
(a -> Term) -> (Term -> Either fail a) -> CodecCBORTerm fail a
CodecCBORTerm { UnversionedProtocol -> Term
encodeTerm :: UnversionedProtocol -> Term
encodeTerm :: UnversionedProtocol -> Term
encodeTerm, Term -> Either (String, Maybe Int) UnversionedProtocol
decodeTerm :: Term -> Either (String, Maybe Int) UnversionedProtocol
decodeTerm :: Term -> Either (String, Maybe Int) UnversionedProtocol
decodeTerm }
      where
        encodeTerm :: UnversionedProtocol -> Term
encodeTerm UnversionedProtocol
UnversionedProtocol = Int -> Term
CBOR.TInt Int
1
        decodeTerm :: Term -> Either (String, Maybe Int) UnversionedProtocol
decodeTerm (CBOR.TInt Int
1) = UnversionedProtocol
-> Either (String, Maybe Int) UnversionedProtocol
forall a b. b -> Either a b
Right UnversionedProtocol
UnversionedProtocol
        decodeTerm (CBOR.TInt Int
n) = (String, Maybe Int)
-> Either (String, Maybe Int) UnversionedProtocol
forall a b. a -> Either a b
Left (String
"decode UnversionedProtocol: unknown tag", Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n)
        decodeTerm Term
_             = (String, Maybe Int)
-> Either (String, Maybe Int) UnversionedProtocol
forall a b. a -> Either a b
Left (String
"decode UnversionedProtocol: deserialisation failure", Maybe Int
forall a. Maybe a
Nothing)