{-# OPTIONS_HADDOCK prune #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveGeneric #-}
module Lightning.Protocol.BOLT3.Validate (
ValidationError(..)
, validate_commitment_tx
, validate_commitment_locktime
, validate_commitment_sequence
, validate_htlc_tx
, validate_htlc_timeout_tx
, validate_htlc_success_tx
, validate_closing_tx
, validate_legacy_closing_tx
, validate_output_ordering
, validate_dust_limits
, validate_anchor_outputs
, validate_commitment_fee
, validate_htlc_fee
) where
import Data.Bits ((.&.), shiftR)
import Data.Word (Word32, Word64)
import GHC.Generics (Generic)
import Lightning.Protocol.BOLT3.Types
import Lightning.Protocol.BOLT3.Tx
data ValidationError
= InvalidVersion {-# UNPACK #-} !Word32 {-# UNPACK #-} !Word32
| InvalidLocktime {-# UNPACK #-} !Word32
| InvalidSequence {-# UNPACK #-} !Word32
| InvalidOutputOrdering
| DustLimitViolation {-# UNPACK #-} !Int !Satoshi !Satoshi
| MissingAnchorOutput
| InvalidAnchorValue {-# UNPACK #-} !Satoshi
| InvalidFee {-# UNPACK #-} !Satoshi {-# UNPACK #-} !Satoshi
| InvalidHTLCLocktime {-# UNPACK #-} !Word32 {-# UNPACK #-} !Word32
| InvalidHTLCSequence {-# UNPACK #-} !Word32 {-# UNPACK #-} !Word32
| NoOutputs
| TooManyOutputs {-# UNPACK #-} !Int
deriving (ValidationError -> ValidationError -> Bool
(ValidationError -> ValidationError -> Bool)
-> (ValidationError -> ValidationError -> Bool)
-> Eq ValidationError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ValidationError -> ValidationError -> Bool
== :: ValidationError -> ValidationError -> Bool
$c/= :: ValidationError -> ValidationError -> Bool
/= :: ValidationError -> ValidationError -> Bool
Eq, Int -> ValidationError -> ShowS
[ValidationError] -> ShowS
ValidationError -> String
(Int -> ValidationError -> ShowS)
-> (ValidationError -> String)
-> ([ValidationError] -> ShowS)
-> Show ValidationError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ValidationError -> ShowS
showsPrec :: Int -> ValidationError -> ShowS
$cshow :: ValidationError -> String
show :: ValidationError -> String
$cshowList :: [ValidationError] -> ShowS
showList :: [ValidationError] -> ShowS
Show, (forall x. ValidationError -> Rep ValidationError x)
-> (forall x. Rep ValidationError x -> ValidationError)
-> Generic ValidationError
forall x. Rep ValidationError x -> ValidationError
forall x. ValidationError -> Rep ValidationError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ValidationError -> Rep ValidationError x
from :: forall x. ValidationError -> Rep ValidationError x
$cto :: forall x. Rep ValidationError x -> ValidationError
to :: forall x. Rep ValidationError x -> ValidationError
Generic)
validate_commitment_tx
:: DustLimit
-> ChannelFeatures
-> CommitmentTx
-> Either ValidationError ()
validate_commitment_tx :: DustLimit
-> ChannelFeatures -> CommitmentTx -> Either ValidationError ()
validate_commitment_tx DustLimit
dust ChannelFeatures
features CommitmentTx
tx = do
Word32 -> Word32 -> Either ValidationError ()
validateVersion Word32
2 (CommitmentTx -> Word32
ctx_version CommitmentTx
tx)
Locktime -> Either ValidationError ()
validate_commitment_locktime (CommitmentTx -> Locktime
ctx_locktime CommitmentTx
tx)
Sequence -> Either ValidationError ()
validate_commitment_sequence (CommitmentTx -> Sequence
ctx_input_sequence CommitmentTx
tx)
[TxOutput] -> Either ValidationError ()
validate_output_ordering (CommitmentTx -> [TxOutput]
ctx_outputs CommitmentTx
tx)
DustLimit -> [TxOutput] -> Either ValidationError ()
validate_dust_limits DustLimit
dust (CommitmentTx -> [TxOutput]
ctx_outputs CommitmentTx
tx)
if ChannelFeatures -> Bool
has_anchors ChannelFeatures
features
then [TxOutput] -> Either ValidationError ()
validate_anchor_outputs (CommitmentTx -> [TxOutput]
ctx_outputs CommitmentTx
tx)
else () -> Either ValidationError ()
forall a. a -> Either ValidationError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
{-# INLINE validate_commitment_tx #-}
validate_commitment_locktime :: Locktime -> Either ValidationError ()
validate_commitment_locktime :: Locktime -> Either ValidationError ()
validate_commitment_locktime (Locktime Word32
lt) =
let !upper :: Word32
upper = (Word32
lt Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Int
24) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xFF
in if Word32
upper Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0x20
then () -> Either ValidationError ()
forall a b. b -> Either a b
Right ()
else ValidationError -> Either ValidationError ()
forall a b. a -> Either a b
Left (Word32 -> ValidationError
InvalidLocktime Word32
lt)
{-# INLINE validate_commitment_locktime #-}
validate_commitment_sequence :: Sequence -> Either ValidationError ()
validate_commitment_sequence :: Sequence -> Either ValidationError ()
validate_commitment_sequence (Sequence Word32
sq) =
let !upper :: Word32
upper = (Word32
sq Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Int
24) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xFF
in if Word32
upper Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0x80
then () -> Either ValidationError ()
forall a b. b -> Either a b
Right ()
else ValidationError -> Either ValidationError ()
forall a b. a -> Either a b
Left (Word32 -> ValidationError
InvalidSequence Word32
sq)
{-# INLINE validate_commitment_sequence #-}
validate_htlc_tx :: HTLCTx -> Either ValidationError ()
validate_htlc_tx :: HTLCTx -> Either ValidationError ()
validate_htlc_tx HTLCTx
tx = do
Word32 -> Word32 -> Either ValidationError ()
validateVersion Word32
2 (HTLCTx -> Word32
htx_version HTLCTx
tx)
() -> Either ValidationError ()
forall a. a -> Either ValidationError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
{-# INLINE validate_htlc_tx #-}
validate_htlc_timeout_tx
:: ChannelFeatures
-> CltvExpiry
-> HTLCTx
-> Either ValidationError ()
validate_htlc_timeout_tx :: ChannelFeatures
-> CltvExpiry -> HTLCTx -> Either ValidationError ()
validate_htlc_timeout_tx ChannelFeatures
features CltvExpiry
expiry HTLCTx
tx = do
HTLCTx -> Either ValidationError ()
validate_htlc_tx HTLCTx
tx
let !expectedLt :: Word32
expectedLt = CltvExpiry -> Word32
unCltvExpiry CltvExpiry
expiry
!actualLt :: Word32
actualLt = Locktime -> Word32
unLocktime (HTLCTx -> Locktime
htx_locktime HTLCTx
tx)
if Word32
expectedLt Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
actualLt
then () -> Either ValidationError ()
forall a. a -> Either ValidationError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
else ValidationError -> Either ValidationError ()
forall a b. a -> Either a b
Left (Word32 -> Word32 -> ValidationError
InvalidHTLCLocktime Word32
expectedLt Word32
actualLt)
let !expectedSeq :: Word32
expectedSeq = if ChannelFeatures -> Bool
has_anchors ChannelFeatures
features then Word32
1 else Word32
0
!actualSeq :: Word32
actualSeq = Sequence -> Word32
unSequence (HTLCTx -> Sequence
htx_input_sequence HTLCTx
tx)
if Word32
expectedSeq Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
actualSeq
then () -> Either ValidationError ()
forall a. a -> Either ValidationError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
else ValidationError -> Either ValidationError ()
forall a b. a -> Either a b
Left (Word32 -> Word32 -> ValidationError
InvalidHTLCSequence Word32
expectedSeq Word32
actualSeq)
{-# INLINE validate_htlc_timeout_tx #-}
validate_htlc_success_tx
:: ChannelFeatures
-> HTLCTx
-> Either ValidationError ()
validate_htlc_success_tx :: ChannelFeatures -> HTLCTx -> Either ValidationError ()
validate_htlc_success_tx ChannelFeatures
features HTLCTx
tx = do
HTLCTx -> Either ValidationError ()
validate_htlc_tx HTLCTx
tx
let !actualLt :: Word32
actualLt = Locktime -> Word32
unLocktime (HTLCTx -> Locktime
htx_locktime HTLCTx
tx)
if Word32
actualLt Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0
then () -> Either ValidationError ()
forall a. a -> Either ValidationError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
else ValidationError -> Either ValidationError ()
forall a b. a -> Either a b
Left (Word32 -> Word32 -> ValidationError
InvalidHTLCLocktime Word32
0 Word32
actualLt)
let !expectedSeq :: Word32
expectedSeq = if ChannelFeatures -> Bool
has_anchors ChannelFeatures
features then Word32
1 else Word32
0
!actualSeq :: Word32
actualSeq = Sequence -> Word32
unSequence (HTLCTx -> Sequence
htx_input_sequence HTLCTx
tx)
if Word32
expectedSeq Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
actualSeq
then () -> Either ValidationError ()
forall a. a -> Either ValidationError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
else ValidationError -> Either ValidationError ()
forall a b. a -> Either a b
Left (Word32 -> Word32 -> ValidationError
InvalidHTLCSequence Word32
expectedSeq Word32
actualSeq)
{-# INLINE validate_htlc_success_tx #-}
validate_closing_tx :: ClosingTx -> Either ValidationError ()
validate_closing_tx :: ClosingTx -> Either ValidationError ()
validate_closing_tx ClosingTx
tx = do
Word32 -> Word32 -> Either ValidationError ()
validateVersion Word32
2 (ClosingTx -> Word32
cltx_version ClosingTx
tx)
let !actualSeq :: Word32
actualSeq = Sequence -> Word32
unSequence (ClosingTx -> Sequence
cltx_input_sequence ClosingTx
tx)
if Word32
actualSeq Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0xFFFFFFFD
then () -> Either ValidationError ()
forall a. a -> Either ValidationError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
else ValidationError -> Either ValidationError ()
forall a b. a -> Either a b
Left (Word32 -> ValidationError
InvalidSequence Word32
actualSeq)
[TxOutput] -> Either ValidationError ()
validateOutputCount (ClosingTx -> [TxOutput]
cltx_outputs ClosingTx
tx)
[TxOutput] -> Either ValidationError ()
validate_output_ordering (ClosingTx -> [TxOutput]
cltx_outputs ClosingTx
tx)
{-# INLINE validate_closing_tx #-}
validate_legacy_closing_tx :: ClosingTx -> Either ValidationError ()
validate_legacy_closing_tx :: ClosingTx -> Either ValidationError ()
validate_legacy_closing_tx ClosingTx
tx = do
Word32 -> Word32 -> Either ValidationError ()
validateVersion Word32
2 (ClosingTx -> Word32
cltx_version ClosingTx
tx)
let !actualLt :: Word32
actualLt = Locktime -> Word32
unLocktime (ClosingTx -> Locktime
cltx_locktime ClosingTx
tx)
if Word32
actualLt Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0
then () -> Either ValidationError ()
forall a. a -> Either ValidationError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
else ValidationError -> Either ValidationError ()
forall a b. a -> Either a b
Left (Word32 -> ValidationError
InvalidLocktime Word32
actualLt)
let !actualSeq :: Word32
actualSeq = Sequence -> Word32
unSequence (ClosingTx -> Sequence
cltx_input_sequence ClosingTx
tx)
if Word32
actualSeq Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0xFFFFFFFF
then () -> Either ValidationError ()
forall a. a -> Either ValidationError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
else ValidationError -> Either ValidationError ()
forall a b. a -> Either a b
Left (Word32 -> ValidationError
InvalidSequence Word32
actualSeq)
[TxOutput] -> Either ValidationError ()
validateOutputCount (ClosingTx -> [TxOutput]
cltx_outputs ClosingTx
tx)
[TxOutput] -> Either ValidationError ()
validate_output_ordering (ClosingTx -> [TxOutput]
cltx_outputs ClosingTx
tx)
{-# INLINE validate_legacy_closing_tx #-}
validate_output_ordering :: [TxOutput] -> Either ValidationError ()
validate_output_ordering :: [TxOutput] -> Either ValidationError ()
validate_output_ordering [TxOutput]
outputs =
let !sorted :: [TxOutput]
sorted = [TxOutput] -> [TxOutput]
sort_outputs [TxOutput]
outputs
in if [TxOutput]
outputs [TxOutput] -> [TxOutput] -> Bool
forall a. Eq a => a -> a -> Bool
== [TxOutput]
sorted
then () -> Either ValidationError ()
forall a b. b -> Either a b
Right ()
else ValidationError -> Either ValidationError ()
forall a b. a -> Either a b
Left ValidationError
InvalidOutputOrdering
{-# INLINE validate_output_ordering #-}
validate_dust_limits
:: DustLimit
-> [TxOutput]
-> Either ValidationError ()
validate_dust_limits :: DustLimit -> [TxOutput] -> Either ValidationError ()
validate_dust_limits DustLimit
dust = Int -> [TxOutput] -> Either ValidationError ()
go Int
0 where
!limit :: Satoshi
limit = DustLimit -> Satoshi
unDustLimit DustLimit
dust
go :: Int -> [TxOutput] -> Either ValidationError ()
go !Int
_ [] = () -> Either ValidationError ()
forall a b. b -> Either a b
Right ()
go !Int
idx (TxOutput
out:[TxOutput]
rest) =
let !val :: Satoshi
val = TxOutput -> Satoshi
txout_value TxOutput
out
in case TxOutput -> OutputType
txout_type TxOutput
out of
OutputType
OutputLocalAnchor -> Int -> [TxOutput] -> Either ValidationError ()
go (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [TxOutput]
rest
OutputType
OutputRemoteAnchor -> Int -> [TxOutput] -> Either ValidationError ()
go (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [TxOutput]
rest
OutputType
_ -> if Satoshi -> Word64
unSatoshi Satoshi
val Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Satoshi -> Word64
unSatoshi Satoshi
limit
then Int -> [TxOutput] -> Either ValidationError ()
go (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [TxOutput]
rest
else ValidationError -> Either ValidationError ()
forall a b. a -> Either a b
Left (Int -> Satoshi -> Satoshi -> ValidationError
DustLimitViolation Int
idx Satoshi
val Satoshi
limit)
{-# INLINE validate_dust_limits #-}
validate_anchor_outputs :: [TxOutput] -> Either ValidationError ()
validate_anchor_outputs :: [TxOutput] -> Either ValidationError ()
validate_anchor_outputs [TxOutput]
outputs =
let !anchors :: [TxOutput]
anchors = (TxOutput -> Bool) -> [TxOutput] -> [TxOutput]
forall a. (a -> Bool) -> [a] -> [a]
filter TxOutput -> Bool
isAnchor [TxOutput]
outputs
in if [TxOutput] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TxOutput]
anchors
then ValidationError -> Either ValidationError ()
forall a b. a -> Either a b
Left ValidationError
MissingAnchorOutput
else [TxOutput] -> Either ValidationError ()
validateAnchorValues [TxOutput]
anchors
where
isAnchor :: TxOutput -> Bool
isAnchor TxOutput
out = case TxOutput -> OutputType
txout_type TxOutput
out of
OutputType
OutputLocalAnchor -> Bool
True
OutputType
OutputRemoteAnchor -> Bool
True
OutputType
_ -> Bool
False
validateAnchorValues :: [TxOutput] -> Either ValidationError ()
validateAnchorValues [] = () -> Either ValidationError ()
forall a b. b -> Either a b
Right ()
validateAnchorValues (TxOutput
a:[TxOutput]
as) =
let !val :: Satoshi
val = TxOutput -> Satoshi
txout_value TxOutput
a
in if Satoshi
val Satoshi -> Satoshi -> Bool
forall a. Eq a => a -> a -> Bool
== Satoshi
anchor_output_value
then [TxOutput] -> Either ValidationError ()
validateAnchorValues [TxOutput]
as
else ValidationError -> Either ValidationError ()
forall a b. a -> Either a b
Left (Satoshi -> ValidationError
InvalidAnchorValue Satoshi
val)
{-# INLINE validate_anchor_outputs #-}
validate_commitment_fee
:: FeeratePerKw
-> ChannelFeatures
-> Word64
-> Satoshi
-> Either ValidationError ()
validate_commitment_fee :: FeeratePerKw
-> ChannelFeatures
-> Word64
-> Satoshi
-> Either ValidationError ()
validate_commitment_fee FeeratePerKw
feerate ChannelFeatures
features Word64
numHtlcs Satoshi
actualFee =
let !expectedFee :: Satoshi
expectedFee = FeeratePerKw -> ChannelFeatures -> Word64 -> Satoshi
commitment_fee FeeratePerKw
feerate ChannelFeatures
features Word64
numHtlcs
in if Satoshi
actualFee Satoshi -> Satoshi -> Bool
forall a. Eq a => a -> a -> Bool
== Satoshi
expectedFee
then () -> Either ValidationError ()
forall a b. b -> Either a b
Right ()
else ValidationError -> Either ValidationError ()
forall a b. a -> Either a b
Left (Satoshi -> Satoshi -> ValidationError
InvalidFee Satoshi
expectedFee Satoshi
actualFee)
{-# INLINE validate_commitment_fee #-}
validate_htlc_fee
:: FeeratePerKw
-> ChannelFeatures
-> HTLCDirection
-> Satoshi
-> Either ValidationError ()
validate_htlc_fee :: FeeratePerKw
-> ChannelFeatures
-> HTLCDirection
-> Satoshi
-> Either ValidationError ()
validate_htlc_fee FeeratePerKw
feerate ChannelFeatures
features HTLCDirection
direction Satoshi
actualFee =
let !expectedFee :: Satoshi
expectedFee = case HTLCDirection
direction of
HTLCDirection
HTLCOffered -> FeeratePerKw -> ChannelFeatures -> Satoshi
htlc_timeout_fee FeeratePerKw
feerate ChannelFeatures
features
HTLCDirection
HTLCReceived -> FeeratePerKw -> ChannelFeatures -> Satoshi
htlc_success_fee FeeratePerKw
feerate ChannelFeatures
features
in if Satoshi
actualFee Satoshi -> Satoshi -> Bool
forall a. Eq a => a -> a -> Bool
== Satoshi
expectedFee
then () -> Either ValidationError ()
forall a b. b -> Either a b
Right ()
else ValidationError -> Either ValidationError ()
forall a b. a -> Either a b
Left (Satoshi -> Satoshi -> ValidationError
InvalidFee Satoshi
expectedFee Satoshi
actualFee)
{-# INLINE validate_htlc_fee #-}
validateVersion :: Word32 -> Word32 -> Either ValidationError ()
validateVersion :: Word32 -> Word32 -> Either ValidationError ()
validateVersion Word32
expected Word32
actual =
if Word32
expected Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
actual
then () -> Either ValidationError ()
forall a b. b -> Either a b
Right ()
else ValidationError -> Either ValidationError ()
forall a b. a -> Either a b
Left (Word32 -> Word32 -> ValidationError
InvalidVersion Word32
expected Word32
actual)
{-# INLINE validateVersion #-}
validateOutputCount :: [TxOutput] -> Either ValidationError ()
validateOutputCount :: [TxOutput] -> Either ValidationError ()
validateOutputCount [] = ValidationError -> Either ValidationError ()
forall a b. a -> Either a b
Left ValidationError
NoOutputs
validateOutputCount [TxOutput]
_ = () -> Either ValidationError ()
forall a b. b -> Either a b
Right ()
{-# INLINE validateOutputCount #-}