module Ripple.Transaction (
Transaction(..),
TransactionType(..),
Field(..)
) where
import Numeric
import Control.Monad
import Control.Applicative
import Data.Maybe
import Data.List
import Data.Word
import Data.LargeWord
import Data.Bits
import Control.Error (readMay)
import Data.Binary (Binary(..), Put, Get, putWord8, getWord8, encode)
import Data.Binary.Get (isEmpty, getLazyByteString, lookAheadM)
import Data.Binary.Put (putLazyByteString)
import Data.Bool.HT (select)
import Data.Base58Address (RippleAddress)
import qualified Data.ByteString.Lazy as LZ
import Data.Aeson ((.:?))
import qualified Data.Aeson as Aeson
import qualified Data.Text as T
import Ripple.Amount
import Ripple.Path
data TransactionType =
Payment | AccountSet | SetRegularKey | OfferCreate | OfferCancel |
Sign | TrustSet | OtherTransaction Word16
deriving (Show, Read, Eq)
instance Enum TransactionType where
toEnum 00 = Payment
toEnum 03 = AccountSet
toEnum 05 = SetRegularKey
toEnum 07 = OfferCreate
toEnum 08 = OfferCancel
toEnum 09 = Sign
toEnum 20 = TrustSet
toEnum x = OtherTransaction $ toEnum x
fromEnum Payment = 00
fromEnum AccountSet = 03
fromEnum SetRegularKey = 05
fromEnum OfferCreate = 07
fromEnum OfferCancel = 08
fromEnum Sign = 09
fromEnum TrustSet = 20
fromEnum (OtherTransaction x) = fromEnum x
newtype VariableLengthData = VariableLengthData LZ.ByteString
deriving (Show, Eq)
instance Binary VariableLengthData where
get = do
tag <- getWord8
len <- select (fail "could not determine length of VariableLengthData") [
(tag < 193, return $ fromIntegral tag),
(tag < 241, do
tag2 <- getWord8
return $
193 + ((fromIntegral tag 193)*256) +
fromIntegral tag2
),
(tag < 255, do
(tag2, tag3) <- (,) <$> getWord8 <*> getWord8
return $
12481 + ((fromIntegral tag 241)*65536) +
(fromIntegral tag2 * 256) + fromIntegral tag3
)
]
VariableLengthData <$> getLazyByteString len
put (VariableLengthData bytes) =
mapM_ (putWord8.fromIntegral) tag >> putLazyByteString bytes
where
tag
| l < 193 = [l]
| l < 16320 = [(l2 `div` 256) + 193, l2 `mod` 256]
| l < 995520 = [(l3 `div` 65536) + 241, (l3 `mod` 65536) `div` 256, (l3 `mod` 65536) `mod` 256]
| otherwise = error "Data too long for VariableLengthData"
l3 = l 12481
l2 = l 193
l = LZ.length bytes
data TypedField =
TF1 Word16 |
TF2 Word32 |
TF3 Word64 |
TF4 Word128 |
TF5 Word256 |
TF6 Amount |
TF7 LZ.ByteString |
TF8 RippleAddress |
TF14 [Field] |
TF15 [Field] |
TF16 Word8 |
TF17 Word160 |
TF18 PathSet |
TF19 [Word256]
deriving (Show, Eq)
putTF :: TypedField -> (Word8, Put)
putTF (TF1 x) = (01, put x)
putTF (TF2 x) = (02, put x)
putTF (TF3 x) = (03, put x)
putTF (TF4 x) = (04, put x)
putTF (TF5 x) = (05, put x)
putTF (TF6 x) = (05, put x)
putTF (TF7 x) = (07, put $ VariableLengthData x)
putTF (TF8 x) = (08, putWord8 20 >> put x)
putTF (TF14 x) = (14, mapM_ put x >> putWord8 0xE1)
putTF (TF15 x) = (15, mapM_ put x >> putWord8 0xF1)
putTF (TF16 x) = (16, put x)
putTF (TF17 x) = (17, put x)
putTF (TF18 x) = (18, put x)
putTF (TF19 x) = (19, put $ VariableLengthData $ LZ.concat (map encode x))
getTF :: Word8 -> Get TypedField
getTF 01 = TF1 <$> get
getTF 02 = TF2 <$> get
getTF 03 = TF3 <$> get
getTF 04 = TF4 <$> get
getTF 05 = TF5 <$> get
getTF 06 = TF6 <$> get
getTF 07 = (\(VariableLengthData x) -> TF7 x) <$> get
getTF 08 = TF8 <$> do
len <- getWord8
when (len /= 20) $
fail $ "RippleAddress is 160 bit encoding, len is " ++ show len
get
getTF 14 = TF14 <$> getInnerObject
getTF 15 = TF15 <$> getInnerArray
getTF 16 = TF16 <$> get
getTF 17 = TF17 <$> get
getTF 18 = TF18 <$> get
getTF x = error $ "Unknown type for TypedField: " ++ show x
getInnerObject :: Get [Field]
getInnerObject = do
maybeEmpty <- lookAheadM (fmap isEnd getWord8)
case maybeEmpty of
Just () -> return []
Nothing -> (:) <$> get <*> getInnerObject
where
isEnd 0xE1 = Just ()
isEnd _ = Nothing
getInnerArray :: Get [Field]
getInnerArray = do
maybeEmpty <- lookAheadM (fmap isEnd getWord8)
case maybeEmpty of
Just () -> return []
Nothing -> (:) <$> get <*> getInnerArray
where
isEnd 0xF1 = Just ()
isEnd _ = Nothing
data Field =
LedgerEntryType Word16 |
TransactionType TransactionType |
Flags Word32 |
SourceTag Word32 |
SequenceNumber Word32 |
PreviousTransactionLedgerSequence Word32 |
LedgerSequence Word32 |
LedgerCloseTime Word32 |
ParentLedgerCloseTime Word32 |
SigningTime Word32 |
ExpirationTime Word32 |
TransferRate Word32 |
WalletSize Word32 |
OwnerCount Word32 |
DestinationTag Word32 |
LedgerHash Word256 |
ParentHash Word256 |
TransactionHash Word256 |
AccountHash Word256 |
PreviousTxnID Word256 |
LedgerIndex Word256 |
WalletLocator Word256 |
RootIndex Word256 |
AccountTxnID Word256 |
InvoiceID Word256 |
Amount Amount |
Balance Amount |
Limit Amount |
TakerPays Amount |
TakerGets Amount |
LowLimit Amount |
HighLimit Amount |
Fee Amount |
SendMaximum Amount |
DeliveredAmount Amount |
PublicKey LZ.ByteString |
MessageKey LZ.ByteString |
SigningPublicKey LZ.ByteString |
TransactionSignature LZ.ByteString |
Generator LZ.ByteString |
Signature LZ.ByteString |
Domain LZ.ByteString |
FundScript LZ.ByteString |
RemoveScript LZ.ByteString |
ExpireScript LZ.ByteString |
CreateScript LZ.ByteString |
LedgerCloseTimeResolution Word8 |
Account RippleAddress |
Owner RippleAddress |
Destination RippleAddress |
Issuer RippleAddress |
Target RippleAddress |
AuthorizedKey RippleAddress |
ModifiedNode [Field] |
AffectedNodes [Field] |
TemplateEntryType Word8 |
TransactionResult Word8 |
UnknownField Word8 TypedField
deriving (Show, Eq)
instance Ord Field where
compare x y = compare (tagPair x) (tagPair y)
where
tagPair f = let (tag, tf) = ungetField f in
(fst $ putTF tf, tag)
instance Binary Field where
get = do
tag <- getWord8
typ <- case tag `shiftR` 4 of
0 -> get
t -> return t
fld <- case tag .&. 0x0F of
0 -> get
t -> return t
tf <- getTF typ
return $ getField fld tf
put fld = mapM_ put header >> dta
where
header
| typ < 16 && tag < 16 = [(typ `shiftL` 4) .|. tag]
| typ < 16 = [typ `shiftL` 4, tag]
| tag < 16 = [tag, typ]
| otherwise = [0, typ, tag]
(typ, dta) = putTF tf
(tag, tf) = ungetField fld
getField :: Word8 -> TypedField -> Field
getField 01 (TF1 x) = LedgerEntryType x
getField 02 (TF1 x) = TransactionType $ toEnum $ fromEnum x
getField 02 (TF2 x) = Flags x
getField 03 (TF2 x) = SourceTag x
getField 04 (TF2 x) = SequenceNumber x
getField 05 (TF2 x) = PreviousTransactionLedgerSequence x
getField 06 (TF2 x) = LedgerSequence x
getField 07 (TF2 x) = LedgerCloseTime x
getField 08 (TF2 x) = ParentLedgerCloseTime x
getField 09 (TF2 x) = SigningTime x
getField 10 (TF2 x) = ExpirationTime x
getField 11 (TF2 x) = TransferRate x
getField 12 (TF2 x) = WalletSize x
getField 13 (TF2 x) = OwnerCount x
getField 14 (TF2 x) = DestinationTag x
getField 01 (TF5 x) = LedgerHash x
getField 02 (TF5 x) = ParentHash x
getField 03 (TF5 x) = TransactionHash x
getField 04 (TF5 x) = AccountHash x
getField 05 (TF5 x) = PreviousTxnID x
getField 06 (TF5 x) = LedgerIndex x
getField 07 (TF5 x) = WalletLocator x
getField 08 (TF5 x) = RootIndex x
getField 09 (TF5 x) = AccountTxnID x
getField 17 (TF5 x) = InvoiceID x
getField 01 (TF6 x) = Ripple.Transaction.Amount x
getField 02 (TF6 x) = Balance x
getField 03 (TF6 x) = Limit x
getField 04 (TF6 x) = TakerPays x
getField 05 (TF6 x) = TakerGets x
getField 06 (TF6 x) = LowLimit x
getField 07 (TF6 x) = HighLimit x
getField 08 (TF6 x) = Fee x
getField 09 (TF6 x) = SendMaximum x
getField 18 (TF6 x) = DeliveredAmount x
getField 01 (TF7 x) = PublicKey x
getField 02 (TF7 x) = MessageKey x
getField 03 (TF7 x) = SigningPublicKey x
getField 04 (TF7 x) = TransactionSignature x
getField 05 (TF7 x) = Generator x
getField 06 (TF7 x) = Signature x
getField 07 (TF7 x) = Domain x
getField 08 (TF7 x) = FundScript x
getField 09 (TF7 x) = RemoveScript x
getField 10 (TF7 x) = ExpireScript x
getField 11 (TF7 x) = CreateScript x
getField 01 (TF8 x) = Account x
getField 02 (TF8 x) = Owner x
getField 03 (TF8 x) = Destination x
getField 04 (TF8 x) = Issuer x
getField 05 (TF8 x) = Target x
getField 06 (TF8 x) = AuthorizedKey x
getField 05 (TF14 x) = ModifiedNode x
getField 08 (TF15 x) = AffectedNodes x
getField 01 (TF16 x) = LedgerCloseTimeResolution x
getField 02 (TF16 x) = TemplateEntryType x
getField 03 (TF16 x) = TransactionResult x
getField tag tf = UnknownField tag tf
ungetField :: Field -> (Word8, TypedField)
ungetField (LedgerEntryType x) = (01, TF1 x)
ungetField (TransactionType x) = (02, TF1 $ toEnum $ fromEnum x)
ungetField (Flags x) = (02, TF2 x)
ungetField (SourceTag x) = (03, TF2 x)
ungetField (SequenceNumber x) = (04, TF2 x)
ungetField (PreviousTransactionLedgerSequence x) = (05, TF2 x)
ungetField (LedgerSequence x) = (06, TF2 x)
ungetField (LedgerCloseTime x) = (07, TF2 x)
ungetField (ParentLedgerCloseTime x) = (08, TF2 x)
ungetField (SigningTime x) = (09, TF2 x)
ungetField (ExpirationTime x) = (10, TF2 x)
ungetField (TransferRate x) = (11, TF2 x)
ungetField (WalletSize x) = (12, TF2 x)
ungetField (OwnerCount x) = (13, TF2 x)
ungetField (DestinationTag x) = (14, TF2 x)
ungetField (LedgerHash x) = (01, TF5 x)
ungetField (ParentHash x) = (02, TF5 x)
ungetField (TransactionHash x) = (03, TF5 x)
ungetField (AccountHash x) = (04, TF5 x)
ungetField (PreviousTxnID x) = (05, TF5 x)
ungetField (LedgerIndex x) = (06, TF5 x)
ungetField (WalletLocator x) = (07, TF5 x)
ungetField (RootIndex x) = (08, TF5 x)
ungetField (AccountTxnID x) = (09, TF5 x)
ungetField (InvoiceID x) = (17, TF5 x)
ungetField (Ripple.Transaction.Amount x) = (01, TF6 x)
ungetField (Balance x) = (02, TF6 x)
ungetField (Limit x) = (03, TF6 x)
ungetField (TakerPays x) = (04, TF6 x)
ungetField (TakerGets x) = (05, TF6 x)
ungetField (LowLimit x) = (06, TF6 x)
ungetField (HighLimit x) = (07, TF6 x)
ungetField (Fee x) = (08, TF6 x)
ungetField (SendMaximum x) = (09, TF6 x)
ungetField (DeliveredAmount x) = (18, TF6 x)
ungetField (PublicKey x) = (01, TF7 x)
ungetField (MessageKey x) = (02, TF7 x)
ungetField (SigningPublicKey x) = (03, TF7 x)
ungetField (TransactionSignature x) = (04, TF7 x)
ungetField (Generator x) = (05, TF7 x)
ungetField (Signature x) = (06, TF7 x)
ungetField (Domain x) = (07, TF7 x)
ungetField (FundScript x) = (08, TF7 x)
ungetField (RemoveScript x) = (09, TF7 x)
ungetField (ExpireScript x) = (10, TF7 x)
ungetField (CreateScript x) = (11, TF7 x)
ungetField (Account x) = (01, TF8 x)
ungetField (Owner x) = (02, TF8 x)
ungetField (Destination x) = (03, TF8 x)
ungetField (Issuer x) = (04, TF8 x)
ungetField (Target x) = (05, TF8 x)
ungetField (AuthorizedKey x) = (06, TF8 x)
ungetField (ModifiedNode x) = (05, TF14 x)
ungetField (AffectedNodes x) = (08, TF15 x)
ungetField (LedgerCloseTimeResolution x) = (01, TF16 x)
ungetField (TemplateEntryType x) = (02, TF16 x)
ungetField (TransactionResult x) = (03, TF16 x)
ungetField (UnknownField tag tf) = (tag, tf)
newtype Transaction = Transaction [Field]
deriving (Show, Eq)
instance Binary Transaction where
get = Transaction <$> listUntilEnd
put (Transaction fs) = mapM_ put (sort fs)
listUntilEnd :: (Binary a) => Get [a]
listUntilEnd = do
done <- isEmpty
if done then return [] else do
next <- get
rest <- listUntilEnd
return (next:rest)
instance Aeson.FromJSON Transaction where
parseJSON (Aeson.Object o) = Transaction <$> do
txhash <- fmap (>>= fmap TransactionHash . hexMay) (k "hash")
account <- fmap (>>= fmap Account . readMay) (k "Account")
amount <- (fmap.fmap) Ripple.Transaction.Amount (k "Amount")
destination <- fmap (>>= fmap Destination . readMay) (k "Destination")
fee <- (fmap.fmap) Fee (k "Fee")
flags <- (fmap.fmap) Flags (k "Flags")
sendMax <- (fmap.fmap) SendMaximum (k "SendMax")
sequence <- (fmap.fmap) SequenceNumber (k "Sequence")
typ <- fmap (>>= fmap TransactionType . readMay) (k "TransactionType")
delivered <- (fmap.fmap) DeliveredAmount (k "DeliveredAmount")
result <- fmap (>>= fmap TransactionResult . tRes) (k "TransactionResult")
dt <- (fmap.fmap) DestinationTag (k "DestinationTag")
invoiceid <- fmap (>>= fmap InvoiceID . hexMay) (k "InvoiceID")
date <- fmap (>>= fmap SigningTime) (k "date")
return $ catMaybes [
txhash, account, amount, destination, fee, flags, sendMax, sequence,
typ, delivered, result, dt, invoiceid, date
]
where
k s = o .:? T.pack s
parseJSON _ = fail "Transaction is always a JSON object"
hexMay :: (Eq a, Num a) => String -> Maybe a
hexMay s = case readHex s of
[(x, "")] -> Just x
_ -> Nothing
tRes :: String -> Maybe Word8
tRes ('t':'e':'s':_) = Just 0
tRes ('t':'e':'c':_) = Just 100
tRes ('t':'e':'r':_) = Just (99)
tRes ('t':'e':'f':_) = Just (199)
tRes ('t':'e':'m':_) = Just (299)
tRes ('t':'e':'l':_) = Just (399)
tRes _ = Nothing