ripple 0.1 → 0.2
raw patch · 5 files changed
+291/−32 lines, 5 filesdep +transformersdep ~binary
Dependencies added: transformers
Dependency ranges changed: binary
Files
- Ripple/Amount.hs +21/−6
- Ripple/Path.hs +75/−0
- Ripple/Transaction.hs +122/−5
- Ripple/WebSockets.hs +69/−19
- ripple.cabal +4/−2
Ripple/Amount.hs view
@@ -1,6 +1,7 @@ module Ripple.Amount ( Amount(..),- Currency(..)+ Currency(..),+ CurrencySpecifier(..) ) where import Control.Monad@@ -28,11 +29,26 @@ instance Binary Currency where get = do+ CurrencySpecifier code <- get+ issuer <- get++ return $ Currency code issuer++ put XRP = fail "XRP does not get encoded as a currency specifier."+ put (Currency code issuer) = do+ put $ CurrencySpecifier code+ put issuer++-- | The raw 160-bit currency specifier, no issuer+newtype CurrencySpecifier = CurrencySpecifier (Char,Char,Char)+ deriving (Show, Eq)++instance Binary CurrencySpecifier where+ get = do allZero <- getLazyByteString 12 currency <- getLazyByteString 3 version <- getLazyByteString 2 reserved <- getLazyByteString 3- issuer <- get when (LZ.any (/=0) allZero) (fail "Bad currency format az") when (LZ.any (/=0) version) (fail "Bad currency format ver")@@ -40,17 +56,16 @@ -- Spec says ASCII let [a,b,c] = map (toEnum.fromIntegral) $ LZ.unpack currency- return $ Currency (a,b,c) issuer - put XRP = fail "XRP does not get encoded as a currency specifier."- put (Currency (a,b,c) issuer) = do+ return $ CurrencySpecifier (a,b,c)++ put (CurrencySpecifier (a,b,c)) = do replicateM_ 12 (putWord8 0) putWord8 $ fromIntegral $ fromEnum a putWord8 $ fromIntegral $ fromEnum b putWord8 $ fromIntegral $ fromEnum c replicateM_ 2 (putWord8 0) replicateM_ 3 (putWord8 0)- put issuer data Amount = Amount Rational Currency deriving (Eq)
+ Ripple/Path.hs view
@@ -0,0 +1,75 @@+module Ripple.Path (PathSet(..), Path(..), PathEntry(..)) where++import Data.Bits ((.&.), (.|.))+import Data.List (find)+import Control.Arrow (first, second)+import Control.Applicative ((<$>), (<*>))+import Data.Word (Word8)+import Data.Binary (Binary(..), Get, putWord8, getWord8)+import Data.Binary.Get (lookAheadM)+import Data.Base58Address (RippleAddress)++import Ripple.Amount (CurrencySpecifier)++newtype PathSet = PathSet [Path]+ deriving (Show, Eq)++instance Binary PathSet where+ get = do+ maybeEmpty <- lookAheadM (maybeGetWord8 [0x00])+ case maybeEmpty of+ Just _ -> return (PathSet [Path []])+ _ -> PathSet <$> getPaths++ put (PathSet []) = fail "Empty PathSet is not allowed"+ put (PathSet (Path entries : [])) = do+ mapM_ put entries+ putWord8 0x00+ put (PathSet (Path entries : ps)) = do+ mapM_ put entries+ putWord8 0xFF+ put (PathSet ps)++getPaths :: Get [Path]+getPaths = do+ (done, path) <- getEntries+ if done then return [Path path] else+ getPaths >>= \rest -> return (Path path : rest)++getEntries :: Get (Bool, [PathEntry])+getEntries = do+ entry <- get+ nextOrDone <- lookAheadM (maybeGetWord8 [0xFF,0x00])+ case nextOrDone of+ Just 0x00 -> return (True, [entry])+ Just 0xFF -> return (False, [entry])+ _ -> getEntries >>= \(done, rest) -> return (done, entry:rest)++newtype Path = Path [PathEntry]+ deriving (Show, Eq)++data PathEntry = PathEntry {+ account :: Maybe RippleAddress,+ toCurrency :: Maybe CurrencySpecifier,+ issuer :: Maybe RippleAddress+ } deriving (Show, Eq)++instance Binary PathEntry where+ get = getWord8 >>= \typ -> PathEntry <$>+ (if typ .&. 0x01 == 0x01 then Just <$> get else return Nothing) <*>+ (if typ .&. 0x10 == 0x10 then Just <$> get else return Nothing) <*>+ (if typ .&. 0x20 == 0x20 then Just <$> get else return Nothing)++ put (PathEntry Nothing Nothing Nothing) =+ fail "Invalid empty PathEntry"+ put (PathEntry account currency issuer) = putWord8 typ >> dta+ where+ (dta, typ) = first sequence_ $ second (foldr (.|.) 0x00) $ unzip [+ maybePut 0x01 account,+ maybePut 0x10 currency,+ maybePut 0x20 issuer+ ]+ maybePut tag = maybe (return (), 0x00) (\x -> (put x, tag))++maybeGetWord8 :: [Word8] -> Get (Maybe Word8)+maybeGetWord8 ws = fmap (\w -> find (==w) ws) getWord8
Ripple/Transaction.hs view
@@ -4,25 +4,33 @@ 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)+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, Eq)+ deriving (Show, Read, Eq) instance Enum TransactionType where toEnum 00 = Payment@@ -39,7 +47,7 @@ fromEnum SetRegularKey = 05 fromEnum OfferCreate = 07 fromEnum OfferCancel = 08- fromEnum Sign = 09+ fromEnum Sign = 09 fromEnum TrustSet = 20 fromEnum (OtherTransaction x) = fromEnum x @@ -87,10 +95,11 @@ TF6 Amount | TF7 LZ.ByteString | TF8 RippleAddress |- TF14 [TypedField] |- TF15 [[TypedField]] |+ TF14 [Field] |+ TF15 [Field] | TF16 Word8 | TF17 Word160 |+ TF18 PathSet | TF19 [Word256] deriving (Show, Eq) @@ -103,8 +112,11 @@ 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@@ -120,10 +132,33 @@ 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 |@@ -138,6 +173,18 @@ 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 |@@ -147,6 +194,7 @@ HighLimit Amount | Fee Amount | SendMaximum Amount |+ DeliveredAmount Amount | PublicKey LZ.ByteString | MessageKey LZ.ByteString | SigningPublicKey LZ.ByteString |@@ -165,6 +213,8 @@ Issuer RippleAddress | Target RippleAddress | AuthorizedKey RippleAddress |+ ModifiedNode [Field] |+ AffectedNodes [Field] | TemplateEntryType Word8 | TransactionResult Word8 | UnknownField Word8 TypedField@@ -212,6 +262,18 @@ 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@@ -221,6 +283,7 @@ 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@@ -238,6 +301,8 @@ 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@@ -257,6 +322,18 @@ 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)@@ -266,6 +343,7 @@ 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)@@ -283,6 +361,8 @@ 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)@@ -303,3 +383,40 @@ rest <- listUntilEnd return (next:rest) {-# INLINE listUntilEnd #-}++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")+ return $ catMaybes [+ txhash, account, amount, destination, fee, flags, sendMax, sequence,+ typ, delivered, result, dt, invoiceid+ ]+ 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 -- 100 .. 199+tRes ('t':'e':'r':_) = Just (-99) -- -99 .. -1+tRes ('t':'e':'f':_) = Just (-199) -- -199 .. -100+tRes ('t':'e':'m':_) = Just (-299) -- -299 .. -200+tRes ('t':'e':'l':_) = Just (-399) -- -399 .. -300+tRes _ = Nothing
Ripple/WebSockets.hs view
@@ -5,13 +5,17 @@ -- * Ripple JSON result parsing and error handling RippleError(..), RippleResult(..),+ getRippleResult, -- * ripple_path_find CommandRipplePathFind(..), ResultRipplePathFind(..), Alternative(..), -- * account_tx CommandAccountTX(..),- ResultAccountTX(..)+ ResultAccountTX(..),+ -- * ledger_closed+ CommandLedgerClosed(..),+ ResultLedgerClosed(..) ) where import Numeric (readHex)@@ -19,9 +23,10 @@ import Data.Word (Word8) import Control.Applicative ((<$>), (<*>)) import Control.Monad (forM)-import Control.Error (note, fmapL, readZ)+import Control.Error (note, fmapL, readZ, justZ) import Data.Base58Address (RippleAddress) import Data.Binary (decodeOrFail)+import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Aeson ((.=), (.:), (.:?)) import qualified Data.Aeson as Aeson@@ -34,17 +39,18 @@ -- Base WebSocket helpers -receiveJSON :: (Aeson.FromJSON j) => WS.Connection -> IO (Either String j)-receiveJSON = fmap Aeson.eitherDecode . WS.receiveData+receiveJSON :: (Aeson.FromJSON j, MonadIO m) => WS.Connection -> m (Either String j)+receiveJSON = liftIO . fmap Aeson.eitherDecode . WS.receiveData -sendJSON :: (Aeson.ToJSON j) => WS.Connection -> j -> IO ()-sendJSON conn = WS.sendTextData conn . Aeson.encode+sendJSON :: (Aeson.ToJSON j, MonadIO m) => WS.Connection -> j -> m ()+sendJSON conn = liftIO . WS.sendTextData conn . Aeson.encode -- Ripple JSON result parsing and error handling -- | Ripple server error codes data RippleError = UnknownCommand |+ ResponseParseError String | OtherRippleError Int String String deriving (Show, Eq) @@ -52,6 +58,10 @@ newtype RippleResult a = RippleResult (Either RippleError a) deriving (Show, Eq) +getRippleResult :: Either String (RippleResult a) -> Either RippleError a+getRippleResult (Left e) = Left $ ResponseParseError e+getRippleResult (Right (RippleResult x)) = x+ instance (Aeson.FromJSON a) => Aeson.FromJSON (RippleResult a) where parseJSON (Aeson.Object o) = RippleResult <$> do status <- o .: T.pack "status"@@ -109,24 +119,26 @@ data CommandAccountTX = CommandAccountTX { account :: RippleAddress, limit :: Int,- ledgerIndexMin :: Maybe Int,- ledgerIndexMax :: Maybe Int,+ offset :: Maybe Int,+ ledgerIndexMin :: Maybe Integer,+ ledgerIndexMax :: Maybe Integer, descending :: Bool, binary :: Bool } instance Aeson.ToJSON CommandAccountTX where- toJSON (CommandAccountTX account lim min max desc bin) = Aeson.object [+ toJSON (CommandAccountTX account lim off min max desc bin) = Aeson.object [ T.pack "command" .= "account_tx", T.pack "account" .= show account, T.pack "ledger_index_min" .= fromMaybe (-1) min, T.pack "ledger_index_max" .= fromMaybe (-1) max, T.pack "binary" .= bin, T.pack "limit" .= lim,+ T.pack "offset" .= fromMaybe 0 off, T.pack "descending" .= desc ] --- | [(ledger_index, transaction)]+-- | [(ledger_index, transaction+meta)] data ResultAccountTX = ResultAccountTX [(Integer,Transaction)] deriving (Show, Eq) @@ -134,18 +146,56 @@ parseJSON (Aeson.Object o) = ResultAccountTX <$> do transactions <- o .: T.pack "transactions" forM transactions $ \transaction -> do- True <- transaction .: T.pack "validated"- ledger <- transaction .: T.pack "ledger_index"- blob <- transaction .:? T.pack "tx_blob" -- binary transaction+ True <- transaction .: T.pack "validated"+ mblob <- transaction .:? T.pack "tx_blob" -- binary transaction+ mtx <- transaction .:? T.pack "tx" -- json transaction - tr <- either fail return $ do- hex <- note "JSON transactions not implemented yet" blob- bytes <- note "Invalid Hexidecimal encoding" $ hex2bytes hex- fmapL (\(_,_,e) -> e) $ fmap (\(_,_,r) -> r) $- decodeOrFail (LZ.pack bytes)+ case (mblob, mtx) of+ (Just blob, Nothing) -> do+ meta <- transaction .: T.pack "meta"+ tr <- either fail return $ do+ bytes <- note "Invalid Hexidecimal encoding" $ hex2bytes blob+ Transaction tr <- fmapL (\(_,_,e)->e) $ fmap (\(_,_,r)->r) $+ decodeOrFail (LZ.pack bytes) - return (ledger, tr)+ bytes <- note "Invalid Hexidecimal encoding" $ hex2bytes meta+ Transaction mta <- fmapL (\(_,_,e)->e) $ fmap (\(_,_,r)->r) $+ decodeOrFail (LZ.pack bytes)++ return $ Transaction (tr ++ mta)++ ledger <- transaction .: T.pack "ledger_index"+ return (ledger, tr)++ (Nothing, Just (Transaction tx)) -> do+ Transaction meta <- transaction .: T.pack "meta"+ Aeson.Object txo <- transaction .: T.pack "tx"+ ledger <- txo .: T.pack "ledger_index"+ return (ledger, Transaction (tx ++ meta))++ (Just _, Just _) -> fail "tx or tx_blob required (not both)"+ _ -> fail "tx or tx_blob required"+ parseJSON _ = fail "account_tx result is always a JSON object"++-- ledger_closed++data CommandLedgerClosed = CommandLedgerClosed+ deriving (Show, Eq)++instance Aeson.ToJSON CommandLedgerClosed where+ toJSON CommandLedgerClosed = Aeson.object [+ T.pack "command" .= "ledger_closed"+ ]++data ResultLedgerClosed = ResultLedgerClosed LZ.ByteString Integer+ deriving (Show, Eq)++instance Aeson.FromJSON ResultLedgerClosed where+ parseJSON (Aeson.Object o) = ResultLedgerClosed <$>+ (fmap LZ.pack . justZ . hex2bytes =<< o .: T.pack "ledger_hash") <*>+ (o .: T.pack "ledger_index")+ parseJSON _ = fail "ledger_closed result is always a JSON object" -- Helpers
ripple.cabal view
@@ -1,5 +1,5 @@ name: ripple-version: 0.1+version: 0.2 cabal-version: >= 1.8 license: OtherLicense license-file: COPYING@@ -22,6 +22,7 @@ library exposed-modules: Ripple.Amount+ Ripple.Path Ripple.Seed Ripple.Sign Ripple.Transaction@@ -32,8 +33,9 @@ utility-ht, bytestring, text,+ transformers, largeword >= 1.1.0,- binary,+ binary >= 0.7.0.0, cereal, aeson, attoparsec,