rootstock.hs

   1 --------------------------------------------------------------------------------
   2 {-# LANGUAGE FlexibleContexts
   3   , GADTs
   4   , OverloadedStrings
   5   , QuasiQuotes
   6   , TemplateHaskell
   7   , TypeFamilies #-}
   8
   9 module Main
  10     ( main
  11     ) where
  12
  13
  14 --------------------------------------------------------------------------------
  15 import Control.Applicative ((<$>), (<*>))
  16 import Control.Concurrent (forkIO)
  17 import Control.Monad (forever, unless, foldM, liftM)
  18 import Control.Monad.Trans (lift, liftIO)
  19 import Control.Monad.Trans.Reader
  20 import Data.Aeson
  21 import Data.Aeson.Types
  22 import qualified Data.ByteString.Char8 as BS
  23 import qualified Data.ByteString.Lazy.Char8 as BSL8
  24 import Data.List (find, intersperse)
  25 import Data.Maybe (isJust, listToMaybe)
  26 import Data.Text (Text)
  27 import qualified Data.Text as T
  28 import qualified Data.Text.IO as T
  29 import Data.Time.Clock
  30 import Database.Esqueleto
  31 import Database.Persist.Postgresql hiding ((==.))
  32 import Database.Persist.TH
  33 import Fund
  34 import qualified Network.WebSockets as WS
  35 import Numeric (showFFloat)
  36 import System.Process (readProcess)
  37
  38
  39 --------------------------------------------------------------------------------
  40 data AccountInfo = AccountInfo
  41   { dropsBalance    :: Integer
  42   , currentSequence :: Integer
  43   }
  44
  45 data IOUAmount = IOUAmount
  46   { iouLine       :: IOULine
  47   , iouQuantity   :: Double
  48   }
  49   deriving Show
  50
  51 newtype AccountLines = AccountLines [IOUAmount]
  52
  53 data Amount
  54   = Drops Integer
  55   | IOU IOUAmount
  56   deriving Show
  57
  58 data Transaction
  59   = OfferCreate Amount Amount Integer (Maybe Integer)
  60   | OfferCancel Integer Integer
  61   deriving Show
  62
  63 data Offer = Offer
  64   { takerGets     :: Amount
  65   , takerPays     :: Amount
  66   , offerSequence :: Integer
  67   }
  68
  69 newtype Offers = Offers [Offer]
  70
  71 data Ledger = Ledger
  72   { ledgerIndex :: Integer
  73   , feeRef      :: Integer
  74   }
  75
  76 data RecordedTransaction = RecordedTransaction
  77
  78 share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
  79   HalfLink
  80     root      Fund
  81     branch    Fund
  82     quantity  Double
  83     timestamp UTCTime
  84     HalfLinkUnique root branch timestamp
  85   Link
  86     left  Fund
  87     right Fund
  88     LinkUnique left right
  89   LinkStatus
  90     linkId      LinkId
  91     halfSpread  Double
  92     timestamp   UTCTime
  93     LinkStatusUnique linkId timestamp
  94   |]
  95 data OldLink = OldLink
  96   { leftFund    :: Fund
  97   , rightFund   :: Fund
  98   , halfSpread  :: Double
  99   , logFileName :: FilePath
 100   }
 101
 102 data Rootstock = Rootstock
 103   { secret    :: String
 104   , websocket :: WS.Connection
 105   , sql       :: Connection
 106   }
 107
 108 type RootstockIO = ReaderT Rootstock IO
 109
 110
 111 --------------------------------------------------------------------------------
 112 instance ToJSON Amount where
 113   toJSON (Drops numDrops) = toJSON $ show numDrops
 114   toJSON (IOU iou) = object
 115     [ "currency"  .= lineCurrency (iouLine iou)
 116     , "issuer"    .= peerAccount  (iouLine iou)
 117     , "value"     .= showFFloat Nothing (iouQuantity iou) ""
 118     ]
 119
 120 instance ToJSON Transaction where
 121   toJSON (OfferCreate toSell toBuy curSeq maybeOldOfferSequence) = object $
 122     [ "TransactionType" .= ("OfferCreate" :: Text)
 123     , "Account"         .= account
 124     , "Fee"             .= fee
 125     , "Sequence"        .= curSeq
 126     , "Flags"           .= tfSell
 127     , "TakerPays"       .= toBuy
 128     , "TakerGets"       .= toSell
 129     ] ++ maybe
 130       []
 131       (\oldOfferSequence -> ["OfferSequence" .= show oldOfferSequence])
 132       maybeOldOfferSequence
 133   toJSON (OfferCancel curSeq oldOfferSequence) = object $
 134     [ "TransactionType" .= ("OfferCancel" :: Text)
 135     , "Account"         .= account
 136     , "Fee"             .= fee
 137     , "Sequence"        .= curSeq
 138     , "OfferSequence"   .= oldOfferSequence
 139     ]
 140
 141 instance FromJSON AccountInfo where
 142   parseJSON (Object obj) = do
 143     result      <- obj    .: "result"
 144     accountData <- result .: "account_data"
 145     AccountInfo
 146       <$> (accountData .: "Balance"   >>= return . read)
 147       <*>  accountData .: "Sequence"
 148   parseJSON value = fail $
 149     "Not an account info response:\n" ++ (BSL8.unpack $ encode value)
 150
 151 instance FromJSON IOUAmount where
 152   parseJSON (Object obj) = IOUAmount
 153     <$> (IOULine
 154       <$> obj .: "account"
 155       <*> obj .: "currency")
 156     <*> (obj .: "balance" >>= return . read)
 157   parseJSON value = fail $
 158     "Not an account line:\n" ++ (BSL8.unpack $ encode value)
 159
 160 instance FromJSON AccountLines where
 161   parseJSON (Object obj) = do
 162     result <- obj .: "result"
 163     AccountLines <$> result .: "lines"
 164   parseJSON value = fail $
 165     "Not a list of account lines:\n" ++ (BSL8.unpack $ encode value)
 166
 167 instance FromJSON Amount where
 168   parseJSON (Object obj) = IOU <$> (IOUAmount
 169     <$> (IOULine
 170       <$> obj .: "issuer"
 171       <*> obj .: "currency")
 172     <*> (obj .: "value" >>= return . read))
 173   parseJSON (String str) = return $ Drops $ read $ T.unpack str
 174   parseJSON value = fail $
 175     "Not an Amount:\n" ++ (BSL8.unpack $ encode value)
 176
 177 instance FromJSON Offer where
 178   parseJSON (Object obj) = Offer
 179     <$> obj   .: "taker_gets"
 180     <*> obj   .: "taker_pays"
 181     <*> obj   .: "seq"
 182   parseJSON value = fail $
 183     "Not an offer:\n" ++ (BSL8.unpack $ encode value)
 184
 185 instance FromJSON Offers where
 186   parseJSON (Object obj) = do
 187     result <- obj .: "result"
 188     Offers <$> result .: "offers"
 189   parseJSON value = fail $
 190     "Not a list of offers:\n" ++ (BSL8.unpack $ encode value)
 191
 192 instance FromJSON Ledger where
 193   parseJSON (Object obj) = Ledger
 194     <$> obj .: "ledger_index"
 195     <*> obj .: "fee_ref"
 196   parseJSON value = fail $
 197     "Not a ledger:\n" ++ (BSL8.unpack $ encode value)
 198
 199 instance FromJSON RecordedTransaction where
 200   parseJSON (Object obj) = do
 201     objType <- obj .: "type"
 202     if objType == ("transaction" :: Text)
 203     then return RecordedTransaction
 204     else fail $
 205       "Not a recorded transaction:\n" ++ (BSL8.unpack $ encode $ Object obj)
 206   parseJSON value = fail $
 207       "Not a recorded transaction:\n" ++ (BSL8.unpack $ encode value)
 208
 209
 210 --------------------------------------------------------------------------------
 211 secretFile, rsignPath, sqlPassFile :: FilePath
 212 secretFile = "/home/tim/Documents/passwords/ripple-secret.gpg"
 213 rsignPath =
 214   "/home/tim/build/ripple/ripple-lib/node_modules/ripple-lib/bin/rsign.js"
 215 sqlPassFile = "sql-password.gpg"
 216
 217 connString :: BS.ByteString
 218 connString = "host=localhost port=5432 user=tim dbname=rootstock password="
 219
 220 account, bitStamp, rippleCN :: Text
 221 account  = "rpY4wdftAiEH5y5uzxC2XAvy3G27UyeQKS"
 222 bitStamp = "rvYAfWj5gh67oV6fW32ZzP3Aw4Eubs59B"
 223 rippleCN = "rnuF96W4SZoCJmbHYBFoJZpR8eCaxNvekK"
 224
 225 fee, tfSell, reserve :: Integer
 226 fee = 10
 227 tfSell = 0x00080000
 228 reserve = 200000000
 229
 230 btcBitstamp, usdBitstamp, cnyRippleCN :: Fund
 231 btcBitstamp = IOUFund $ IOULine {peerAccount = bitStamp, lineCurrency = "BTC"}
 232 usdBitstamp = IOUFund $ IOULine {peerAccount = bitStamp, lineCurrency = "USD"}
 233 cnyRippleCN = IOUFund $ IOULine {peerAccount = rippleCN, lineCurrency = "CNY"}
 234
 235 xrpbtc, usdcny :: OldLink
 236 xrpbtc = OldLink
 237   { leftFund    = XRP
 238   , rightFund   = btcBitstamp
 239   , halfSpread  = 1.02
 240   , logFileName = "XRPBTClog.csv"
 241   }
 242 usdcny = OldLink
 243   { leftFund    = usdBitstamp
 244   , rightFund   = cnyRippleCN
 245   , halfSpread  = 1.006
 246   , logFileName = "USDCNYlog.csv"
 247   }
 248
 249 oldLinks :: [OldLink]
 250 oldLinks = [xrpbtc, usdcny]
 251
 252 lookupFund :: AccountInfo -> AccountLines -> Fund -> Maybe Amount
 253 lookupFund acInfo _ XRP = Just $ Drops $ dropsBalance acInfo - reserve
 254 lookupFund _ (AccountLines lines) (IOUFund fundLine) = do
 255   foundLine <- find ((fundLine ==) . iouLine) lines
 256   return $ IOU foundLine
 257
 258 getQuantity :: Amount -> Double
 259 getQuantity (Drops n) = fromInteger n
 260 getQuantity (IOU iou) = iouQuantity iou
 261
 262 setQuantity :: Amount -> Double -> Amount
 263 setQuantity (Drops _) q = Drops $ round q
 264 setQuantity (IOU iou) q = IOU $ iou { iouQuantity = q }
 265
 266 sellAtPrice :: Amount -> Amount -> Double -> Double -> Double ->
 267   (Amount, Amount)
 268 sellAtPrice sellFrom buyTo sellFee buyFee p =
 269   let
 270     q = (getQuantity sellFrom - sellFee - (getQuantity buyTo - buyFee)/p)/2
 271   in
 272     (setQuantity sellFrom q, setQuantity buyTo $ p * q)
 273
 274 sellAtHalfSpread :: Amount -> Amount -> Double -> Double -> Double
 275   -> (Amount, Amount)
 276 sellAtHalfSpread sellFrom buyTo sellFee buyFee hSpread =
 277   sellAtPrice sellFrom buyTo sellFee buyFee $
 278     hSpread * getQuantity buyTo / getQuantity sellFrom
 279
 280 validNoLoss :: Amount -> Amount -> Double -> Double -> Amount -> Amount -> Bool
 281 validNoLoss sellFrom buyTo sellFee buyFee toSell toBuy =
 282   let
 283     sellFromQ = getQuantity sellFrom
 284     buyToQ    = getQuantity buyTo
 285     toSellQ   = getQuantity toSell
 286     toBuyQ    = getQuantity toBuy
 287   in
 288     toSellQ > 0 && toBuyQ > 0 &&
 289       (sellFromQ - toSellQ - sellFee) * (buyToQ + toBuyQ - buyFee) >=
 290         sellFromQ * buyToQ
 291
 292 fund :: Amount -> Fund
 293 fund (Drops _) = XRP
 294 fund (IOU iou) = IOUFund $ iouLine iou
 295
 296 lookupOffer :: Offers -> Fund -> Fund -> Maybe Offer
 297 lookupOffer (Offers offers) toSell toBuy = find
 298   (\offer -> fund (takerGets offer) == toSell &&
 299     fund (takerPays offer) == toBuy)
 300   offers
 301
 302 lookupOfferSequence :: Offers -> Fund -> Fund -> Maybe Integer
 303 lookupOfferSequence offers toSell toBuy = do
 304   foundOffer <- lookupOffer offers toSell toBuy
 305   return $ offerSequence foundOffer
 306
 307 bothOffersPresent :: Offers -> Link -> Bool
 308 bothOffersPresent offers link =
 309   let
 310     left = linkLeft link
 311     right = linkRight link
 312   in
 313     (isJust $ lookupOffer offers left right) &&
 314       (isJust $ lookupOffer offers right left)
 315
 316
 317 --------------------------------------------------------------------------------
 318 getRootstock :: RootstockIO Rootstock
 319 getRootstock = ask
 320
 321 getSqlConnection :: RootstockIO Connection
 322 getSqlConnection = getRootstock >>= return . sql
 323
 324 runSqlQuery :: SqlPersistM a -> RootstockIO a
 325 runSqlQuery query = do
 326   sqlConn <- getSqlConnection
 327   lift $ runSqlPersistM query sqlConn
 328
 329 receiveData :: WS.WebSocketsData a => RootstockIO a
 330 receiveData = getRootstock >>= return . websocket >>= lift . WS.receiveData
 331
 332 sendTextData :: WS.WebSocketsData a => a -> RootstockIO ()
 333 sendTextData x =
 334   getRootstock >>= return . websocket >>= lift . flip WS.sendTextData x
 335
 336 signTransaction :: Transaction -> RootstockIO String
 337 signTransaction tx = do
 338   rs <- getRootstock
 339   blobNewLine <- lift $ readProcess
 340     rsignPath [secret rs, BSL8.unpack $ encode tx] ""
 341   return $ init blobNewLine
 342
 343 waitForType :: FromJSON a => RootstockIO a
 344 waitForType = do
 345   encoded <- receiveData
 346   case decode encoded of
 347     Nothing -> do
 348       lift $ putStrLn ("Skipping:\n" ++ (BSL8.unpack encoded))
 349       waitForType
 350     Just result -> do
 351       lift $ putStrLn ("Using:\n" ++ (BSL8.unpack encoded))
 352       return result
 353
 354 signAndSend :: Transaction -> RootstockIO ()
 355 signAndSend tx = do
 356   txBlob <- signTransaction tx
 357   sendTextData $ encode $ object
 358     [ "command" .= ("submit" :: Text)
 359     , "tx_blob" .= txBlob
 360     ]
 361
 362 submitSellOffer :: Amount -> Amount -> Double -> Double -> Double -> Offers ->
 363   Integer -> RootstockIO Integer
 364 submitSellOffer
 365   sellFrom buyTo
 366   sellFee buyFee hSpread
 367   offers curSeq = do
 368     let
 369       (toSell, toBuy) = sellAtHalfSpread sellFrom buyTo sellFee buyFee hSpread
 370       maybeOldOfferSequence =
 371         lookupOfferSequence offers (fund sellFrom) $ fund buyTo
 372       tx = OfferCreate toSell toBuy curSeq Nothing
 373     lift $ BSL8.putStrLn $ encode tx
 374     if validNoLoss sellFrom buyTo sellFee buyFee toSell toBuy
 375     then do
 376       signAndSend tx
 377       case maybeOldOfferSequence of
 378         Nothing -> return $ curSeq + 1
 379         Just oldOfferSequence -> do
 380           signAndSend $ OfferCancel (curSeq + 1) oldOfferSequence
 381           return $ curSeq + 2
 382     else do
 383       lift $ putStrLn "Skipping the above: either invalid or loss-making"
 384       return curSeq
 385
 386 subscribeAccount :: RootstockIO ()
 387 subscribeAccount =
 388   sendTextData $ encode $ object
 389     [ "command"   .= ("subscribe" :: Text)
 390     , "accounts"  .= [account]
 391     ]
 392
 393 marketMaker :: RootstockIO ()
 394 marketMaker = do
 395   subscribeAccount
 396   marketMakerLoop
 397
 398 getLinkEntities :: RootstockIO [Entity Link]
 399 getLinkEntities = runSqlQuery $ select $ from return
 400
 401 getLinks :: RootstockIO [Link]
 402 getLinks = liftM (map entityVal) getLinkEntities
 403
 404 waitForAction :: RootstockIO Offers
 405 waitForAction = do
 406   sendTextData $ encode $ object
 407     [ "command" .= ("account_offers" :: Text)
 408     , "account" .= account
 409     ]
 410   offers <- waitForType
 411   links <- getLinks
 412   if all (bothOffersPresent offers) links
 413   then do
 414     RecordedTransaction <- waitForType
 415     waitForAction
 416   else return offers
 417
 418 currentLinkStatus :: LinkId -> RootstockIO (Maybe LinkStatus)
 419 currentLinkStatus linkId = do
 420   statusList <- runSqlQuery $ select $ from $ \status -> do
 421     where_ $ status ^. LinkStatusLinkId ==. val linkId
 422     orderBy [desc $ status ^. LinkStatusTimestamp]
 423     limit 1
 424     return status
 425   return $ liftM entityVal $ listToMaybe statusList
 426
 427 submitLinkOffers :: AccountInfo -> AccountLines ->
 428   Offers -> Entity Link -> Integer -> RootstockIO Integer
 429 submitLinkOffers acInfo acLines offers (Entity linkId link) curSeq = do
 430   if bothOffersPresent offers link
 431   then return curSeq
 432   else do
 433     maybeHSpread <- liftM (liftM linkStatusHalfSpread) $
 434       currentLinkStatus linkId
 435     let
 436       left = linkLeft link
 437       right = linkRight link
 438       feeForCalcs XRP = fromInteger $ 3 * fee
 439       feeForCalcs _ = 0
 440       leftFeeForCalcs = feeForCalcs left
 441       rightFeeForCalcs = feeForCalcs right
 442     case
 443       ( lookupFund acInfo acLines left
 444       , lookupFund acInfo acLines right
 445       , maybeHSpread
 446       ) of
 447       (Just leftTotal, Just rightTotal, Just hSpread) -> do
 448         now <- lift getCurrentTime
 449         runSqlQuery $ do
 450           insert $ HalfLink left right (getQuantity leftTotal) now
 451           insert $ HalfLink right left (getQuantity rightTotal) now
 452         nextSeq <- submitSellOffer
 453           leftTotal rightTotal
 454           leftFeeForCalcs rightFeeForCalcs hSpread
 455           offers curSeq
 456         submitSellOffer
 457           rightTotal leftTotal
 458           rightFeeForCalcs leftFeeForCalcs hSpread
 459           offers nextSeq
 460       _ -> do
 461         lift $ putStrLn
 462           "The link status or one of the lines of credit wasn't found"
 463         return curSeq
 464
 465 marketMakerLoop :: RootstockIO ()
 466 marketMakerLoop = do
 467   offers <- waitForAction
 468   sendTextData $ encode $ object
 469     [ "command" .= ("account_info" :: Text)
 470     , "account" .= account
 471     ]
 472   acInfo <- waitForType
 473   sendTextData $ encode $ object
 474     [ "command" .= ("account_lines" :: Text)
 475     , "account" .= account
 476     ]
 477   acLines <- waitForType
 478   linkEntities <- getLinkEntities
 479   foldM (flip ($)) (currentSequence acInfo) $
 480     map (submitLinkOffers acInfo acLines offers) linkEntities
 481   marketMakerLoop
 482
 483 insertOldLink :: OldLink -> RootstockIO ()
 484 insertOldLink link = do
 485   now <- lift getCurrentTime
 486   runSqlQuery $ do
 487     linkId <- insert $ Link (leftFund link) (rightFund link)
 488     insert $ LinkStatus linkId (halfSpread link) now
 489   return ()
 490
 491
 492 --------------------------------------------------------------------------------
 493 runRootstock :: RootstockIO a -> Rootstock -> IO a
 494 runRootstock = runReaderT
 495
 496 rippleInteract :: WS.ClientApp ()
 497 rippleInteract conn = do
 498   -- Fork a thread that writes WS data to stdout
 499   _ <- forkIO $ forever $ do
 500       msg <- WS.receiveData conn
 501       liftIO $ T.putStrLn msg
 502
 503   runRootstock subscribeAccount $ Rootstock
 504     { secret    = ""
 505     , websocket = conn
 506     , sql       = undefined
 507     }
 508
 509   -- Read from stdin and write to WS
 510   let loop = do
 511           line <- T.getLine
 512           unless (T.null line) $ WS.sendTextData conn line >> loop
 513
 514   loop
 515   WS.sendClose conn ("Bye!" :: Text)
 516
 517 readSecret :: IO String
 518 readSecret = readProcess "gpg" ["-o", "-", secretFile] ""
 519
 520 readSqlPass :: IO BS.ByteString
 521 readSqlPass = readProcess "gpg" ["-o", "-", sqlPassFile] "" >>= return . BS.pack
 522
 523 runRipple :: WS.ClientApp a -> IO a
 524 runRipple app = WS.runClient "s1.ripple.com" 443 "/" app
 525
 526 runRippleWithSecret :: RootstockIO a -> IO a
 527 runRippleWithSecret app = do
 528   sec <- readSecret
 529   sqlPass <- readSqlPass
 530   withPostgresqlConn (BS.concat [connString, sqlPass]) $ \sqlConn -> do
 531     runSqlPersistM (runMigration migrateAll) sqlConn
 532     runRipple $ \wsConn ->
 533       runRootstock app $ Rootstock
 534         { websocket = wsConn
 535         , secret    = sec
 536         , sql       = sqlConn
 537         }
 538
 539 insertOldLinks :: IO ()
 540 insertOldLinks = runRippleWithSecret $ sequence_ $ map insertOldLink oldLinks
 541
 542 main :: IO ()
 543 main = runRippleWithSecret marketMaker
 544