{-# OPTIONS_HADDOCK prune #-}
{-# LANGUAGE BangPatterns #-}

-- |
-- Module: Lightning.Protocol.BOLT5.Detect
-- Copyright: (c) 2025 Jared Tobin
-- License: MIT
-- Maintainer: Jared Tobin <jared@ppad.tech>
--
-- Close identification, output classification, and preimage
-- extraction for BOLT #5 on-chain transaction handling.

module Lightning.Protocol.BOLT5.Detect (
    -- * Close identification
    identify_close

    -- * Output classification
  , classify_local_commit_outputs
  , classify_remote_commit_outputs
  , classify_revoked_commit_outputs

    -- * Preimage extraction
  , extract_preimage_offered
  , extract_preimage_htlc_success

    -- * Timeout check
  , htlc_timed_out
  ) where

import qualified Bitcoin.Prim.Tx as BT
import Data.Word (Word32)
import qualified Data.ByteString as BS
import Lightning.Protocol.BOLT3
import Lightning.Protocol.BOLT5.Types

-- close identification -----------------------------------------------

-- | Identify the type of channel close from a transaction that
--   spends the funding output.
--
-- Compares the on-chain transaction bytes against the known
-- local and remote commitment transaction serializations
-- (stripped/unsigned) to determine whether it's a local or
-- remote commitment close.
--
-- Returns 'Nothing' if the transaction doesn't match either
-- commitment. Mutual close and revoked commitment detection
-- require additional checks by the caller (e.g. comparing
-- closing tx format, checking a secret store for older
-- commitment numbers).
identify_close
  :: CommitmentTx
  -- ^ Our local commitment tx.
  -> CommitmentTx
  -- ^ The remote commitment tx (current).
  -> BS.ByteString
  -- ^ Raw serialized transaction found on chain.
  -> Maybe CloseType
identify_close :: CommitmentTx -> CommitmentTx -> ByteString -> Maybe CloseType
identify_close !CommitmentTx
localCommitTx !CommitmentTx
remoteCommitTx
    !ByteString
onChainBytes =
    let !localBytes :: Maybe ByteString
localBytes = CommitmentTx -> Maybe ByteString
encode_tx_for_signing CommitmentTx
localCommitTx
        !remoteBytes :: Maybe ByteString
remoteBytes = CommitmentTx -> Maybe ByteString
encode_tx_for_signing CommitmentTx
remoteCommitTx
    in  if Maybe ByteString
localBytes Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
onChainBytes
        then CloseType -> Maybe CloseType
forall a. a -> Maybe a
Just CloseType
LocalCommitClose
        else if Maybe ByteString
remoteBytes Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
onChainBytes
        then CloseType -> Maybe CloseType
forall a. a -> Maybe a
Just CloseType
RemoteCommitClose
        else Maybe CloseType
forall a. Maybe a
Nothing

-- output classification ----------------------------------------------

-- | Classify outputs of our local commitment transaction.
--
-- Per BOLT #5: when we discover our local commitment on chain,
-- we must resolve each output. to_local requires a CSV-delayed
-- spend, to_remote is resolved by the commitment itself, HTLC
-- outputs need second-stage transactions, and anchors can be
-- spent immediately.
classify_local_commit_outputs
  :: CommitmentTx
  -- ^ Our local commitment transaction.
  -> CommitmentKeys
  -- ^ Derived keys for this commitment.
  -> ToSelfDelay
  -- ^ Remote's to_self_delay (CSV delay for our outputs).
  -> ChannelFeatures
  -- ^ Channel feature flags.
  -> [HTLC]
  -- ^ HTLCs in this commitment.
  -> [UnresolvedOutput]
classify_local_commit_outputs :: CommitmentTx
-> CommitmentKeys
-> ToSelfDelay
-> ChannelFeatures
-> [HTLC]
-> [UnresolvedOutput]
classify_local_commit_outputs !CommitmentTx
commitTx !CommitmentKeys
keys !ToSelfDelay
delay
    !ChannelFeatures
features ![HTLC]
htlcs =
  case CommitmentTx -> Maybe TxId
commitment_txid CommitmentTx
commitTx of
    Maybe TxId
Nothing -> []
    Just !TxId
txid ->
      let !outputs :: [TxOutput]
outputs = CommitmentTx -> [TxOutput]
ctx_outputs CommitmentTx
commitTx
          !revpk :: RevocationPubkey
revpk = CommitmentKeys -> RevocationPubkey
ck_revocation_pubkey CommitmentKeys
keys
          !delayedpk :: LocalDelayedPubkey
delayedpk = CommitmentKeys -> LocalDelayedPubkey
ck_local_delayed CommitmentKeys
keys
      in  (Word32 -> TxOutput -> UnresolvedOutput)
-> [Word32] -> [TxOutput] -> [UnresolvedOutput]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (TxId
-> RevocationPubkey
-> LocalDelayedPubkey
-> ToSelfDelay
-> ChannelFeatures
-> CommitmentKeys
-> [HTLC]
-> Word32
-> TxOutput
-> UnresolvedOutput
classifyLocalOutput TxId
txid RevocationPubkey
revpk LocalDelayedPubkey
delayedpk
                     ToSelfDelay
delay ChannelFeatures
features CommitmentKeys
keys [HTLC]
htlcs)
            [Word32
0..] [TxOutput]
outputs

-- | Classify a single output from a local commitment tx.
classifyLocalOutput
  :: TxId
  -> RevocationPubkey
  -> LocalDelayedPubkey
  -> ToSelfDelay
  -> ChannelFeatures
  -> CommitmentKeys
  -> [HTLC]
  -> Word32
  -> TxOutput
  -> UnresolvedOutput
classifyLocalOutput :: TxId
-> RevocationPubkey
-> LocalDelayedPubkey
-> ToSelfDelay
-> ChannelFeatures
-> CommitmentKeys
-> [HTLC]
-> Word32
-> TxOutput
-> UnresolvedOutput
classifyLocalOutput !TxId
txid !RevocationPubkey
revpk !LocalDelayedPubkey
delayedpk !ToSelfDelay
delay
    !ChannelFeatures
features !CommitmentKeys
keys ![HTLC]
htlcs !Word32
idx !TxOutput
out =
  let !op :: OutPoint
op = TxId -> Word32 -> OutPoint
OutPoint TxId
txid Word32
idx
      !val :: Satoshi
val = TxOutput -> Satoshi
txout_value TxOutput
out
      !resolution :: OutputResolution
resolution = case TxOutput -> OutputType
txout_type TxOutput
out of
        OutputType
OutputToLocal ->
          ToSelfDelay
-> RevocationPubkey -> LocalDelayedPubkey -> OutputResolution
SpendToLocal ToSelfDelay
delay RevocationPubkey
revpk LocalDelayedPubkey
delayedpk
        OutputType
OutputToRemote ->
          OutputResolution
Resolved
        OutputType
OutputLocalAnchor ->
          FundingPubkey -> OutputResolution
AnchorSpend (CommitmentKeys -> FundingPubkey
ck_local_funding CommitmentKeys
keys)
        OutputType
OutputRemoteAnchor ->
          OutputResolution
Resolved
        OutputOfferedHTLC CltvExpiry
_expiry ->
          case HTLCDirection
-> Script
-> CommitmentKeys
-> ChannelFeatures
-> [HTLC]
-> Maybe HTLC
findHTLC HTLCDirection
HTLCOffered
                 (TxOutput -> Script
txout_script TxOutput
out) CommitmentKeys
keys ChannelFeatures
features [HTLC]
htlcs of
            Just HTLC
htlc ->
              HTLC -> CommitmentKeys -> ChannelFeatures -> OutputResolution
SpendHTLCTimeout HTLC
htlc CommitmentKeys
keys ChannelFeatures
features
            Maybe HTLC
Nothing -> OutputResolution
Resolved
        OutputReceivedHTLC CltvExpiry
_expiry ->
          case HTLCDirection
-> Script
-> CommitmentKeys
-> ChannelFeatures
-> [HTLC]
-> Maybe HTLC
findHTLC HTLCDirection
HTLCReceived
                 (TxOutput -> Script
txout_script TxOutput
out) CommitmentKeys
keys ChannelFeatures
features [HTLC]
htlcs of
            Just HTLC
htlc ->
              HTLC -> CommitmentKeys -> ChannelFeatures -> OutputResolution
SpendHTLCSuccess HTLC
htlc CommitmentKeys
keys ChannelFeatures
features
            Maybe HTLC
Nothing -> OutputResolution
Resolved
  in OutPoint -> Satoshi -> OutputResolution -> UnresolvedOutput
UnresolvedOutput OutPoint
op Satoshi
val OutputResolution
resolution

-- | Classify outputs of the remote commitment transaction.
--
-- Per BOLT #5: when we discover the remote commitment on chain,
-- there are no CSV delays on our outputs. We can spend offered
-- HTLCs directly after timeout, and received HTLCs directly
-- with the preimage.
classify_remote_commit_outputs
  :: CommitmentTx
  -- ^ The remote commitment transaction.
  -> CommitmentKeys
  -- ^ Derived keys for this commitment (from remote's
  --   perspective, so local/remote are swapped).
  -> ChannelFeatures
  -- ^ Channel feature flags.
  -> [HTLC]
  -- ^ HTLCs in this commitment.
  -> [UnresolvedOutput]
classify_remote_commit_outputs :: CommitmentTx
-> CommitmentKeys
-> ChannelFeatures
-> [HTLC]
-> [UnresolvedOutput]
classify_remote_commit_outputs !CommitmentTx
commitTx !CommitmentKeys
keys
    !ChannelFeatures
features ![HTLC]
htlcs =
  case CommitmentTx -> Maybe TxId
commitment_txid CommitmentTx
commitTx of
    Maybe TxId
Nothing -> []
    Just !TxId
txid ->
      let !outputs :: [TxOutput]
outputs = CommitmentTx -> [TxOutput]
ctx_outputs CommitmentTx
commitTx
      in  (Word32 -> TxOutput -> UnresolvedOutput)
-> [Word32] -> [TxOutput] -> [UnresolvedOutput]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
            (TxId
-> ChannelFeatures
-> CommitmentKeys
-> [HTLC]
-> Word32
-> TxOutput
-> UnresolvedOutput
classifyRemoteOutput TxId
txid ChannelFeatures
features CommitmentKeys
keys [HTLC]
htlcs)
            [Word32
0..] [TxOutput]
outputs

-- | Classify a single output from a remote commitment tx.
classifyRemoteOutput
  :: TxId
  -> ChannelFeatures
  -> CommitmentKeys
  -> [HTLC]
  -> Word32
  -> TxOutput
  -> UnresolvedOutput
classifyRemoteOutput :: TxId
-> ChannelFeatures
-> CommitmentKeys
-> [HTLC]
-> Word32
-> TxOutput
-> UnresolvedOutput
classifyRemoteOutput !TxId
txid !ChannelFeatures
features !CommitmentKeys
keys
    ![HTLC]
htlcs !Word32
idx !TxOutput
out =
  let !op :: OutPoint
op = TxId -> Word32 -> OutPoint
OutPoint TxId
txid Word32
idx
      !val :: Satoshi
val = TxOutput -> Satoshi
txout_value TxOutput
out
      !resolution :: OutputResolution
resolution = case TxOutput -> OutputType
txout_type TxOutput
out of
        OutputType
OutputToLocal ->
          OutputResolution
Resolved  -- Remote's to_local; not ours
        OutputType
OutputToRemote ->
          OutputResolution
Resolved  -- Our to_remote; resolved by commitment
        OutputType
OutputLocalAnchor ->
          OutputResolution
Resolved  -- Remote's anchor
        OutputType
OutputRemoteAnchor ->
          FundingPubkey -> OutputResolution
AnchorSpend (CommitmentKeys -> FundingPubkey
ck_remote_funding CommitmentKeys
keys)
        OutputOfferedHTLC CltvExpiry
_expiry ->
          -- On remote's commit, their offered = our received.
          -- We can claim with preimage.
          case HTLCDirection
-> Script
-> CommitmentKeys
-> ChannelFeatures
-> [HTLC]
-> Maybe HTLC
findHTLC HTLCDirection
HTLCOffered
                 (TxOutput -> Script
txout_script TxOutput
out) CommitmentKeys
keys ChannelFeatures
features [HTLC]
htlcs of
            Just HTLC
htlc ->
              HTLC -> OutputResolution
SpendHTLCPreimageDirect HTLC
htlc
            Maybe HTLC
Nothing -> OutputResolution
Resolved
        OutputReceivedHTLC CltvExpiry
_expiry ->
          -- On remote's commit, their received = our offered.
          -- We can claim after timeout.
          case HTLCDirection
-> Script
-> CommitmentKeys
-> ChannelFeatures
-> [HTLC]
-> Maybe HTLC
findHTLC HTLCDirection
HTLCReceived
                 (TxOutput -> Script
txout_script TxOutput
out) CommitmentKeys
keys ChannelFeatures
features [HTLC]
htlcs of
            Just HTLC
htlc ->
              HTLC -> OutputResolution
SpendHTLCTimeoutDirect HTLC
htlc
            Maybe HTLC
Nothing -> OutputResolution
Resolved
  in OutPoint -> Satoshi -> OutputResolution -> UnresolvedOutput
UnresolvedOutput OutPoint
op Satoshi
val OutputResolution
resolution

-- | Classify outputs of a revoked commitment transaction.
--
-- Per BOLT #5: when we discover a revoked commitment, we can
-- claim everything using the revocation key. to_local is spent
-- via revocation, HTLCs are spent via revocation, and we can
-- also optionally sweep to_remote.
classify_revoked_commit_outputs
  :: CommitmentTx
  -- ^ The revoked commitment transaction.
  -> CommitmentKeys
  -- ^ Derived keys for the revoked commitment.
  -> RevocationPubkey
  -- ^ Revocation pubkey (derived from the revealed secret).
  -> ChannelFeatures
  -- ^ Channel feature flags.
  -> [HTLC]
  -- ^ HTLCs in the revoked commitment.
  -> [UnresolvedOutput]
classify_revoked_commit_outputs :: CommitmentTx
-> CommitmentKeys
-> RevocationPubkey
-> ChannelFeatures
-> [HTLC]
-> [UnresolvedOutput]
classify_revoked_commit_outputs !CommitmentTx
commitTx !CommitmentKeys
_keys
    !RevocationPubkey
revpk !ChannelFeatures
_features ![HTLC]
_htlcs =
  case CommitmentTx -> Maybe TxId
commitment_txid CommitmentTx
commitTx of
    Maybe TxId
Nothing -> []
    Just !TxId
txid ->
      let !outputs :: [TxOutput]
outputs = CommitmentTx -> [TxOutput]
ctx_outputs CommitmentTx
commitTx
      in  (Word32 -> TxOutput -> UnresolvedOutput)
-> [Word32] -> [TxOutput] -> [UnresolvedOutput]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (TxId -> RevocationPubkey -> Word32 -> TxOutput -> UnresolvedOutput
classifyRevokedOutput TxId
txid RevocationPubkey
revpk)
            [Word32
0..] [TxOutput]
outputs

-- | Classify a single output from a revoked commitment tx.
classifyRevokedOutput
  :: TxId
  -> RevocationPubkey
  -> Word32
  -> TxOutput
  -> UnresolvedOutput
classifyRevokedOutput :: TxId -> RevocationPubkey -> Word32 -> TxOutput -> UnresolvedOutput
classifyRevokedOutput !TxId
txid !RevocationPubkey
revpk !Word32
idx !TxOutput
out =
  let !op :: OutPoint
op = TxId -> Word32 -> OutPoint
OutPoint TxId
txid Word32
idx
      !val :: Satoshi
val = TxOutput -> Satoshi
txout_value TxOutput
out
      !resolution :: OutputResolution
resolution = case TxOutput -> OutputType
txout_type TxOutput
out of
        OutputType
OutputToLocal ->
          RevocationPubkey -> OutputResolution
Revoke RevocationPubkey
revpk
        OutputType
OutputToRemote ->
          OutputResolution
Resolved  -- Our funds; resolved by commitment
        OutputType
OutputLocalAnchor ->
          OutputResolution
Resolved  -- Can be swept by anyone after 16 blocks
        OutputType
OutputRemoteAnchor ->
          OutputResolution
Resolved  -- Our anchor
        otype :: OutputType
otype@(OutputOfferedHTLC CltvExpiry
_) ->
          RevocationPubkey -> OutputType -> OutputResolution
RevokeHTLC RevocationPubkey
revpk OutputType
otype
        otype :: OutputType
otype@(OutputReceivedHTLC CltvExpiry
_) ->
          RevocationPubkey -> OutputType -> OutputResolution
RevokeHTLC RevocationPubkey
revpk OutputType
otype
  in OutPoint -> Satoshi -> OutputResolution -> UnresolvedOutput
UnresolvedOutput OutPoint
op Satoshi
val OutputResolution
resolution

-- preimage extraction ------------------------------------------------

-- | Extract a payment preimage from an offered HTLC witness.
--
-- When the remote party claims an offered HTLC on our local
-- commitment, the witness contains the preimage. The witness
-- stack for a preimage claim is:
--
-- @\<remotehtlcsig\> \<paymentPreimage\>@
--
-- The preimage is the second item (32 bytes) and must hash to
-- the expected payment hash.
extract_preimage_offered :: Witness -> Maybe PaymentPreimage
extract_preimage_offered :: Witness -> Maybe PaymentPreimage
extract_preimage_offered (Witness [ByteString]
items) =
  case [ByteString]
items of
    [ByteString
_sig, ByteString
preimageBytes]
      | ByteString -> Int
BS.length ByteString
preimageBytes Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
32 ->
          ByteString -> Maybe PaymentPreimage
paymentPreimage ByteString
preimageBytes
    [ByteString]
_ -> Maybe PaymentPreimage
forall a. Maybe a
Nothing

-- | Extract a payment preimage from an HTLC-success transaction
--   witness.
--
-- When the remote party uses an HTLC-success tx on their
-- commitment to claim a received HTLC, the witness contains the
-- preimage. The witness stack is:
--
-- @0 \<remotehtlcsig\> \<localhtlcsig\> \<paymentPreimage\>@
--
-- The preimage is the fourth item (32 bytes).
extract_preimage_htlc_success
  :: Witness -> Maybe PaymentPreimage
extract_preimage_htlc_success :: Witness -> Maybe PaymentPreimage
extract_preimage_htlc_success (Witness [ByteString]
items) =
  case [ByteString]
items of
    [ByteString
_zero, ByteString
_remoteSig, ByteString
_localSig, ByteString
preimageBytes]
      | ByteString -> Int
BS.length ByteString
preimageBytes Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
32 ->
          ByteString -> Maybe PaymentPreimage
paymentPreimage ByteString
preimageBytes
    [ByteString]
_ -> Maybe PaymentPreimage
forall a. Maybe a
Nothing

-- timeout check ------------------------------------------------------

-- | Check if an HTLC has timed out at the given block height.
--
-- An HTLC has timed out when the current block height is equal
-- to or greater than the HTLC's CLTV expiry.
htlc_timed_out :: Word32 -> HTLC -> Bool
htlc_timed_out :: Word32 -> HTLC -> Bool
htlc_timed_out !Word32
currentHeight !HTLC
htlc =
  Word32
currentHeight Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
>= CltvExpiry -> Word32
unCltvExpiry (HTLC -> CltvExpiry
htlc_cltv_expiry HTLC
htlc)
{-# INLINE htlc_timed_out #-}

-- internal helpers ---------------------------------------------------

-- | Compute the txid of a commitment transaction.
--
-- Returns 'Nothing' if the commitment has no outputs.
commitment_txid :: CommitmentTx -> Maybe TxId
commitment_txid :: CommitmentTx -> Maybe TxId
commitment_txid !CommitmentTx
tx = (Tx -> TxId) -> Maybe Tx -> Maybe TxId
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Tx -> TxId
BT.txid (CommitmentTx -> Maybe Tx
commitment_to_tx CommitmentTx
tx)

-- | Find an HTLC matching a given script in the output list.
findHTLC
  :: HTLCDirection
  -> Script
  -> CommitmentKeys
  -> ChannelFeatures
  -> [HTLC]
  -> Maybe HTLC
findHTLC :: HTLCDirection
-> Script
-> CommitmentKeys
-> ChannelFeatures
-> [HTLC]
-> Maybe HTLC
findHTLC !HTLCDirection
dir !Script
targetScript !CommitmentKeys
keys !ChannelFeatures
features =
  [HTLC] -> Maybe HTLC
go
  where
    go :: [HTLC] -> Maybe HTLC
go [] = Maybe HTLC
forall a. Maybe a
Nothing
    go (HTLC
htlc:[HTLC]
rest)
      | HTLC -> HTLCDirection
htlc_direction HTLC
htlc HTLCDirection -> HTLCDirection -> Bool
forall a. Eq a => a -> a -> Bool
== HTLCDirection
dir
      , HTLC -> Script
htlcScript HTLC
htlc Script -> Script -> Bool
forall a. Eq a => a -> a -> Bool
== Script
targetScript = HTLC -> Maybe HTLC
forall a. a -> Maybe a
Just HTLC
htlc
      | Bool
otherwise = [HTLC] -> Maybe HTLC
go [HTLC]
rest

    htlcScript :: HTLC -> Script
htlcScript HTLC
htlc = case HTLCDirection
dir of
      HTLCDirection
HTLCOffered ->
        Script -> Script
to_p2wsh (Script -> Script) -> Script -> Script
forall a b. (a -> b) -> a -> b
$ RevocationPubkey
-> RemoteHtlcPubkey
-> LocalHtlcPubkey
-> PaymentHash
-> ChannelFeatures
-> Script
offered_htlc_script
          (CommitmentKeys -> RevocationPubkey
ck_revocation_pubkey CommitmentKeys
keys)
          (CommitmentKeys -> RemoteHtlcPubkey
ck_remote_htlc CommitmentKeys
keys)
          (CommitmentKeys -> LocalHtlcPubkey
ck_local_htlc CommitmentKeys
keys)
          (HTLC -> PaymentHash
htlc_payment_hash HTLC
htlc)
          ChannelFeatures
features
      HTLCDirection
HTLCReceived ->
        Script -> Script
to_p2wsh (Script -> Script) -> Script -> Script
forall a b. (a -> b) -> a -> b
$ RevocationPubkey
-> RemoteHtlcPubkey
-> LocalHtlcPubkey
-> PaymentHash
-> CltvExpiry
-> ChannelFeatures
-> Script
received_htlc_script
          (CommitmentKeys -> RevocationPubkey
ck_revocation_pubkey CommitmentKeys
keys)
          (CommitmentKeys -> RemoteHtlcPubkey
ck_remote_htlc CommitmentKeys
keys)
          (CommitmentKeys -> LocalHtlcPubkey
ck_local_htlc CommitmentKeys
keys)
          (HTLC -> PaymentHash
htlc_payment_hash HTLC
htlc)
          (HTLC -> CltvExpiry
htlc_cltv_expiry HTLC
htlc)
          ChannelFeatures
features