-
Notifications
You must be signed in to change notification settings - Fork 86
/
Unversioned.hs
81 lines (60 loc) · 2.86 KB
/
Unversioned.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
{-# LANGUAGE NamedFieldPuns #-}
-- | Unversioned protocol, used in tests and demo applications.
--
module Ouroboros.Network.Protocol.Handshake.Unversioned
( UnversionedProtocol (..)
, UnversionedProtocolData (..)
, unversionedHandshakeCodec
, unversionedProtocolDataCodec
, unversionedProtocol
) where
import Control.Monad.Class.MonadST
import qualified Codec.CBOR.Read as CBOR
import qualified Codec.CBOR.Term as CBOR
import Data.Text (Text)
import qualified Data.Text as T
import Data.ByteString.Lazy (ByteString)
import Ouroboros.Network.Codec
import Ouroboros.Network.CodecCBORTerm
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 (Eq, Ord, Show)
data UnversionedProtocolData = UnversionedProtocolData
deriving (Eq, Show)
instance Acceptable UnversionedProtocolData where
acceptableVersion UnversionedProtocolData
UnversionedProtocolData = Accept
unversionedProtocolDataCodec :: CodecCBORTerm Text UnversionedProtocolData
unversionedProtocolDataCodec = CodecCBORTerm {encodeTerm, decodeTerm}
where
encodeTerm :: UnversionedProtocolData -> CBOR.Term
encodeTerm UnversionedProtocolData = CBOR.TNull
decodeTerm :: CBOR.Term -> Either Text UnversionedProtocolData
decodeTerm CBOR.TNull = Right UnversionedProtocolData
decodeTerm t = Left $ T.pack $ "unexpected term: " ++ show t
-- | Make a 'Versions' for an unversioned protocol. Only use this for
-- tests and demos where proper versioning is excessive.
--
unversionedProtocol :: app -> Versions UnversionedProtocol DictVersion app
unversionedProtocol =
simpleSingletonVersions UnversionedProtocol UnversionedProtocolData
(DictVersion unversionedProtocolDataCodec)
-- | 'Handshake' codec used in various tests.
--
unversionedHandshakeCodec :: MonadST m
=> Codec (Handshake UnversionedProtocol CBOR.Term)
CBOR.DeserialiseFailure m ByteString
unversionedHandshakeCodec = codecHandshake unversionedProtocolCodec
where
unversionedProtocolCodec :: CodecCBORTerm (String, Maybe Int) UnversionedProtocol
unversionedProtocolCodec = CodecCBORTerm { encodeTerm, decodeTerm }
where
encodeTerm UnversionedProtocol = CBOR.TInt 1
decodeTerm (CBOR.TInt 1) = Right UnversionedProtocol
decodeTerm (CBOR.TInt n) = Left ("decode UnversionedProtocol: unknown tag", Just n)
decodeTerm _ = Left ("decode UnversionedProtocol: deserialisation failure", Nothing)