ripple (empty) → 0.1
raw patch · 9 files changed
+749/−0 lines, 9 filesdep +aesondep +attoparsecdep +basesetup-changed
Dependencies added: aeson, attoparsec, base, base58address, binary, bytestring, cereal, crypto-api, crypto-pubkey-types, cryptohash-cryptoapi, ecdsa, errors, largeword, text, utility-ht, websockets
Files
- COPYING +13/−0
- README +1/−0
- Ripple/Amount.hs +140/−0
- Ripple/Seed.hs +39/−0
- Ripple/Sign.hs +41/−0
- Ripple/Transaction.hs +305/−0
- Ripple/WebSockets.hs +157/−0
- Setup.hs +3/−0
- ripple.cabal +50/−0
+ COPYING view
@@ -0,0 +1,13 @@+Copyright © 2013-2014, Stephen Paul Weber <singpolyma.net>++Permission to use, copy, modify, and/or distribute this software for any+purpose with or without fee is hereby granted, provided that the above+copyright notice and this permission notice appear in all copies.++THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES+WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR+ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES+WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN+ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF+OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ README view
@@ -0,0 +1,1 @@+Interact with Ripple servers, sign transactions, etc.
+ Ripple/Amount.hs view
@@ -0,0 +1,140 @@+module Ripple.Amount (+ Amount(..),+ Currency(..)+) where++import Control.Monad+import Control.Applicative+import Data.Bits+import Data.Word+import Data.Binary (Binary(..), Get, putWord8)+import Data.Binary.Get (getLazyByteString)+import Data.Base58Address (RippleAddress)+import Control.Error (readZ)+import qualified Data.ByteString.Lazy as LZ+import qualified Data.Text as T++import Data.Aeson ((.=), (.:))+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Types as Aeson+import qualified Data.Attoparsec.Number as Aeson++data Currency = XRP | Currency (Char,Char,Char) RippleAddress+ deriving (Eq)++instance Show Currency where+ show XRP = "XRP"+ show (Currency (a,b,c) adr) = [a,b,c,'/'] ++ show adr++instance Binary Currency 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")+ when (LZ.any (/=0) reserved) (fail "Bad currency format res")++ -- 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+ 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)++instance Show Amount where+ show (Amount a c) =+ show (realToFrac a :: Double) ++ "/" ++ show c++instance Aeson.ToJSON Amount where+ toJSON (Amount v XRP) = Aeson.toJSON $ show (floor (v * one_drop) :: Integer)+ toJSON (Amount v (Currency (a,b,c) issuer)) = Aeson.object [+ T.pack "value" .= show (realToFrac v :: Double),+ T.pack "currency" .= [a,b,c],+ T.pack "issuer" .= show issuer+ ]++instance Aeson.FromJSON Amount where+ parseJSON (Aeson.Object o) = do+ amountVal <- o .: T.pack "value"+ amount <- realToFrac <$> case amountVal of+ Aeson.Number n ->+ Aeson.parseJSON (Aeson.Number n) :: Aeson.Parser Double+ Aeson.String s ->+ readZ (T.unpack s) :: Aeson.Parser Double+ _ -> fail "No valid amount"+ currency <- o .: T.pack "currency"+ guard (length currency == 3 && currency /= "XRP")+ issuer <- readZ =<< o .: T.pack "issuer"++ let [a,b,c] = currency+ return $ Amount amount (Currency (a,b,c) issuer)+ parseJSON (Aeson.Number (Aeson.I n)) = pure $ Amount (fromIntegral n) XRP+ parseJSON (Aeson.Number (Aeson.D n)) = pure $ Amount (one_drop * realToFrac n) XRP+ parseJSON (Aeson.String s) = case T.find (=='.') s of+ Nothing -> (Amount . realToFrac) <$>+ (readZ (T.unpack s) :: Aeson.Parser Integer) <*> pure XRP+ Just _ -> (\x -> Amount (realToFrac x * one_drop)) <$>+ (readZ (T.unpack s) :: Aeson.Parser Double) <*> pure XRP+ parseJSON _ = fail "Invalid amount"++instance Binary Amount where+ get = do+ value <- get :: Get Word64+ if testBit value 63 then+ (flip Amount <$> get <*>) $ pure $+ case (clearBit (clearBit value 63) 62 `shiftR` 54, value .&. 0x003FFFFFFFFFFFFF) of+ (0,0) -> 0+ (e,m) ->+ (if testBit value 62 then 1 else -1) *+ fromIntegral m * (10 ^^ (fromIntegral e + exp_min - 1))+ else+ return $ (`Amount` XRP) $+ (if testBit value 62 then 1 else -1) *+ (fromIntegral (clearBit value 62) / one_drop)++ put (Amount value XRP) =+ put $ (if value >= 0 then (`setBit` 62) else id) drops+ where+ drops = floor $ abs $ value * one_drop :: Word64+ put (Amount 0 currency) = do+ put (setBit (0 :: Word64) 63)+ put currency+ put (Amount value currency)+ | value > 0 = put (setBit encoded 62) >> put currency+ | otherwise = put encoded >> put currency+ where+ encoded = setBit ((e8 `shiftL` 54) .|. m64) 63+ e8 = fromIntegral (fromIntegral (e-exp_min+1) :: Word8) -- to get the bits+ m64 = fromIntegral m :: Word64+ (m,e) = until ((>= man_min_value) . fst) (\(m,e) -> (m*10,e-1)) $+ until ((<= man_max_value) . fst) (\(m,e) -> (m`div`10,e+1))+ (abs $ floor (value * (10 ^^ exp_max)), -exp_max)++one_drop :: Rational+one_drop = 1000000++exp_max :: Integer+exp_max = 80++exp_min :: Integer+exp_min = -96++man_max_value :: Integer+man_max_value = 9999999999999999++man_min_value :: Integer+man_min_value = 1000000000000000
+ Ripple/Seed.hs view
@@ -0,0 +1,39 @@+module Ripple.Seed (getSecret) where++import Data.Word+import Data.Base58Address (RippleAddress, rippleAddressPayload)+import Crypto.Hash.CryptoAPI (SHA512, hash')+import qualified Data.ByteString as BS+import qualified Data.Serialize as Serialize++import Crypto.Types.PubKey.ECC (Curve(CurveFP), CurvePrime(..), CurveCommon(..), getCurveByName, CurveName(SEC_p256k1))++import Crypto.Util (bs2i, i2bs_unsized)++import ECDSA (publicFromPrivate, publicToBytes, PrivateKey(..))++-- n is the order of the base point+n :: Integer+p256k1 :: Curve+p256k1@(CurveFP (CurvePrime _ (CurveCommon {ecc_n = n}))) = getCurveByName SEC_p256k1++-- | Derive the secret key for the given secret seed and address+getSecret ::+ RippleAddress -- ^ Secret seed address+ -> PrivateKey+getSecret seed = PrivateKey p256k1 d+ where+ d = (sec + priv) `mod` n+ sec = bs2i $ gen (pub `BS.append` seq)+ pub = publicToBytes $ publicFromPrivate $ PrivateKey p256k1 priv+ priv = bs2i $ gen sbytes+ sbytes = i2bs_unsized (rippleAddressPayload seed)+ seq = Serialize.encode (0 :: Word32)++gen :: BS.ByteString -> BS.ByteString+gen bytes = fst $ until (\(x,_) -> n >= bs2i x) (\(_,i) -> (go i,i+1)) (go 0, 1)+ where+ go i = halfOfSHA512 $ hash' (bytes `BS.append` Serialize.encode (i :: Word32))++halfOfSHA512 :: SHA512 -> BS.ByteString+halfOfSHA512 sha512 = BS.take 32 $ Serialize.encode sha512
+ Ripple/Sign.hs view
@@ -0,0 +1,41 @@+module Ripple.Sign (signTransaction) where++import Data.Word (Word32)+import Control.Applicative ((<$>))+import Control.Arrow (first)+import Data.Binary (encode)+import qualified Data.Serialize as Serialize+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LZ++import Crypto.Hash.CryptoAPI (SHA512, Hash(..), hash)+import Crypto.Types.PubKey.ECDSA (PrivateKey(..))+import Crypto.Random (CryptoRandomGen, GenError)+import ECDSA (sign, publicToBytes, publicFromPrivate, signatureEncodeDER)++import Ripple.Transaction++signTransaction :: (CryptoRandomGen g) =>+ Transaction -> PrivateKey -> g -> Either GenError (Transaction, g)+signTransaction (Transaction fs) private g =+ first (addSig . signatureEncodeDER) <$> sign private hash g+ where+ addSig s = Transaction ((TransactionSignature $ LZ.fromChunks [s]) : fs')+ hash = signing_hash (Transaction fs')+ fs' = SigningPublicKey publicKey : filter (not.isSPK) fs+ publicKey = LZ.fromChunks [publicToBytes $ publicFromPrivate private]++isSPK :: Field -> Bool+isSPK (SigningPublicKey {}) = True+isSPK _ = False++hash_sign :: Word32+hash_sign = 0x53545800++compute_hash :: (Hash ctx d) => Transaction -> d+compute_hash t = hash (encode hash_sign `LZ.append` encode t)++signing_hash :: Transaction -> BS.ByteString+signing_hash t = BS.take 32 $ Serialize.encode sha512+ where+ sha512 = compute_hash t :: SHA512
+ Ripple/Transaction.hs view
@@ -0,0 +1,305 @@+module Ripple.Transaction (+ Transaction(..),+ TransactionType(..),+ Field(..)+) where++import Control.Monad+import Control.Applicative+import Data.List+import Data.Word+import Data.LargeWord+import Data.Bits+import Data.Binary (Binary(..), Put, Get, putWord8, getWord8, encode)+import Data.Binary.Get (isEmpty, getLazyByteString)+import Data.Binary.Put (putLazyByteString)+import Data.Bool.HT (select)+import Data.Base58Address (RippleAddress)+import qualified Data.ByteString.Lazy as LZ++import Ripple.Amount++data TransactionType =+ Payment | AccountSet | SetRegularKey | OfferCreate | OfferCancel |+ Sign | TrustSet | OtherTransaction Word16+ deriving (Show, 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 [TypedField] |+ TF15 [[TypedField]] |+ TF16 Word8 |+ TF17 Word160 |+ 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 (TF16 x) = (16, put x)+putTF (TF17 x) = (17, 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 16 = TF16 <$> get+getTF 17 = TF17 <$> get+getTF x = error $ "Unknown type for TypedField: " ++ show x++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 |+ Amount Amount |+ Balance Amount |+ Limit Amount |+ TakerPays Amount |+ TakerGets Amount |+ LowLimit Amount |+ HighLimit Amount |+ Fee Amount |+ SendMaximum 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 |+ 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 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 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 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 (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 (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 (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)+{-# INLINE listUntilEnd #-}
+ Ripple/WebSockets.hs view
@@ -0,0 +1,157 @@+module Ripple.WebSockets (+ -- * Base WebSocket helpers+ receiveJSON,+ sendJSON,+ -- * Ripple JSON result parsing and error handling+ RippleError(..),+ RippleResult(..),+ -- * ripple_path_find+ CommandRipplePathFind(..),+ ResultRipplePathFind(..),+ Alternative(..),+ -- * account_tx+ CommandAccountTX(..),+ ResultAccountTX(..)+) where++import Numeric (readHex)+import Data.Maybe (fromMaybe)+import Data.Word (Word8)+import Control.Applicative ((<$>), (<*>))+import Control.Monad (forM)+import Control.Error (note, fmapL, readZ)+import Data.Base58Address (RippleAddress)+import Data.Binary (decodeOrFail)++import Data.Aeson ((.=), (.:), (.:?))+import qualified Data.Aeson as Aeson+import qualified Network.WebSockets as WS+import qualified Data.Text as T+import qualified Data.ByteString.Lazy as LZ++import Ripple.Transaction+import Ripple.Amount++-- Base WebSocket helpers++receiveJSON :: (Aeson.FromJSON j) => WS.Connection -> IO (Either String j)+receiveJSON = fmap Aeson.eitherDecode . WS.receiveData++sendJSON :: (Aeson.ToJSON j) => WS.Connection -> j -> IO ()+sendJSON conn = WS.sendTextData conn . Aeson.encode++-- Ripple JSON result parsing and error handling++-- | Ripple server error codes+data RippleError =+ UnknownCommand |+ OtherRippleError Int String String+ deriving (Show, Eq)++-- | The result of a WebSocket command -- either error or a response+newtype RippleResult a = RippleResult (Either RippleError a)+ deriving (Show, Eq)++instance (Aeson.FromJSON a) => Aeson.FromJSON (RippleResult a) where+ parseJSON (Aeson.Object o) = RippleResult <$> do+ status <- o .: T.pack "status"+ typ <- o .: T.pack "type"+ case (status, typ) of+ ("success", "response") ->+ Right <$> (Aeson.parseJSON =<< o.: T.pack "result")+ ("error", "response") -> do+ err <- o .: T.pack "error"+ code <- o .: T.pack "error_code"+ msg <- o .: T.pack "error_message"+ case code of+ 27 -> return $ Left UnknownCommand+ _ -> return $ Left $ OtherRippleError code err msg+ _ -> fail "Invalid Ripple Result"+ parseJSON _ = fail "Ripple Result is always a JSON object"++-- ripple_path_find++data CommandRipplePathFind = CommandRipplePathFind {+ source_account :: RippleAddress,+ destination_account :: RippleAddress,+ destination_amount :: Amount+ } deriving (Show, Eq)++instance Aeson.ToJSON CommandRipplePathFind where+ toJSON (CommandRipplePathFind source dest amount) = Aeson.object [+ T.pack "command" .= T.pack "ripple_path_find",+ T.pack "source_account" .= show source,+ T.pack "destination_account" .= show dest,+ T.pack "destination_amount" .= amount+ ]++data ResultRipplePathFind = ResultRipplePathFind {+ alternatives :: [Alternative],+ response_destination_account :: RippleAddress+ } deriving (Show, Eq)++instance Aeson.FromJSON ResultRipplePathFind where+ parseJSON (Aeson.Object o) = ResultRipplePathFind <$>+ o .: T.pack "alternatives" <*>+ (readZ =<< o .: T.pack "destination_account")+ parseJSON _ = fail "PathFindResponse is always a JSON object"++data Alternative = Alternative {+ source_amount :: Amount+ } deriving (Show, Eq)++instance Aeson.FromJSON Alternative where+ parseJSON (Aeson.Object o) = Alternative <$> o .: T.pack "source_amount"+ parseJSON _ = fail "Alternative is always a JSON object"++-- account_tx++data CommandAccountTX = CommandAccountTX {+ account :: RippleAddress,+ limit :: Int,+ ledgerIndexMin :: Maybe Int,+ ledgerIndexMax :: Maybe Int,+ descending :: Bool,+ binary :: Bool+ }++instance Aeson.ToJSON CommandAccountTX where+ toJSON (CommandAccountTX account lim 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 "descending" .= desc+ ]++-- | [(ledger_index, transaction)]+data ResultAccountTX = ResultAccountTX [(Integer,Transaction)]+ deriving (Show, Eq)++instance Aeson.FromJSON ResultAccountTX where+ 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++ 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)++ return (ledger, tr)+ parseJSON _ = fail "account_tx result is always a JSON object"++-- Helpers++hex2bytes :: String -> Maybe [Word8]+hex2bytes [] = Just []+hex2bytes (x:y:rest) = case readHex [x,y] of+ [(n, "")] -> fmap (n:) (hex2bytes rest)+ _ -> Nothing+hex2bytes _ = Nothing
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain
+ ripple.cabal view
@@ -0,0 +1,50 @@+name: ripple+version: 0.1+cabal-version: >= 1.8+license: OtherLicense+license-file: COPYING+category: Crypto+copyright: © 2014 Stephen Paul Weber+author: Stephen Paul Weber <singpolyma@singpolyma.net>+maintainer: Stephen Paul Weber <singpolyma@singpolyma.net>+stability: experimental+tested-with: GHC == 7.4.1+synopsis: Ripple payment system library+homepage: https://github.com/singpolyma/ripple-haskell+bug-reports: https://github.com/singpolyma/ripple-haskell/issues+build-type: Simple+description:+ Interact with Ripple servers, sign transactions, etc.++extra-source-files:+ README++library+ exposed-modules:+ Ripple.Amount+ Ripple.Seed+ Ripple.Sign+ Ripple.Transaction+ Ripple.WebSockets++ build-depends:+ base == 4.*,+ utility-ht,+ bytestring,+ text,+ largeword >= 1.1.0,+ binary,+ cereal,+ aeson,+ attoparsec,+ errors,+ base58address,+ crypto-api,+ cryptohash-cryptoapi,+ crypto-pubkey-types,+ ecdsa >= 0.2,+ websockets++source-repository head+ type: git+ location: git://github.com/singpolyma/ripple-haskell.git