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