ppad-bolt4-0.1.0: bench/Fixtures.hs

{-# LANGUAGE OverloadedStrings #-}

module Fixtures (
    Fixtures(..)
  , fixtures
  ) where

import Control.DeepSeq (NFData(..))
import qualified Data.ByteString as BS
import qualified Lightning.Protocol.BOLT1 as BOLT1
import Lightning.Protocol.BOLT4

data Fixtures = Fixtures {
    fx_session       :: !SecretKey
  , fx_ad            :: !BS.ByteString
  , fx_route_1       :: ![Hop]
  , fx_route_5       :: ![Hop]
  , fx_route_20      :: ![Hop]
  , fx_first_node    :: !SecretKey
  , fx_onion_5       :: !OnionPacket
  , fx_onion_1       :: !OnionPacket
  , fx_secrets_5     :: ![SharedSecret]
  , fx_secret        :: !SharedSecret
  , fx_blinded_node  :: !SecretKey
  , fx_blinded_onion :: !OnionPacket
  , fx_path_key      :: !BOLT1.Point
  , fx_path_seed     :: !SecretKey
  , fx_path_nodes    :: ![(BOLT1.Point, BlindedHopData)]
  , fx_encrypted     :: !BS.ByteString
  , fx_failure       :: !FailureMessage
  , fx_error         :: !ErrorPacket
  , fx_returned      :: !ErrorPacket
  , fx_onion_bytes   :: !BS.ByteString
  , fx_payload       :: !HopPayload
  , fx_payload_bytes :: !BS.ByteString
  }

instance NFData Fixtures where
  rnf (Fixtures a b c d e f g h i j k l m n o p q r s t u v) =
    rnf a `seq` rnf b `seq` rnf c `seq` rnf d `seq` rnf e `seq` rnf f
      `seq` rnf g `seq` rnf h `seq` rnf i `seq` rnf j `seq` rnf k
      `seq` rnf l `seq` rnf m `seq` rnf n `seq` rnf o `seq` rnf p
      `seq` rnf q `seq` rnf r `seq` rnf s `seq` rnf t `seq` rnf u
      `seq` rnf v

demand :: String -> Maybe a -> IO a
demand msg = maybe (ioError (userError msg)) pure

right :: Show e => String -> Either e a -> IO a
right msg = either (ioError . userError . (msg ++) . (": " ++) . show) pure

fixtures :: IO Fixtures
fixtures = do
  let key b = demand "secret_key" (secret_key (BS.replicate 32 b))
      ad = BS.replicate 32 0x42
  session <- key 0x41
  nodes <- mapM key [1 .. 20]
  amt <- demand "milli_satoshi" (BOLT1.milli_satoshi 100000)
  scid <- demand "short_channel_id" (BOLT1.short_channel_id 800000 1 0)
  ps <- demand "payment_secret" (payment_secret (BS.replicate 32 0xaa))
  let fwd = empty_hop_payload
        { hp_amt_to_forward = Just amt
        , hp_outgoing_cltv_value = Just 800000
        , hp_short_channel_id = Just scid
        }
      final = empty_hop_payload
        { hp_amt_to_forward = Just amt
        , hp_outgoing_cltv_value = Just 800000
        , hp_payment_data = Just (PaymentData ps amt)
        }
      route n = [ Hop (public_key k) fwd | k <- take (n - 1) nodes ]
             ++ [ Hop (public_key k) final
                | k <- take 1 (drop (n - 1) nodes) ]
  first_node <- demand "node" (safe_head nodes)
  (onion_5, secrets_5) <- right "construct" (construct session (route 5) ad)
  (onion_1, _) <- right "construct" (construct session (route 1) ad)

  -- a blinded route through nodes 1 to 3, entered at node 0
  seed <- key 0x55
  let relay = empty_blinded_hop_data
        { bhd_short_channel_id = Just scid
        , bhd_payment_relay = Just (PaymentRelay 40 100 1000)
        }
      path_nodes = [ (public_key k, relay) | k <- take 2 (drop 1 nodes) ]
                ++ [ (public_key k, empty_blinded_hop_data
                       { bhd_path_id = Just (BS.replicate 32 1) })
                   | k <- take 1 (drop 3 nodes) ]
  path <- right "create_blinded_path" (create_blinded_path seed path_nodes)
  hops <- case bp_hops path of
    [h1, h2, h3] -> pure (h1, h2, h3)
    _ -> ioError (userError "expected 3 blinded hops")
  let (h1, h2, h3) = hops
      bhop h pl = Hop (bh_blinded_node_id h)
        pl { hp_encrypted_data = Just (bh_encrypted_data h) }
      entry = Hop (public_key first_node) fwd
      broute = [ entry
               , Hop (bp_first_node_id path) empty_hop_payload
                   { hp_encrypted_data = Just (bh_encrypted_data h1)
                   , hp_current_path_key = Just (bp_first_path_key path) }
               , bhop h2 empty_hop_payload
               , bhop h3 empty_hop_payload
                   { hp_amt_to_forward = Just amt
                   , hp_outgoing_cltv_value = Just 800000
                   , hp_total_amount_msat = Just amt } ]
  (bonion, _) <- right "construct" (construct session broute ad)
  -- the onion received, with a path_key, by node 2
  node1 <- demand "node" (safe_head (drop 1 nodes))
  node2 <- demand "node" (safe_head (drop 2 nodes))
  f0 <- forwarded (process first_node bonion ad Nothing)
  f1 <- forwarded (process node1 (fwd_next_packet f0) ad Nothing)
  b1 <- demand "blinded" (fwd_blinded f1)

  -- node 4 fails a 5-hop payment
  ss4 <- demand "secret" (safe_head (drop 4 secrets_5))
  let failure = FailureMessage TemporaryNodeFailure BOLT1.empty_tlv_stream
  err <- right "construct_error" (construct_error ss4 failure)
  let returned = foldr wrap_error err (take 4 secrets_5)

  payload_bytes <- right "encode_hop_payload" (encode_hop_payload final)
  pure Fixtures {
      fx_session       = session
    , fx_ad            = ad
    , fx_route_1       = route 1
    , fx_route_5       = route 5
    , fx_route_20      = route 20
    , fx_first_node    = first_node
    , fx_onion_5       = onion_5
    , fx_onion_1       = onion_1
    , fx_secrets_5     = secrets_5
    , fx_secret        = ss4
    , fx_blinded_node  = node2
    , fx_blinded_onion = fwd_next_packet f1
    , fx_path_key      = bi_next_path_key b1
    , fx_path_seed     = seed
    , fx_path_nodes    = path_nodes
    , fx_encrypted     = bh_encrypted_data h2
    , fx_failure       = failure
    , fx_error         = err
    , fx_returned      = returned
    , fx_onion_bytes   = encode_onion_packet onion_5
    , fx_payload       = final
    , fx_payload_bytes = payload_bytes
    }
  where
    safe_head xs = case xs of
      x : _ -> Just x
      []    -> Nothing
    forwarded r = case r of
      Right (Forward f) -> pure f
      _ -> ioError (userError ("expected Forward: " ++ show r))