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