diff --git a/COPYING b/COPYING new file mode 100644 --- /dev/null +++ b/COPYING @@ -0,0 +1,13 @@ +Copyright © 2013-2014, Stephen Paul Weber + +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. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,1 @@ +Interact with Ripple servers, sign transactions, etc. diff --git a/Ripple/Amount.hs b/Ripple/Amount.hs new file mode 100644 --- /dev/null +++ b/Ripple/Amount.hs @@ -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 diff --git a/Ripple/Seed.hs b/Ripple/Seed.hs new file mode 100644 --- /dev/null +++ b/Ripple/Seed.hs @@ -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 diff --git a/Ripple/Sign.hs b/Ripple/Sign.hs new file mode 100644 --- /dev/null +++ b/Ripple/Sign.hs @@ -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 diff --git a/Ripple/Transaction.hs b/Ripple/Transaction.hs new file mode 100644 --- /dev/null +++ b/Ripple/Transaction.hs @@ -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 #-} diff --git a/Ripple/WebSockets.hs b/Ripple/WebSockets.hs new file mode 100644 --- /dev/null +++ b/Ripple/WebSockets.hs @@ -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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/ripple.cabal b/ripple.cabal new file mode 100644 --- /dev/null +++ b/ripple.cabal @@ -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 +maintainer: Stephen Paul Weber +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