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 Prelude hiding (catch)
  16 import Action
  17 import Control.Applicative ((<$>), (<*>), pure)
  18 import Control.Concurrent (forkIO)
  19 import Control.Exception (AsyncException(..), catch, fromException)
  20 import Control.Monad (forever, join, liftM, unless, when)
  21 import Control.Monad.IfElse (aifM, awhenM, unlessM)
  22 import Control.Monad.Trans (lift, liftIO)
  23 import Control.Monad.Trans.Error (ErrorT(..), mapErrorT, throwError)
  24 import Control.Monad.Trans.State
  25 import Crypto.Random (SystemRandom, newGenIO)
  26 import Crypto.Types.PubKey.ECDSA (PrivateKey)
  27 import Data.Aeson
  28 import Data.Aeson.Types
  29 import Data.Base58Address (RippleAddress)
  30 import qualified Data.Binary as B
  31 import Data.Bits ((.|.))
  32 import qualified Data.ByteString.Base16.Lazy as H
  33 import qualified Data.ByteString.Char8 as BS
  34 import qualified Data.ByteString.Lazy.Char8 as BSL8
  35 import Data.Foldable (forM_, toList)
  36 import Data.List (find, intersperse)
  37 import Data.Map (Map)
  38 import qualified Data.Map as Map
  39 import Data.Maybe (catMaybes, fromJust, fromMaybe, isJust, listToMaybe)
  40 import Data.Set (Set)
  41 import qualified Data.Set as Set
  42 import Data.Text (Text)
  43 import qualified Data.Text as T
  44 import qualified Data.Text.IO as T
  45 import Data.Time.Clock
  46 import Data.Word (Word32)
  47 import Database.Esqueleto hiding ((=.), get, update)
  48 import Database.Persist.Postgresql hiding ((==.), (<=.), (!=.), get, update)
  49 import qualified Database.Persist.Postgresql as P
  50 import Database.Persist.TH
  51 import Fund
  52 import qualified Network.WebSockets as WS
  53 import Numeric (showFFloat)
  54 import qualified Ripple.Amount as RH
  55 import Ripple.Seed (getSecret)
  56 import Ripple.Sign (signTransaction)
  57 import Ripple.Transaction
  58 import Ripple.WebSockets (RippleResult(RippleResult))
  59 import RootstockException (RootstockException(..))
  60 import System.Environment (getArgs)
  61 import Util.ApproxEq ((~~=))
  62 import Util.Either (doLeft, isRight)
  63 import Util.Error (throwIf)
  64 import Util.Foldable (sumWith)
  65 import Util.Function ((.!))
  66 import Util.Monad ((>>=*), buildMap)
  67 import Util.Persist (insertReturnEntity)
  68 import Util.Set (distinctPairs, distinctPairsOneWay)
  69 import ValueSimplex
  70
  71
  72 --------------------------------------------------------------------------------
  73 data AccountInfo = AccountInfo
  74   { dropsBalance    :: Integer
  75   , currentSequence :: Word32
  76   , transferRate    :: Double
  77   }
  78
  79 data IOUAmount = IOUAmount
  80   { iouLine       :: IOULine
  81   , iouQuantity   :: Double
  82   }
  83   deriving Show
  84
  85 newtype AccountLines = AccountLines [IOUAmount]
  86
  87 data Amount
  88   = Drops Integer
  89   | IOU IOUAmount
  90   deriving Show
  91
  92 data Offer = Offer
  93   { takerGets     :: Amount
  94   , takerPays     :: Amount
  95   , offerSequence :: Word32
  96   }
  97
  98 newtype Offers = Offers [Offer]
  99
 100 data BookOffer = BookOffer
 101   { bookOfferTakerGets        :: RH.Amount
 102   , bookOfferTakerPays        :: RH.Amount
 103   , bookOfferQuality          :: Double
 104   , bookOfferTakerGetsFunded  :: Maybe RH.Amount
 105   , bookOfferTakerPaysFunded  :: Maybe RH.Amount
 106   }
 107
 108 newtype BookOffers = BookOffers [BookOffer]
 109
 110 data Ledger = Ledger
 111   { ledgerIndex :: Integer
 112   , feeRef      :: Integer
 113   }
 114
 115 data RecordedTransaction = RecordedTransaction
 116
 117 share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
 118   Node
 119     fund Fund
 120     NodeUnique fund
 121     deriving Eq
 122     deriving Ord
 123   FundStatus
 124     fundId    NodeId
 125     quantity  Double
 126     time      UTCTime
 127     FundStatusUnique fundId time
 128   HalfLink
 129     root      NodeId
 130     branch    NodeId
 131     quantity  Double
 132     time      UTCTime
 133     HalfLinkUnique root branch time
 134   ActionLog
 135     action      Action
 136     start       UTCTime
 137     end         UTCTime Maybe
 138     success     Bool Maybe
 139     ActionUnique start
 140   Warning
 141     warning Text
 142     time    UTCTime
 143   |]
 144
 145 type NodeEntity = Entity Node
 146 type ValueSimplexND = ValueSimplex NodeEntity Double
 147
 148 data Rootstock = Rootstock
 149   { secret        :: PrivateKey
 150   , websocket     :: WS.Connection
 151   , sql           :: Connection
 152   , valueSimplex  :: ValueSimplexND
 153   , nextSequence  :: Word32
 154   , rsAction      :: ActionLogId
 155   , randGen       :: SystemRandom
 156   }
 157
 158 type RootstockIO = StateT Rootstock IO
 159 type ExceptionalRootstock = ErrorT RootstockException RootstockIO
 160
 161
 162 --------------------------------------------------------------------------------
 163 instance ToJSON Amount where
 164   toJSON (Drops numDrops) = toJSON $ show numDrops
 165   toJSON (IOU iou) = object
 166     [ "currency"  .= lineCurrency (iouLine iou)
 167     , "issuer"    .= peerAccount  (iouLine iou)
 168     , "value"     .= showFFloat Nothing (iouQuantity iou) ""
 169     ]
 170
 171 instance FromJSON AccountInfo where
 172   parseJSON (Object obj) = do
 173     accountData <- obj .: "account_data"
 174     AccountInfo
 175       <$> (accountData .: "Balance"   >>= return . read)
 176       <*>  accountData .: "Sequence"
 177       <*> (maybe 1 (/1000000000) <$> accountData .:? "TransferRate")
 178   parseJSON value = fail $
 179     "Not an account info response:\n" ++ (BSL8.unpack $ encode value)
 180
 181 instance FromJSON IOUAmount where
 182   parseJSON (Object obj) = IOUAmount
 183     <$> (IOULine
 184       <$> obj .: "account"
 185       <*> obj .: "currency")
 186     <*> (obj .: "balance" >>= return . read)
 187   parseJSON value = fail $
 188     "Not an account line:\n" ++ (BSL8.unpack $ encode value)
 189
 190 instance FromJSON AccountLines where
 191   parseJSON (Object obj) = AccountLines <$> obj .: "lines"
 192   parseJSON value = fail $
 193     "Not a list of account lines:\n" ++ (BSL8.unpack $ encode value)
 194
 195 instance FromJSON Amount where
 196   parseJSON (Object obj) = IOU <$> (IOUAmount
 197     <$> (IOULine
 198       <$> obj .: "issuer"
 199       <*> obj .: "currency")
 200     <*> (obj .: "value" >>= return . read))
 201   parseJSON (String str) = return $ Drops $ read $ T.unpack str
 202   parseJSON value = fail $
 203     "Not an Amount:\n" ++ (BSL8.unpack $ encode value)
 204
 205 instance FromJSON Offer where
 206   parseJSON (Object obj) = Offer
 207     <$> obj   .: "taker_gets"
 208     <*> obj   .: "taker_pays"
 209     <*> obj   .: "seq"
 210   parseJSON value = fail $
 211     "Not an offer:\n" ++ (BSL8.unpack $ encode value)
 212
 213 instance FromJSON Offers where
 214   parseJSON (Object obj) = Offers <$> obj .: "offers"
 215   parseJSON value = fail $
 216     "Not a list of offers:\n" ++ (BSL8.unpack $ encode value)
 217
 218 instance FromJSON BookOffer where
 219   parseJSON (Object obj) = BookOffer
 220     <$> obj .:  "TakerGets"
 221     <*> obj .:  "TakerPays"
 222     <*> obj .:  "quality"
 223     <*> obj .:? "taker_gets_funded"
 224     <*> obj .:? "taker_pays_funded"
 225   parseJSON value = fail $ "Not a book offer:\n" ++ (BSL8.unpack $ encode value)
 226
 227 instance FromJSON BookOffers where
 228   parseJSON (Object obj) = BookOffers <$> obj .: "offers"
 229   parseJSON value = fail $
 230     "Not a list of book offers:\n" ++ (BSL8.unpack $ encode value)
 231
 232 instance FromJSON Ledger where
 233   parseJSON (Object obj) = Ledger
 234     <$> obj .: "ledger_index"
 235     <*> obj .: "fee_ref"
 236   parseJSON value = fail $
 237     "Not a ledger:\n" ++ (BSL8.unpack $ encode value)
 238
 239 instance FromJSON RecordedTransaction where
 240   parseJSON (Object obj) = do
 241     objType <- obj .: "type"
 242     if objType == ("transaction" :: Text)
 243     then return RecordedTransaction
 244     else fail $
 245       "Not a recorded transaction:\n" ++ (BSL8.unpack $ encode $ Object obj)
 246   parseJSON value = fail $
 247       "Not a recorded transaction:\n" ++ (BSL8.unpack $ encode value)
 248
 249
 250 --------------------------------------------------------------------------------
 251 secretFile, sqlPassFile :: FilePath
 252 secretFile = "/media/mishael/ripple-secret"
 253 sqlPassFile = "/media/mishael/sql-password"
 254
 255 connString :: BS.ByteString
 256 connString = BS.concat
 257   [ "host=localhost port=5432 dbname=rootstock-test"
 258   , " user=rootstock password="
 259   ]
 260
 261 account :: Text
 262 account  = "rpY4wdftAiEH5y5uzxC2XAvy3G27UyeQKS"
 263
 264 accountAddress :: RippleAddress
 265 accountAddress = read $ T.unpack account
 266
 267 feeInDrops :: Integer
 268 feeInDrops = 10000
 269
 270 fee :: RH.Amount
 271 fee = RH.Amount (toRational feeInDrops / 1000000) RH.XRP
 272
 273 reserve :: Integer
 274 reserve = 200000000
 275
 276 generosity, halfSpread :: Double
 277 generosity = 1000000
 278 halfSpread = 1.01
 279
 280 noAction :: ActionLogId
 281 noAction = Key PersistNull
 282
 283 lookupXRP :: AccountInfo -> Amount
 284 lookupXRP acInfo = Drops $ dropsBalance acInfo - reserve
 285
 286 lookupLine :: AccountLines -> IOULine -> Maybe Amount
 287 lookupLine (AccountLines lines) fundLine = do
 288   foundLine <- find ((fundLine ==) . iouLine) lines
 289   return $ IOU foundLine
 290
 291 lookupFund :: AccountInfo -> AccountLines -> Fund -> Maybe Amount
 292 lookupFund acInfo _ XRP = Just $ lookupXRP acInfo
 293 lookupFund _ acLines (IOUFund fundLine) = lookupLine acLines fundLine
 294
 295 getQuantity :: Amount -> Double
 296 getQuantity (Drops n) = fromInteger n
 297 getQuantity (IOU iou) = iouQuantity iou
 298
 299 firstSequence :: [Field] -> Word32
 300 firstSequence [] = 0
 301 firstSequence (SequenceNumber x : _) = x
 302 firstSequence (_:fs) = firstSequence fs
 303
 304 getSequence :: Transaction -> Word32
 305 getSequence (Transaction fs) = firstSequence fs
 306
 307 nodeEntityFund :: NodeEntity -> Fund
 308 nodeEntityFund = nodeFund . entityVal
 309
 310 lookupGetQuantity :: AccountInfo -> AccountLines -> NodeEntity -> Double
 311 lookupGetQuantity acInfo acLines =
 312   fromMaybe 0 . liftM getQuantity .
 313     lookupFund acInfo acLines . nodeEntityFund
 314
 315 fromNodeEntity :: a -> (IOULine -> a) -> NodeEntity -> a
 316 fromNodeEntity d f x = case nodeEntityFund x of
 317   XRP       -> d
 318   IOUFund l -> f l
 319
 320 amount :: Double -> NodeEntity -> Amount
 321 amount q =
 322   fromNodeEntity (Drops $ round q) $ \l ->
 323     IOU $ IOUAmount {iouLine = l, iouQuantity = q}
 324
 325 peerOfNodeEntity :: NodeEntity -> Maybe Text
 326 peerOfNodeEntity = fromNodeEntity Nothing $ Just . peerAccount
 327
 328 actionFinished :: ActionLog -> Bool
 329 actionFinished = isJust . actionLogEnd
 330
 331 actionEntityFinished :: Entity ActionLog -> Bool
 332 actionEntityFinished = actionFinished . entityVal
 333
 334 actionRunning :: Entity ActionLog -> Bool
 335 actionRunning acEnt =
 336   actionLogAction (entityVal acEnt) == Running
 337   && not (actionEntityFinished acEnt)
 338
 339 updatedValueSimplexWithGenerosity ::
 340   Double -> ValueSimplexND -> AccountInfo -> AccountLines -> ValueSimplexND
 341 updatedValueSimplexWithGenerosity gen vs acInfo acLines =
 342   multiUpdate vs $ \nodeEnt ->
 343     let actual = lookupGetQuantity acInfo acLines nodeEnt in
 344     case nodeEntityFund nodeEnt of
 345       XRP -> gen + actual
 346       _   -> actual
 347
 348 updatedValueSimplex ::
 349   ValueSimplexND -> AccountInfo -> AccountLines -> ValueSimplexND
 350 updatedValueSimplex = updatedValueSimplexWithGenerosity 0
 351
 352 toRHAmount :: Amount -> RH.Amount
 353 toRHAmount (Drops x) = RH.Amount (toRational x / 1000000) RH.XRP
 354 toRHAmount (IOU x) = let
 355     line = iouLine x
 356     [a, b, c] = T.unpack $ lineCurrency line
 357   in
 358     RH.Amount (toRational $ iouQuantity x)
 359       $ RH.Currency (a, b, c) $ read $ T.unpack $ peerAccount line
 360
 361 commonTransactionStuff :: Word32 -> [Transaction] -> [Transaction]
 362 commonTransactionStuff nextSeq = zipWith
 363   (\sequ (Transaction fs) -> Transaction $
 364     [ Account accountAddress
 365     , Fee fee
 366     , SequenceNumber sequ
 367     ] ++ fs
 368   )
 369   [nextSeq ..]
 370
 371 pivotFee ::
 372   ValueSimplexND -> Double -> NodeEntity -> Maybe (Double, ValueSimplexND)
 373 pivotFee vs feeDrops x =
 374   let
 375     xrpNodeEntity =
 376       fromJust $ find ((XRP ==) . nodeEntityFund) $ toList $ nodes vs
 377   in
 378   if x == xrpNodeEntity
 379     then Just (feeDrops, vs)
 380     else if feeDrops >= supremumSellable vs xrpNodeEntity x
 381       then Nothing
 382       else let f = breakEven vs xrpNodeEntity (-feeDrops) x in
 383         Just (f, update vs xrpNodeEntity (-feeDrops) x f)
 384
 385 maybeOfferCreate
 386   :: ValueSimplexND
 387   -> ValueSimplexND
 388   -> NodeEntity
 389   -> NodeEntity
 390   -> (NodeEntity -> Double)
 391   -> Double
 392   -> Bool
 393   -> Maybe Transaction
 394 maybeOfferCreate vs vs' x0 x1 trf f immediate = do
 395   (_, (q0, q1)) <-
 396     linkBreakEvenAtPriceWithFee vs' x0 x1 (halfSpread * price vs x0 x1) f
 397   return $ Transaction
 398     [ TransactionType OfferCreate
 399     , Flags $ tfSell .|. (if immediate then tfImmediateOrCancel else 0)
 400     , TakerPays $ toRHAmount $ amount q1 x1
 401     , TakerGets $ toRHAmount $ amount (-q0 / trf x0) x0
 402     ]
 403
 404 makeTransactions ::
 405   ValueSimplexND -> (NodeEntity -> Double) -> Word32 -> [Transaction]
 406 makeTransactions vs trf nextSeq = commonTransactionStuff nextSeq $ do
 407   let xs = toList $ nodes vs
 408       n = toInteger $ length xs
 409   x1 <- xs
 410   flip (maybe [])
 411     (pivotFee vs (fromInteger $ (n * (n - 1) * 2 - 1) * feeInDrops) x1)
 412     $ \(f, vs') -> do
 413       x0 <- xs
 414       if x0 == x1
 415         then []
 416         else toList $ maybeOfferCreate vs vs' x0 x1 trf f False
 417
 418 --------------------------------------------------------------------------------
 419 getSqlConnection :: RootstockIO Connection
 420 getSqlConnection = gets sql
 421
 422 runSqlQuery :: SqlPersistM a -> RootstockIO a
 423 runSqlQuery query = do
 424   sqlConn <- getSqlConnection
 425   lift $ runSqlPersistM query sqlConn
 426
 427 getNodeEntities :: SqlPersistM [NodeEntity]
 428 getNodeEntities = select $ from return
 429
 430 readValueSimplexAt :: UTCTime -> SqlPersistM ValueSimplexND
 431 readValueSimplexAt time = do
 432   nodeSet <- Set.fromList <$> getNodeEntities
 433   qMap <- buildMap (toList $ distinctPairs nodeSet) $ \(x, y) -> do
 434       [Value q] <- select $ from $ \hl -> do
 435         where_
 436           $   hl ^. HalfLinkRoot    ==. val (entityKey x)
 437           &&. hl ^. HalfLinkBranch  ==. val (entityKey y)
 438           &&. hl ^. HalfLinkTime    <=. val time
 439         orderBy [desc $ hl ^. HalfLinkTime]
 440         limit 1
 441         return $ hl ^. HalfLinkQuantity
 442       return q
 443   return $ fromFunction (curry $ flip (Map.findWithDefault 0) qMap) nodeSet
 444
 445 readValueSimplex :: SqlPersistM ValueSimplexND
 446 readValueSimplex = liftIO getCurrentTime >>= readValueSimplexAt
 447
 448 writeValueSimplex ::
 449   AccountInfo -> AccountLines -> ValueSimplexND -> SqlPersistM ()
 450 writeValueSimplex acInfo acLines vs = do
 451   time <- liftIO getCurrentTime
 452   insertMany $ flip map (toList $ nodes vs) $ \nodeEnt -> FundStatus
 453     { fundStatusFundId    = entityKey nodeEnt
 454     , fundStatusQuantity  = lookupGetQuantity acInfo acLines nodeEnt
 455     , fundStatusTime      = time
 456     }
 457   forM_ (distinctPairs $ nodes vs) $ \(x, y) -> insert_ $ HalfLink
 458       { halfLinkRoot      = entityKey x
 459       , halfLinkBranch    = entityKey y
 460       , halfLinkQuantity  = vsLookup vs x y
 461       , halfLinkTime      = time
 462       }
 463
 464 warn :: Text -> SqlPersistM ()
 465 warn warning = do
 466   now <- liftIO getCurrentTime
 467   insert_ $ Warning
 468     { warningWarning  = warning
 469     , warningTime     = now
 470     }
 471
 472 getCurrentAction :: SqlPersistM (Maybe (Entity ActionLog))
 473 getCurrentAction = liftM listToMaybe $ select $ from $ \ac -> do
 474   orderBy [desc $ ac ^. ActionLogStart]
 475   limit 1
 476   return ac
 477
 478 startAction :: Action -> SqlPersistM ActionLogId
 479 startAction action = do
 480   start <- liftIO getCurrentTime
 481   insert $ ActionLog
 482     { actionLogAction   = action
 483     , actionLogStart    = start
 484     , actionLogEnd      = Nothing
 485     , actionLogSuccess  = Nothing
 486     }
 487
 488 endAction :: ActionLogId -> Bool -> SqlPersistM ()
 489 endAction actionId success = do
 490   end <- liftIO getCurrentTime
 491   P.update actionId
 492     [ ActionLogEnd      =. Just end
 493     , ActionLogSuccess  =. Just success
 494     ]
 495
 496 putAction :: ActionLogId -> RootstockIO ()
 497 putAction actionId = modify $ \rs -> rs {rsAction = actionId}
 498
 499 intervene :: Action -> ExceptionalRootstock () -> RootstockIO ()
 500 intervene action intervention = do
 501   actionId <- runSqlQuery $ do
 502     awhenM getCurrentAction $ \curAc ->
 503       unless (actionEntityFinished curAc) $
 504         if actionLogAction (entityVal curAc) == Running
 505           then endAction (entityKey curAc) True
 506           else error "Another intervention appears to be running"
 507     startAction action
 508   putAction actionId
 509   result <- runErrorT intervention
 510   doLeft (lift . putStrLn . show) result
 511   runSqlQuery $ endAction actionId $ isRight result
 512
 513
 514 --------------------------------------------------------------------------------
 515 runWebsocket :: WS.ClientApp a -> RootstockIO a
 516 runWebsocket app = gets websocket >>= lift . app
 517
 518 receiveData :: WS.WebSocketsData a => RootstockIO a
 519 receiveData = runWebsocket WS.receiveData
 520
 521 sendTextData :: WS.WebSocketsData a => a -> RootstockIO ()
 522 sendTextData x = runWebsocket $ flip WS.sendTextData x
 523
 524 waitForType :: FromJSON a => RootstockIO a
 525 waitForType = do
 526   encoded <- receiveData
 527   case decode encoded of
 528     Nothing -> do
 529       lift $ putStrLn ("Skipping:\n" ++ (BSL8.unpack encoded))
 530       waitForType
 531     Just result -> do
 532       lift $ putStrLn ("Using:\n" ++ (BSL8.unpack encoded))
 533       return result
 534
 535 waitForResponseWithId :: (Eq id, FromJSON id, FromJSON a)
 536   => id -> RootstockIO (Maybe a)
 537 waitForResponseWithId idSought = do
 538   RippleResult i x <- waitForType
 539   if i == Just idSought
 540     then return $ either (const Nothing) Just x
 541     else waitForResponseWithId idSought
 542
 543 askUntilAnswered :: FromJSON a => [Pair] -> RootstockIO a
 544 askUntilAnswered question = do
 545   qTime <- show <$> liftIO getCurrentTime
 546   sendTextData $ encode $ object $ ("id" .= qTime) : question
 547   aifM (waitForResponseWithId qTime) return $ do
 548     waitForType :: RootstockIO Ledger
 549     askUntilAnswered question
 550
 551 signAndSubmit :: Transaction -> RootstockIO ()
 552 signAndSubmit tx = do
 553   Right (txSigned, rGen) <- signTransaction tx <$> gets secret <*> gets randGen
 554   modify $ \rs -> rs {randGen = rGen}
 555   sendTextData $ encode $ object
 556     [ "command" .= ("submit" :: Text)
 557     , "tx_blob" .= BSL8.unpack (H.encode $ B.encode txSigned)
 558     ]
 559
 560 subscribe :: [Pair] -> WS.ClientApp ()
 561 subscribe options =
 562   flip WS.sendTextData $ encode $ object $
 563     ["command"   .= ("subscribe" :: Text)] ++ options
 564
 565 subscribeLedger :: WS.ClientApp ()
 566 subscribeLedger = subscribe ["streams" .= ["ledger" :: Text]]
 567
 568 subscribeAccount :: WS.ClientApp ()
 569 subscribeAccount = subscribe ["accounts" .= [account]]
 570
 571 subscribeLedgerAndAccount :: WS.ClientApp()
 572 subscribeLedgerAndAccount = subscribe
 573     [ "streams"   .= ["ledger" :: Text]
 574     , "accounts"  .= [account]
 575     ]
 576
 577 queryOwnAccount :: FromJSON a => Text -> RootstockIO a
 578 queryOwnAccount command = askUntilAnswered
 579     [ "command" .= command
 580     , "account" .= account
 581     , "ledger_index" .= ("validated" :: Text)
 582     ]
 583
 584 getAccountInfo :: RootstockIO AccountInfo
 585 getAccountInfo = queryOwnAccount "account_info"
 586
 587 getAccountLines :: RootstockIO AccountLines
 588 getAccountLines = queryOwnAccount "account_lines"
 589
 590 getAccountOffers :: RootstockIO Offers
 591 getAccountOffers = queryOwnAccount "account_offers"
 592
 593 getCurrentAccountInfo :: Text -> RootstockIO AccountInfo
 594 getCurrentAccountInfo peer = askUntilAnswered
 595     [ "command" .= ("account_info" :: Text)
 596     , "account" .= peer
 597     , "ledger_index" .= ("current" :: Text)
 598     ]
 599
 600 valueSimplexEmpty :: RootstockIO Bool
 601 valueSimplexEmpty = isEmpty <$> gets valueSimplex
 602
 603 putValueSimplex :: ValueSimplexND -> RootstockIO ()
 604 putValueSimplex vs = modify $ \rs -> rs {valueSimplex = vs}
 605
 606 putSequence :: Word32 -> RootstockIO ()
 607 putSequence nextSeq = modify $ \rs -> rs {nextSequence = nextSeq}
 608
 609 getAndPutSequence :: RootstockIO ()
 610 getAndPutSequence =
 611   currentSequence <$> getCurrentAccountInfo account >>= putSequence
 612
 613 ownActionGoingQuery :: RootstockIO (SqlPersistM Bool)
 614 ownActionGoingQuery = do
 615   actId <- gets rsAction
 616   return $ maybe False (not . actionFinished) <$> P.get actId
 617
 618 ifRunning :: SqlPersistM () -> ExceptionalRootstock ()
 619 ifRunning query = do
 620   goingQ <- lift ownActionGoingQuery
 621   mapErrorT runSqlQuery $ do
 622     going <- lift $ goingQ
 623     throwIf NotRunning $ not going
 624     lift query
 625
 626 checkRunning :: ExceptionalRootstock ()
 627 checkRunning = ifRunning $ return ()
 628
 629 submitUntilSequenceCatchup' :: [Transaction] -> ExceptionalRootstock ()
 630 submitUntilSequenceCatchup' txs = unless (null txs) $ do
 631   checkRunning
 632   forM_ txs $ lift . signAndSubmit
 633   lift (waitForType :: RootstockIO Ledger)
 634   curSeq <- currentSequence <$> lift getAccountInfo
 635   submitUntilSequenceCatchup' $ dropWhile ((curSeq >) . getSequence) txs
 636
 637 submitUntilSequenceCatchup :: [Transaction] -> ExceptionalRootstock ()
 638 submitUntilSequenceCatchup txs = do
 639   lift $ putSequence =<< (fromIntegral (length txs) +) <$> gets nextSequence
 640   submitUntilSequenceCatchup' txs
 641
 642 clearAndUpdate :: ExceptionalRootstock ()
 643 {- Must have subscribed to ledger updates for this to work -}
 644 clearAndUpdate = do
 645   Offers offerList <- lift getAccountOffers
 646   if null offerList
 647   then do
 648     acInfo <- lift getAccountInfo
 649     acLines <- lift getAccountLines
 650     vs <- lift $ gets valueSimplex
 651     let vs' = updatedValueSimplex vs acInfo acLines
 652     when (status (~~=) vs' /= OK) $ error "Invalid updated ValueSimplex!"
 653     ifRunning $ do
 654       unless (strictlySuperior (~~=) vs' vs) $ do
 655         let
 656           vs'' = updatedValueSimplexWithGenerosity generosity vs acInfo acLines
 657           warning
 658             =           " non-superior ValueSimplex (generosity: "
 659             `T.append`  T.pack (show generosity)
 660             `T.append`  ")"
 661         if strictlySuperior (~~=) vs'' vs
 662           then warn $ "Slightly" `T.append` warning
 663           else error $ "Seriously" ++ T.unpack warning
 664       writeValueSimplex acInfo acLines vs'
 665     lift $ putValueSimplex vs'
 666   else do
 667     curSeq <- lift $ gets nextSequence
 668     submitUntilSequenceCatchup $ commonTransactionStuff curSeq $
 669       flip map offerList $ \off -> Transaction
 670         [ TransactionType OfferCancel
 671         , OfferSequence $ offerSequence off
 672         ]
 673     clearAndUpdate
 674
 675 strictlySuperiorToCurrent :: ValueSimplexND -> RootstockIO Bool
 676 strictlySuperiorToCurrent vs' = strictlySuperior (~~=) vs' <$> gets valueSimplex
 677
 678 waitForImprovement :: ExceptionalRootstock ()
 679 waitForImprovement = do
 680   checkRunning
 681   Offers offerList <- lift getAccountOffers
 682   unlessM
 683     (lift $ strictlySuperiorToCurrent =<<
 684       (updatedValueSimplexWithGenerosity
 685         (fromInteger $ (negate feeInDrops *) $ toInteger $ length offerList)
 686         <$> gets valueSimplex
 687         <*> getAccountInfo
 688         <*> getAccountLines
 689     )) $ do
 690     lift (waitForType :: RootstockIO Ledger)
 691     lift (waitForType :: RootstockIO RecordedTransaction)
 692     waitForImprovement
 693
 694 submitAndWait :: [Transaction] -> ExceptionalRootstock ()
 695 submitAndWait txs = do
 696   submitUntilSequenceCatchup txs
 697   waitForImprovement
 698
 699 getTransitRates :: RootstockIO (NodeEntity -> Double)
 700 getTransitRates = do
 701   peers <- catMaybes . toList . Set.map peerOfNodeEntity . nodes
 702     <$> gets valueSimplex
 703   trm <- buildMap peers $ \peer -> transferRate <$> getCurrentAccountInfo peer
 704   return $ \x -> fromMaybe 1 $ peerOfNodeEntity x >>= flip Map.lookup trm
 705
 706 startRunning :: RootstockIO ()
 707 startRunning = do
 708   mavs <- runSqlQuery $ do
 709     mcurAc <- getCurrentAction
 710     case mcurAc of
 711       Nothing     -> error $ show DatabaseNotSetUp
 712       Just curAc  ->
 713         if actionEntityFinished curAc
 714           then do
 715             actId <- startAction Running
 716             vs <- readValueSimplex
 717             return $ Just (actId, vs)
 718           else return Nothing
 719   case mavs of
 720     Nothing -> do
 721       waitForType :: RootstockIO Ledger
 722       startRunning
 723     Just (actId, vs) -> do
 724       putAction actId
 725       putValueSimplex vs
 726       getAndPutSequence
 727
 728 ensureRunning :: RootstockIO ()
 729 ensureRunning =
 730   unlessM (join $ runSqlQuery <$> ownActionGoingQuery)
 731     startRunning
 732
 733 marketMakerLoop :: RootstockIO ()
 734 marketMakerLoop = do
 735   runErrorT $ do
 736     clearAndUpdate
 737     lift
 738         ( makeTransactions
 739         <$> gets valueSimplex
 740         <*> getTransitRates
 741         <*> gets nextSequence
 742         )
 743       >>= submitAndWait
 744   ensureRunning
 745   marketMakerLoop
 746
 747
 748 --------------------------------------------------------------------------------
 749 getLineBal :: AccountLines -> IOULine -> ExceptionalRootstock Double
 750 getLineBal acLines fundLine = do
 751   lineBal <- case lookupLine acLines fundLine of
 752     Nothing -> throwError LineNotFound
 753     Just amount -> return $ getQuantity amount
 754   throwIf NonPositiveLine $ lineBal <= 0
 755   return lineBal
 756
 757 setupDatabase :: IOULine -> ExceptionalRootstock ()
 758 setupDatabase fundLine = do
 759   isEmpt <- lift $ valueSimplexEmpty
 760   throwIf DatabaseExists $ not isEmpt
 761   lift $ runWebsocket subscribeLedger
 762   acInfo <- lift getAccountInfo
 763   let dropsBal = getQuantity $ lookupXRP acInfo
 764   throwIf InsufficientForReserve $ dropsBal <= 0
 765   acLines <- lift getAccountLines
 766   lineBal <- getLineBal acLines fundLine
 767   lift $ runSqlQuery $ do
 768     xrpNodeEntity   <- insertReturnEntity $ Node {nodeFund = XRP}
 769     lineNodeEntity  <- insertReturnEntity $ Node {nodeFund = IOUFund fundLine}
 770     writeValueSimplex acInfo acLines $
 771       flip fromFunction (Set.fromList [xrpNodeEntity, lineNodeEntity]) $ \x _ ->
 772         if x == xrpNodeEntity
 773         then dropsBal
 774         else lineBal
 775
 776 addCurrency :: IOULine -> Double -> ExceptionalRootstock ()
 777 addCurrency fundLine priceInDrops = do
 778   mxrpNodeEntity <- lift $ runSqlQuery $ getBy $ NodeUnique XRP
 779   xrpNodeEntity <- maybe (throwError DatabaseNotSetUp) return mxrpNodeEntity
 780   throwIf NonPositivePrice $ priceInDrops <= 0
 781   let lineFund = IOUFund fundLine
 782   alreadyPresent <-
 783     isJust <$> (lift $ runSqlQuery $ getBy $ NodeUnique lineFund)
 784   throwIf CurrencyAlreadyPresent alreadyPresent
 785   lift $ runWebsocket subscribeLedgerAndAccount
 786   lift $ getAndPutSequence
 787   clearAndUpdate
 788   acLines <- lift getAccountLines
 789   lineBal <- getLineBal acLines fundLine
 790   vs <- lift $ gets valueSimplex
 791   throwIf NewOutweighsOld $
 792     priceInDrops * lineBal >= totalValue vs xrpNodeEntity
 793   acInfo <- lift getAccountInfo
 794   lift $ runSqlQuery $ do
 795     lineNodeEntity <- insertReturnEntity $ Node {nodeFund = lineFund}
 796     writeValueSimplex acInfo acLines $
 797       addNode vs lineNodeEntity lineBal xrpNodeEntity priceInDrops
 798
 799 report :: RootstockIO ()
 800 report = do
 801   now <- liftIO getCurrentTime
 802   (vs, lastInterventionTime) <- runSqlQuery $ do
 803     [Value (Just lastInterventionTime)] <- select $ from $ \acEnt -> do
 804       where_ $ acEnt ^. ActionLogAction !=. val Running
 805       orderBy [desc $ acEnt ^. ActionLogStart]
 806       limit 1
 807       return $ acEnt ^. ActionLogEnd
 808     vs <- readValueSimplexAt lastInterventionTime
 809     return (vs, lastInterventionTime)
 810   vs' <- gets valueSimplex
 811   let xs = nodes vs
 812   liftIO $ do
 813     let xys = distinctPairsOneWay xs
 814         v = halfLinkValue vs
 815         v' = halfLinkValue vs'
 816         recipYears =
 817           60 * 60 * 24 * 365
 818             / (fromRational $ toRational $
 819               diffUTCTime now lastInterventionTime)
 820         x0 = Set.findMin xs
 821         x0Value = totalValue vs' x0
 822         x0Gain = flip sumWith xys $ \(x, y) ->
 823           2 * hybridPrice vs' x y x0 * (v' x y - v x y)
 824     forM_ xys $ \(x, y) -> mapM_ putStrLn
 825       [ show $ nodeEntityFund x
 826       , show $ nodeEntityFund y
 827       , show $
 828         (v' x y / v x y)
 829           ** recipYears
 830       , show $ 2 * hybridPrice vs' x y x0 * v' x y / x0Value
 831       , ""
 832       ]
 833     forM_ xs $ \x -> mapM_ putStrLn
 834       [ show $ nodeEntityFund x
 835       , show $ totalValue vs' x
 836       , show $ x0Gain / price vs' x x0
 837       , show $ nodeValue vs' x / totalValue vs' x
 838       , ""
 839       ]
 840     putStrLn $ show $ (1 + x0Gain / x0Value) ** recipYears
 841
 842 promptDeposit :: ExceptionalRootstock ()
 843 promptDeposit = do
 844   liftIO $ putStrLn "Please wait while I cancel all offers ..."
 845   lift $ runWebsocket subscribeLedger
 846   lift getAndPutSequence
 847   clearAndUpdate
 848   liftIO $ mapM_ putStrLn
 849     [ "... Finished!"
 850     , "Please deposit into account "
 851       ++ T.unpack account
 852       ++ " and press Enter to continue."
 853     ]
 854   liftIO getLine
 855   lift (waitForType :: RootstockIO Ledger)
 856   vs <- lift $ gets valueSimplex
 857   acInfo <- lift getAccountInfo
 858   acLines <- lift getAccountLines
 859   lift $ runSqlQuery $ writeValueSimplex acInfo acLines $
 860     deposit vs $ lookupGetQuantity acInfo acLines
 861
 862
 863 --------------------------------------------------------------------------------
 864 runRootstock :: RootstockIO a -> Rootstock -> IO a
 865 runRootstock = evalStateT
 866
 867 marketMaker :: RootstockIO ()
 868 marketMaker = do
 869   isEmpt <- valueSimplexEmpty
 870   when isEmpt $ error $ show DatabaseNotSetUp
 871   runWebsocket subscribeLedgerAndAccount
 872   startRunning
 873   rs <- get
 874   liftIO $ catch (runRootstock marketMakerLoop rs) $ \e -> do
 875       flip runSqlPersistM (sql rs) $ do
 876         curAc <- fromJust <$> getCurrentAction
 877         if actionRunning curAc
 878           then
 879             endAction
 880               (entityKey curAc)
 881               $ fromException e `elem` map Just [ThreadKilled, UserInterrupt]
 882           else return ()
 883       putStrLn $ "Exiting on: " ++ show e
 884
 885 rippleInteract :: WS.ClientApp ()
 886 rippleInteract conn = do
 887   -- Fork a thread that writes WS data to stdout
 888   _ <- forkIO $ forever $ do
 889       msg <- WS.receiveData conn
 890       liftIO $ T.putStrLn msg
 891
 892   runRipple subscribeAccount
 893
 894   -- Read from stdin and write to WS
 895   let loop = do
 896           line <- T.getLine
 897           unless (T.null line) $ WS.sendTextData conn line >> loop
 898
 899   loop
 900   WS.sendClose conn ("Bye!" :: Text)
 901
 902 readSecret :: IO String
 903 readSecret = readFile secretFile
 904
 905 readSqlPass :: IO BS.ByteString
 906 readSqlPass = BS.pack <$> readFile sqlPassFile
 907
 908 runRipple :: WS.ClientApp a -> IO a
 909 runRipple app = WS.runClient "127.0.0.1" 5006 "/" app
 910
 911 runRippleWithSecret :: RootstockIO a -> IO a
 912 runRippleWithSecret app = do
 913   sec <- readSecret
 914   sqlPass <- readSqlPass
 915   rGen <- newGenIO
 916   withPostgresqlConn (BS.concat [connString, sqlPass]) $ \sqlConn -> do
 917     vs <- flip runSqlPersistM sqlConn $ do
 918       runMigration migrateAll
 919       readValueSimplex
 920     runRipple $ \wsConn ->
 921       runRootstock app $ Rootstock
 922         { websocket     = wsConn
 923         , secret        = getSecret $ read sec
 924         , sql           = sqlConn
 925         , valueSimplex  = vs
 926         , nextSequence  = 0
 927         , rsAction      = noAction
 928         , randGen       = rGen
 929         }
 930
 931 main :: IO ()
 932 main = do
 933   args <- getArgs
 934   case args of
 935     ["setup", currency, peer] -> runRippleWithSecret $ intervene InitialSetup $
 936       setupDatabase $ IOULine
 937         { peerAccount   = T.pack peer
 938         , lineCurrency  = T.pack currency
 939         }
 940     ["run"] -> runRippleWithSecret marketMaker
 941     ["addCurrency", currency, peer, priceInXRP] ->
 942       runRippleWithSecret $ intervene AddNode $ addCurrency
 943         ( IOULine
 944           { peerAccount   = T.pack peer
 945           , lineCurrency  = T.pack currency
 946           }
 947         )
 948         $ read priceInXRP * 1000000
 949     ["report"] -> runRippleWithSecret report
 950     ["interact"] -> runRipple rippleInteract
 951     ["deposit"] -> runRippleWithSecret $ intervene Deposit $ promptDeposit
 952     _ -> putStrLn "Command not understood"
 953