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