{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
module Bitcoin.Compare where
import Bitcoin.SpendCond.Cond
import Bitcoin.Internal.Util
import Data.Word (Word32)
import qualified Data.List.NonEmpty as NE
import qualified Network.Haskoin.Transaction as HT
import qualified Network.Haskoin.Crypto as HC
import GHC.Generics (Generic)
import Debug.Trace
newtype DiffInfo = DiffInfo [(HC.Address,ValDiff)]
data ValDiff =
Increase BtcAmount
| Decrease BtcAmount
| NoChange
deriving (Eq, Show, Generic, NFData, ToJSON, FromJSON, Serialize)
data TxMismatch r =
TxVersionMismatch Word32 Word32
| TxLocktimeMismatch (Maybe LockTimeDate) (Maybe LockTimeDate)
| TxInMismatch (InMismatch r)
| TxOutMisMatch OutMismatch
deriving (Eq, Show, Generic, NFData, ToJSON, FromJSON, Serialize)
data InMismatch r =
InPrevOutMismatch HT.OutPoint HT.OutPoint
| InRdmScrMismatch r r
| InSequenceMismatch Word32 Word32
deriving (Eq, Show, Generic, NFData, ToJSON, FromJSON, Serialize)
data OutMismatch =
OutAddressMismatch HC.Address HC.Address
deriving (Eq, Show, Generic, NFData, ToJSON, FromJSON, Serialize)
valueDiff :: forall r t a. (Eq r) =>
BtcTx t r a -> BtcTx t r a -> Either (TxMismatch r) DiffInfo
valueDiff oldTx newTx =
compareProp oldTx newTx btcVer TxVersionMismatch
>> compareProp oldTx newTx btcLock TxLocktimeMismatch
>> getFirstErr TxInMismatch compareIns
>> DiffInfo <$> getFirstErr TxOutMisMatch compareOuts
where
getFirstErr mkErr eL = if not $ null (lefts eL) then Left $ mkErr (head $ lefts eL) else Right (rights eL)
compareIns = zipWith inputDiff (NE.toList $ btcIns oldTx) (NE.toList $ btcIns newTx)
compareOuts = zipWith outputDiff (btcOuts oldTx) (btcOuts newTx)
inputDiff :: (Eq r) => InputG t r a -> InputG t r a -> Either (InMismatch r) ()
inputDiff oldIn newIn =
compareProp oldIn newIn btcPrevOut InPrevOutMismatch
>> compareProp oldIn newIn btcCondScr InRdmScrMismatch
>> compareProp oldIn newIn btcSequence InSequenceMismatch
>> return ()
outputDiff :: BtcOut -> BtcOut -> Either OutMismatch (HC.Address,ValDiff)
outputDiff oldOut newOut =
compareProp oldOut newOut btcAddress OutAddressMismatch
>>= \addr -> Right (addr,valDiff)
where
newAmount = nonDusty (btcAmount newOut)
oldAmount = nonDusty (btcAmount oldOut)
valDiff
| newAmount == oldAmount = NoChange
| newAmount > oldAmount = Increase (newAmount - oldAmount)
| otherwise = Decrease (oldAmount - newAmount)
eqIgnoreOutVal :: Eq r =>
IgnoreSigData (BtcTx t r BtcSig) -> IgnoreSigData (BtcTx t r BtcSig) -> Bool
eqIgnoreOutVal tx1 tx2 = tx1 =~= tx2
where
a =~= b = fmap txClearOutVal a == fmap txClearOutVal b
txClearOutVal tx = tx { btcOuts = map outputValClear (btcOuts tx) }
outputValClear out = out { btcAmount = nullAmount }
compareProp :: Eq prop => a -> a -> (a -> prop) -> (prop -> prop -> e) -> Either e prop
compareProp old new getProp mkErr =
if getProp old == getProp new
then Right (getProp new)
else Left $ mkErr (getProp old) (getProp new)