Construct.hs (6002B)
1 {-# OPTIONS_HADDOCK hide #-} 2 {-# LANGUAGE BangPatterns #-} 3 {-# LANGUAGE DeriveGeneric #-} 4 5 -- | 6 -- Module: Lightning.Protocol.BOLT4.Construct 7 -- Copyright: (c) 2025 Jared Tobin 8 -- License: MIT 9 -- Maintainer: Jared Tobin <jared@ppad.tech> 10 -- 11 -- Onion packet construction. 12 13 module Lightning.Protocol.BOLT4.Construct ( 14 Hop(..) 15 , ConstructError(..) 16 , construct 17 ) where 18 19 import Control.DeepSeq (NFData) 20 import qualified Crypto.Curve.Secp256k1 as Secp256k1 21 import qualified Data.ByteString as BS 22 import qualified Data.List as L 23 import GHC.Generics (Generic) 24 import qualified Lightning.Protocol.BOLT1 as BOLT1 25 import Lightning.Protocol.BOLT4.Codec (encode_hop_payload) 26 import Lightning.Protocol.BOLT4.Prim 27 import Lightning.Protocol.BOLT4.Types 28 29 -- | A hop of a route: the public key the hop's onion layer is encrypted 30 -- to (its node id, or its blinded node id in a blinded route), and its 31 -- payload. 32 data Hop = Hop 33 { hop_pubkey :: !BOLT1.Point 34 , hop_payload :: !HopPayload 35 } deriving (Eq, Show, Generic) 36 37 instance NFData Hop 38 39 -- | Why an onion packet could not be constructed. 40 data ConstructError 41 = EmptyRoute 42 -- ^ the route has no hops 43 | TooManyHops 44 -- ^ the route has more than 20 hops 45 | InvalidHopPubKey {-# UNPACK #-} !Int 46 -- ^ the public key of the hop with this index is not a valid point 47 | InvalidHopPayload {-# UNPACK #-} !Int 48 -- ^ the payload of the hop with this index can't be encoded, or 49 -- encodes to fewer than 2 bytes 50 | PayloadsTooLarge {-# UNPACK #-} !Int 51 -- ^ the hops' payloads, with their length prefixes and HMACs, take 52 -- this many bytes, more than the 1300 available 53 deriving (Eq, Show, Generic) 54 55 instance NFData ConstructError 56 57 -- | Construct an onion packet for a route, given a session key (which 58 -- must be fresh and random for every onion), the route's hops from 59 -- the first to the final one, and the associated data (the payment 60 -- hash, for a payment). 61 -- 62 -- Returns the packet and the shared secret of each hop, in route 63 -- order; keep the latter to attribute returned errors with 64 -- 'Lightning.Protocol.BOLT4.unwrap_error'. 65 -- 66 -- >>> let Just session = secret_key (BS.replicate 32 0x41) 67 -- >>> let Just node = secret_key (BS.replicate 32 0x42) 68 -- >>> let Just amt = BOLT1.milli_satoshi 1000 69 -- >>> :{ 70 -- let payload = empty_hop_payload { 71 -- hp_amt_to_forward = Just amt 72 -- , hp_outgoing_cltv_value = Just 800000 73 -- } 74 -- route = [Hop (public_key node) payload] 75 -- :} 76 -- >>> let Right (pkt, sss) = construct session route (BS.replicate 32 0) 77 -- >>> BS.length (encode_onion_packet pkt) 78 -- 1366 79 -- >>> length sss 80 -- 1 81 construct 82 :: SecretKey 83 -> [Hop] 84 -> BS.ByteString 85 -> Either ConstructError (OnionPacket, [SharedSecret]) 86 construct sk hops ad 87 | null hops = Left EmptyRoute 88 | length hops > 20 = Left TooManyHops 89 | otherwise = do 90 pubs <- traverse parse_pub ihops 91 pls <- traverse encode_pl ihops 92 let sizes = map shift_size pls 93 total = sum sizes 94 if total > 1300 95 then Left (PayloadsTooLarge total) 96 else do 97 sss <- shared_secrets (sk_bytes sk) (sk_pub sk) (zip [0 ..] pubs) 98 let streams = map (\ss -> keystream (derive_rho ss) 2600) sss 99 n = length hops 100 fill = filler (take (n - 1) streams) (take (n - 1) sizes) 101 start = keystream (derive_pad sk) 1300 102 (body, mac) = wrap ad fill start 103 (reverse (zip3 sss streams pls)) 104 pkt = OnionPacket 0 (public_key sk) (HopPayloads body) 105 (Hmac32 mac) 106 pure (pkt, sss) 107 where 108 ihops = zip [0 ..] hops 109 110 parse_pub (i, h) = 111 maybe (Left (InvalidHopPubKey i)) Right (from_point (hop_pubkey h)) 112 113 encode_pl (i, h) = case encode_hop_payload (hop_payload h) of 114 Right p | BS.length p >= 2 -> Right p 115 _ -> Left (InvalidHopPayload i) 116 117 -- bytes a payload takes in hop_payloads: length prefix, payload and HMAC 118 shift_size :: BS.ByteString -> Int 119 shift_size p = 120 let !l = BS.length p 121 in BS.length (BOLT1.encode_bigsize (fromIntegral l)) + l + 32 122 123 -- the shared secret of each hop, blinding the ephemeral key pair after 124 -- each one 125 shared_secrets 126 :: BS.ByteString 127 -> Secp256k1.Projective 128 -> [(Int, Secp256k1.Projective)] 129 -> Either ConstructError [SharedSecret] 130 shared_secrets _ _ [] = Right [] 131 shared_secrets e epub ((i, pub) : rest) = do 132 ss <- note (ecdh e pub) 133 case rest of 134 [] -> Right [ss] 135 _ -> do 136 let bf = blinding_factor epub ss 137 e' <- note (blind_scalar e bf) 138 epub' <- note (blind_pub epub bf) 139 (ss :) <$> shared_secrets e' epub' rest 140 where 141 note = maybe (Left (InvalidHopPubKey i)) Right 142 143 -- the filler, from the 2600-byte rho streams and shift sizes of all 144 -- hops but the final one 145 filler :: [BS.ByteString] -> [Int] -> BS.ByteString 146 filler streams sizes = L.foldl' step BS.empty (zip streams sizes) 147 where 148 step f (s, n) = 149 let !ext = f <> BS.replicate n 0 150 !off = 1300 - BS.length f 151 in xor_bytes ext (BS.take (BS.length ext) (BS.drop off s)) 152 153 -- wrap the hops' payloads, given (shared secret, rho stream, payload) 154 -- from the final hop to the first, returning hop_payloads and the HMAC 155 wrap 156 :: BS.ByteString 157 -> BS.ByteString 158 -> BS.ByteString 159 -> [(SharedSecret, BS.ByteString, BS.ByteString)] 160 -> (BS.ByteString, BS.ByteString) 161 wrap ad fill = go True (BS.replicate 32 0) 162 where 163 go _ !mac !buf [] = (buf, mac) 164 go final !mac !buf ((ss, stream, pl) : rest) = 165 let !len = BOLT1.encode_bigsize (fromIntegral (BS.length pl)) 166 !n = BS.length len + BS.length pl + 32 167 !shifted = BS.concat [len, pl, mac, BS.take (1300 - n) buf] 168 !obf = xor_bytes shifted stream 169 !buf' | final = BS.take (1300 - BS.length fill) obf <> fill 170 | otherwise = obf 171 !mac' = hmac (derive_mu ss) (buf' <> ad) 172 in go False mac' buf' rest