TLV.hs (4933B)
1 {-# OPTIONS_HADDOCK hide #-} 2 {-# LANGUAGE BangPatterns #-} 3 {-# LANGUAGE DeriveGeneric #-} 4 5 -- | 6 -- Module: Lightning.Protocol.BOLT1.TLV 7 -- Copyright: (c) 2025 Jared Tobin 8 -- License: MIT 9 -- Maintainer: Jared Tobin <jared@ppad.tech> 10 -- 11 -- The TLV (type-length-value) format of BOLT #1. 12 13 module Lightning.Protocol.BOLT1.TLV ( 14 TlvRecord(..) 15 , TlvStream 16 , tlv_stream 17 , un_tlv_stream 18 , empty_tlv_stream 19 , lookup_tlv 20 , filter_tlv_stream 21 , TlvError(..) 22 , encode_tlv_stream 23 , decode_tlv_stream 24 ) where 25 26 import Control.DeepSeq (NFData) 27 import qualified Data.ByteString as BS 28 import qualified Data.ByteString.Unsafe as BU 29 import qualified Data.List as L 30 import Data.Word (Word64) 31 import GHC.Generics (Generic) 32 import Lightning.Protocol.BOLT1.Prim 33 34 -- | A single TLV record. 35 data TlvRecord = TlvRecord 36 { tlv_type :: {-# UNPACK #-} !Word64 37 , tlv_value :: !BS.ByteString 38 } deriving (Eq, Show, Generic) 39 40 instance NFData TlvRecord 41 42 -- | A TLV stream: records in strictly increasing type order. 43 newtype TlvStream = TlvStream [TlvRecord] 44 deriving (Eq, Show, Generic) 45 46 instance NFData TlvStream 47 48 -- | Construct a 'TlvStream' from records in any order. Fails if two 49 -- records share a type. 50 -- 51 -- >>> let Just s = tlv_stream [TlvRecord 3 "b", TlvRecord 1 "a"] 52 -- >>> map tlv_type (un_tlv_stream s) 53 -- [1,3] 54 -- >>> tlv_stream [TlvRecord 1 "a", TlvRecord 1 "b"] 55 -- Nothing 56 tlv_stream :: [TlvRecord] -> Maybe TlvStream 57 tlv_stream rs 58 | increasing sorted = Just (TlvStream sorted) 59 | otherwise = Nothing 60 where 61 sorted = L.sortOn tlv_type rs 62 63 increasing :: [TlvRecord] -> Bool 64 increasing (a:rest@(b:_)) = tlv_type a < tlv_type b && increasing rest 65 increasing _ = True 66 67 -- | The records of a 'TlvStream', in increasing type order. 68 un_tlv_stream :: TlvStream -> [TlvRecord] 69 un_tlv_stream (TlvStream rs) = rs 70 {-# INLINE un_tlv_stream #-} 71 72 -- | The empty 'TlvStream'. 73 empty_tlv_stream :: TlvStream 74 empty_tlv_stream = TlvStream [] 75 76 -- | The value of the record with the given type, if present. 77 -- 78 -- >>> lookup_tlv 3 =<< tlv_stream [TlvRecord 1 "a", TlvRecord 3 "b"] 79 -- Just "b" 80 lookup_tlv :: Word64 -> TlvStream -> Maybe BS.ByteString 81 lookup_tlv t (TlvStream rs) = go rs 82 where 83 go [] = Nothing 84 go (TlvRecord u v : more) 85 | u == t = Just v 86 | u > t = Nothing 87 | otherwise = go more 88 89 -- | Keep the records whose types satisfy the predicate. 90 -- 91 -- >>> let Just s = tlv_stream [TlvRecord 1 "", TlvRecord 2 ""] 92 -- >>> map tlv_type (un_tlv_stream (filter_tlv_stream odd s)) 93 -- [1] 94 filter_tlv_stream :: (Word64 -> Bool) -> TlvStream -> TlvStream 95 filter_tlv_stream p (TlvStream rs) = TlvStream (filter (p . tlv_type) rs) 96 97 -- | Why a TLV stream failed to decode. 98 data TlvError 99 = TlvTruncated -- ^ a type, length or value was cut off 100 | TlvNonMinimalBigSize -- ^ a type or length wasn't minimal 101 | TlvNotStrictlyIncreasing -- ^ types out of order or repeated 102 | TlvUnknownEvenType !Word64 -- ^ an even type the context doesn't know 103 deriving (Eq, Show, Generic) 104 105 instance NFData TlvError 106 107 -- | Encode a 'TlvStream'. 108 -- 109 -- >>> fmap encode_tlv_stream (tlv_stream [TlvRecord 1 "a"]) 110 -- Just "\SOH\SOHa" 111 encode_tlv_stream :: TlvStream -> BS.ByteString 112 encode_tlv_stream (TlvStream rs) = mconcat (concatMap enc rs) 113 where 114 enc (TlvRecord t v) = 115 [encode_bigsize t, encode_bigsize (fromIntegral (BS.length v)), v] 116 117 -- | Decode a TLV stream occupying the whole input, given a predicate 118 -- identifying the types known in the stream's context. 119 -- 120 -- Per BOLT #1, decoding fails on truncation, non-minimal BigSize 121 -- encodings, types that are not strictly increasing, and unknown 122 -- even types. Every record is kept, including unknown odd ones, so 123 -- re-encoding reproduces the input. 124 -- 125 -- >>> let Right s = decode_tlv_stream (== 1) "\SOH\SOHa\ETX\NUL" 126 -- >>> map tlv_type (un_tlv_stream s) 127 -- [1,3] 128 -- >>> decode_tlv_stream (== 1) "\STX\NUL" 129 -- Left (TlvUnknownEvenType 2) 130 decode_tlv_stream 131 :: (Word64 -> Bool) -- ^ is this type known? 132 -> BS.ByteString 133 -> Either TlvError TlvStream 134 decode_tlv_stream known = go Nothing [] 135 where 136 go !_ !acc !bs | BS.null bs = Right (TlvStream (reverse acc)) 137 go !prev !acc !bs = do 138 (t, r0) <- bigsize bs 139 case prev of 140 Just p | t <= p -> Left TlvNotStrictlyIncreasing 141 _ -> pure () 142 (l, r1) <- bigsize r0 143 if l > fromIntegral (BS.length r1) 144 then Left TlvTruncated 145 else do 146 let !n = fromIntegral l 147 !v = BU.unsafeTake n r1 148 !r2 = BU.unsafeDrop n r1 149 if not (known t) && even t 150 then Left (TlvUnknownEvenType t) 151 else go (Just t) (TlvRecord t v : acc) r2 152 153 bigsize b = case decode_bigsize_detailed b of 154 Right r -> Right r 155 Left BigSizeTruncated -> Left TlvTruncated 156 Left BigSizeNonMinimal -> Left TlvNonMinimalBigSize