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, sqlPassFile :: FilePath
 243 secretFile = "/home/tim/Documents/passwords/ripple-secret.gpg"
 244 sqlPassFile = "/home/tim/Documents/passwords/sql-password.gpg"
 245
 246 connString :: BS.ByteString
 247 connString = "host=localhost port=5432 user=tim dbname=rootstock-test password="
 248
 249 account :: Text
 250 account  = "rpY4wdftAiEH5y5uzxC2XAvy3G27UyeQKS"
 251
 252 fee, tfSell, reserve :: Integer
 253 fee = 10
 254 tfSell = 0x00080000
 255 reserve = 200000000
 256
 257 generosity, halfSpread :: Double
 258 generosity = 1000000
 259 halfSpread = 1.01
 260
 261 noAction :: ActionLogId
 262 noAction = Key PersistNull
 263
 264 lookupXRP :: AccountInfo -> Amount
 265 lookupXRP acInfo = Drops $ dropsBalance acInfo - reserve
 266
 267 lookupLine :: AccountLines -> IOULine -> Maybe Amount
 268 lookupLine (AccountLines lines) fundLine = do
 269   foundLine <- find ((fundLine ==) . iouLine) lines
 270   return $ IOU foundLine
 271
 272 lookupFund :: AccountInfo -> AccountLines -> Fund -> Maybe Amount
 273 lookupFund acInfo _ XRP = Just $ lookupXRP acInfo
 274 lookupFund _ acLines (IOUFund fundLine) = lookupLine acLines fundLine
 275
 276 getQuantity :: Amount -> Double
 277 getQuantity (Drops n) = fromInteger n
 278 getQuantity (IOU iou) = iouQuantity iou
 279
 280 getSequence :: Transaction -> Integer
 281 getSequence (OfferCreate _ _ curSeq _) = curSeq
 282 getSequence (OfferCancel curSeq _) = curSeq
 283
 284 lookupGetQuantity :: AccountInfo -> AccountLines -> NodeEntity -> Double
 285 lookupGetQuantity acInfo acLines =
 286   fromMaybe 0 . liftM getQuantity .
 287     lookupFund acInfo acLines . nodeFund . entityVal
 288
 289 fromNodeEntity :: a -> (IOULine -> a) -> NodeEntity -> a
 290 fromNodeEntity d f x = case nodeFund $ entityVal x of
 291   XRP       -> d
 292   IOUFund l -> f l
 293
 294 amount :: Double -> NodeEntity -> Amount
 295 amount q =
 296   fromNodeEntity (Drops $ round q) $ \l ->
 297     IOU $ IOUAmount {iouLine = l, iouQuantity = q}
 298
 299 peerOfNodeEntity :: NodeEntity -> Maybe Text
 300 peerOfNodeEntity = fromNodeEntity Nothing $ Just . peerAccount
 301
 302 actionFinished :: ActionLog -> Bool
 303 actionFinished = isJust . actionLogEnd
 304
 305 actionEntityFinished :: Entity ActionLog -> Bool
 306 actionEntityFinished = actionFinished . entityVal
 307
 308 actionRunning :: Entity ActionLog -> Bool
 309 actionRunning acEnt =
 310   actionLogAction (entityVal acEnt) == Running
 311   && not (actionEntityFinished acEnt)
 312
 313 updatedValueSimplexWithGenerosity ::
 314   Double -> ValueSimplexND -> AccountInfo -> AccountLines -> ValueSimplexND
 315 updatedValueSimplexWithGenerosity gen vs acInfo acLines =
 316   multiUpdate vs $ \nodeEnt ->
 317     let actual = lookupGetQuantity acInfo acLines nodeEnt in
 318     case nodeFund $ entityVal nodeEnt of
 319       XRP -> gen + actual
 320       _   -> actual
 321
 322 updatedValueSimplex ::
 323   ValueSimplexND -> AccountInfo -> AccountLines -> ValueSimplexND
 324 updatedValueSimplex = updatedValueSimplexWithGenerosity 0
 325
 326 makeTransactions ::
 327   ValueSimplexND -> (NodeEntity -> Double) -> Integer -> [Transaction]
 328 makeTransactions vs trf nextSeq =
 329   flip
 330     (flip zipWith $ Set.toList $ distinctPairs $ nodes vs)
 331     [nextSeq ..]
 332     $ \(x0, x1) curSeq ->
 333     let (q0, q1) = linkOptimumAtPrice vs x0 x1 $ halfSpread * price vs x0 x1 in
 334     OfferCreate (amount (-q0 / trf x0) x0) (amount q1 x1) curSeq Nothing
 335
 336 --------------------------------------------------------------------------------
 337 getSqlConnection :: RootstockIO Connection
 338 getSqlConnection = gets sql
 339
 340 runSqlQuery :: SqlPersistM a -> RootstockIO a
 341 runSqlQuery query = do
 342   sqlConn <- getSqlConnection
 343   lift $ runSqlPersistM query sqlConn
 344
 345 getNodeEntities :: SqlPersistM [NodeEntity]
 346 getNodeEntities = select $ from return
 347
 348 readValueSimplexAt :: UTCTime -> SqlPersistM ValueSimplexND
 349 readValueSimplexAt time = do
 350   nodeSet <- Set.fromList <$> getNodeEntities
 351   qMap <- buildMap (Set.toList $ distinctPairs nodeSet) $ \(x, y) -> do
 352       [Value q] <- select $ from $ \hl -> do
 353         where_
 354           $   hl ^. HalfLinkRoot    ==. val (entityKey x)
 355           &&. hl ^. HalfLinkBranch  ==. val (entityKey y)
 356           &&. hl ^. HalfLinkTime    <=. val time
 357         orderBy [desc $ hl ^. HalfLinkTime]
 358         limit 1
 359         return $ hl ^. HalfLinkQuantity
 360       return q
 361   return $ fromFunction (curry $ flip (Map.findWithDefault 0) qMap) nodeSet
 362
 363 readValueSimplex :: SqlPersistM ValueSimplexND
 364 readValueSimplex = liftIO getCurrentTime >>= readValueSimplexAt
 365
 366 writeValueSimplex ::
 367   AccountInfo -> AccountLines -> ValueSimplexND -> SqlPersistM ()
 368 writeValueSimplex acInfo acLines vs = do
 369   time <- liftIO getCurrentTime
 370   insertMany $ flip map (Set.toList $ nodes vs) $ \nodeEnt -> FundStatus
 371     { fundStatusFundId    = entityKey nodeEnt
 372     , fundStatusQuantity  = lookupGetQuantity acInfo acLines nodeEnt
 373     , fundStatusTime      = time
 374     }
 375   forM_ (distinctPairs $ nodes vs) $ \(x, y) -> insert_ $ HalfLink
 376       { halfLinkRoot      = entityKey x
 377       , halfLinkBranch    = entityKey y
 378       , halfLinkQuantity  = vsLookup vs x y
 379       , halfLinkTime      = time
 380       }
 381
 382 warn :: Text -> SqlPersistM ()
 383 warn warning = do
 384   now <- liftIO getCurrentTime
 385   insert_ $ Warning
 386     { warningWarning  = warning
 387     , warningTime     = now
 388     }
 389
 390 getCurrentAction :: SqlPersistM (Maybe (Entity ActionLog))
 391 getCurrentAction = liftM listToMaybe $ select $ from $ \ac -> do
 392   orderBy [desc $ ac ^. ActionLogStart]
 393   limit 1
 394   return ac
 395
 396 startAction :: Action -> SqlPersistM ActionLogId
 397 startAction action = do
 398   start <- liftIO getCurrentTime
 399   insert $ ActionLog
 400     { actionLogAction   = action
 401     , actionLogStart    = start
 402     , actionLogEnd      = Nothing
 403     , actionLogSuccess  = Nothing
 404     }
 405
 406 endAction :: ActionLogId -> Bool -> SqlPersistM ()
 407 endAction actionId success = do
 408   end <- liftIO getCurrentTime
 409   P.update actionId
 410     [ ActionLogEnd      =. Just end
 411     , ActionLogSuccess  =. Just success
 412     ]
 413
 414 putAction :: ActionLogId -> RootstockIO ()
 415 putAction actionId = modify $ \rs -> rs {rsAction = actionId}
 416
 417 intervene :: Action -> ExceptionalRootstock () -> RootstockIO ()
 418 intervene action intervention = do
 419   actionId <- runSqlQuery $ do
 420     awhenM getCurrentAction $ \curAc ->
 421       unless (actionEntityFinished curAc) $
 422         if actionLogAction (entityVal curAc) == Running
 423           then endAction (entityKey curAc) True
 424           else error "Another intervention appears to be running"
 425     startAction action
 426   putAction actionId
 427   result <- runErrorT intervention
 428   doLeft (lift . putStrLn . show) result
 429   runSqlQuery $ endAction actionId $ isRight result
 430
 431
 432 --------------------------------------------------------------------------------
 433 runWebsocket :: WS.ClientApp a -> RootstockIO a
 434 runWebsocket app = gets websocket >>= lift . app
 435
 436 receiveData :: WS.WebSocketsData a => RootstockIO a
 437 receiveData = runWebsocket WS.receiveData
 438
 439 sendTextData :: WS.WebSocketsData a => a -> RootstockIO ()
 440 sendTextData x = runWebsocket $ flip WS.sendTextData x
 441
 442 waitForType :: FromJSON a => RootstockIO a
 443 waitForType = do
 444   encoded <- receiveData
 445   case decode encoded of
 446     Nothing -> do
 447       lift $ putStrLn ("Skipping:\n" ++ (BSL8.unpack encoded))
 448       waitForType
 449     Just result -> do
 450       lift $ putStrLn ("Using:\n" ++ (BSL8.unpack encoded))
 451       return result
 452
 453 waitForResponseWithId :: (Eq id, FromJSON id, FromJSON a)
 454   => id -> RootstockIO (Maybe a)
 455 waitForResponseWithId idSought = do
 456   RippleResult i x <- waitForType
 457   if i == Just idSought
 458     then return $ either (const Nothing) Just x
 459     else waitForResponseWithId idSought
 460
 461 askUntilAnswered :: FromJSON a => [Pair] -> RootstockIO a
 462 askUntilAnswered question = do
 463   qTime <- show <$> liftIO getCurrentTime
 464   sendTextData $ encode $ object $ ("id" .= qTime) : question
 465   aifM (waitForResponseWithId qTime) return $ do
 466     waitForType :: RootstockIO Ledger
 467     askUntilAnswered question
 468
 469 submitToTrustedServer :: Transaction -> RootstockIO ()
 470 submitToTrustedServer tx = do
 471   sec <- gets secret
 472   sendTextData $ encode $ object
 473     [ "command" .= ("submit" :: Text)
 474     , "tx_json" .= tx
 475     , "secret"  .= sec
 476     ]
 477
 478 subscribe :: [Pair] -> WS.ClientApp ()
 479 subscribe options =
 480   flip WS.sendTextData $ encode $ object $
 481     ["command"   .= ("subscribe" :: Text)] ++ options
 482
 483 subscribeLedger :: WS.ClientApp ()
 484 subscribeLedger = subscribe ["streams" .= ["ledger" :: Text]]
 485
 486 subscribeAccount :: WS.ClientApp ()
 487 subscribeAccount = subscribe ["accounts" .= [account]]
 488
 489 subscribeLedgerAndAccount :: WS.ClientApp()
 490 subscribeLedgerAndAccount = subscribe
 491     [ "streams"   .= ["ledger" :: Text]
 492     , "accounts"  .= [account]
 493     ]
 494
 495 queryOwnAccount :: FromJSON a => Text -> RootstockIO a
 496 queryOwnAccount command = askUntilAnswered
 497     [ "command" .= command
 498     , "account" .= account
 499     , "ledger_index" .= ("validated" :: Text)
 500     ]
 501
 502 getAccountInfo :: RootstockIO AccountInfo
 503 getAccountInfo = queryOwnAccount "account_info"
 504
 505 getAccountLines :: RootstockIO AccountLines
 506 getAccountLines = queryOwnAccount "account_lines"
 507
 508 getAccountOffers :: RootstockIO Offers
 509 getAccountOffers = queryOwnAccount "account_offers"
 510
 511 getCurrentAccountInfo :: Text -> RootstockIO AccountInfo
 512 getCurrentAccountInfo peer = askUntilAnswered
 513     [ "command" .= ("account_info" :: Text)
 514     , "account" .= peer
 515     , "ledger_index" .= ("current" :: Text)
 516     ]
 517
 518 valueSimplexEmpty :: RootstockIO Bool
 519 valueSimplexEmpty = isEmpty <$> gets valueSimplex
 520
 521 putValueSimplex :: ValueSimplexND -> RootstockIO ()
 522 putValueSimplex vs = modify $ \rs -> rs {valueSimplex = vs}
 523
 524 putSequence :: Integer -> RootstockIO ()
 525 putSequence nextSeq = modify $ \rs -> rs {nextSequence = nextSeq}
 526
 527 getAndPutSequence :: RootstockIO ()
 528 getAndPutSequence =
 529   currentSequence <$> getCurrentAccountInfo account >>= putSequence
 530
 531 ownActionGoingQuery :: RootstockIO (SqlPersistM Bool)
 532 ownActionGoingQuery = do
 533   actId <- gets rsAction
 534   return $ maybe False (not . actionFinished) <$> P.get actId
 535
 536 ifRunning :: SqlPersistM () -> ExceptionalRootstock ()
 537 ifRunning query = do
 538   goingQ <- lift ownActionGoingQuery
 539   mapErrorT runSqlQuery $ do
 540     going <- lift $ goingQ
 541     throwIf NotRunning $ not going
 542     lift query
 543
 544 checkRunning :: ExceptionalRootstock ()
 545 checkRunning = ifRunning $ return ()
 546
 547 submitUntilSequenceCatchup' :: [Transaction] -> ExceptionalRootstock ()
 548 submitUntilSequenceCatchup' txs = unless (null txs) $ do
 549   checkRunning
 550   forM_ txs $ lift . submitToTrustedServer
 551   lift (waitForType :: RootstockIO Ledger)
 552   curSeq <- currentSequence <$> lift getAccountInfo
 553   submitUntilSequenceCatchup' $ dropWhile ((curSeq >) . getSequence) txs
 554
 555 submitUntilSequenceCatchup :: [Transaction] -> ExceptionalRootstock ()
 556 submitUntilSequenceCatchup txs = do
 557   lift $ putSequence =<< (toInteger (length txs) +) <$> gets nextSequence
 558   submitUntilSequenceCatchup' txs
 559
 560 clearAndUpdate :: ExceptionalRootstock ()
 561 {- Must have subscribed to ledger updates for this to work -}
 562 clearAndUpdate = do
 563   Offers offerList <- lift getAccountOffers
 564   if null offerList
 565   then do
 566     acInfo <- lift getAccountInfo
 567     acLines <- lift getAccountLines
 568     vs <- lift $ gets valueSimplex
 569     let vs' = updatedValueSimplex vs acInfo acLines
 570     when (status (~~=) vs' /= OK) $ error "Invalid updated ValueSimplex!"
 571     ifRunning $ do
 572       unless (strictlySuperior (~~=) vs' vs) $ do
 573         let
 574           vs'' = updatedValueSimplexWithGenerosity generosity vs acInfo acLines
 575           warning
 576             =           " non-superior ValueSimplex (generosity: "
 577             `T.append`  T.pack (show generosity)
 578             `T.append`  ")"
 579         if strictlySuperior (~~=) vs'' vs
 580           then warn $ "Slightly" `T.append` warning
 581           else error $ "Seriously" ++ T.unpack warning
 582       writeValueSimplex acInfo acLines vs'
 583     lift $ putValueSimplex vs'
 584   else do
 585     curSeq <- lift $ gets nextSequence
 586     submitUntilSequenceCatchup $ zipWith
 587       (\off sequ -> OfferCancel sequ $ offerSequence off)
 588       offerList
 589       [curSeq ..]
 590     clearAndUpdate
 591
 592 getUpdatedValueSimplexWithAccountInfo ::
 593   AccountInfo -> RootstockIO ValueSimplexND
 594 getUpdatedValueSimplexWithAccountInfo acInfo =
 595   updatedValueSimplex <$> gets valueSimplex <*> pure acInfo <*> getAccountLines
 596
 597 getUpdatedValueSimplex :: RootstockIO ValueSimplexND
 598 getUpdatedValueSimplex =
 599   getUpdatedValueSimplexWithAccountInfo =<< getAccountInfo
 600
 601 strictlySuperiorToCurrent :: ValueSimplexND -> RootstockIO Bool
 602 strictlySuperiorToCurrent vs' = strictlySuperior (~~=) vs' <$> gets valueSimplex
 603
 604 waitForImprovement :: ExceptionalRootstock ()
 605 waitForImprovement = do
 606   checkRunning
 607   unlessM (lift $ strictlySuperiorToCurrent =<< getUpdatedValueSimplex) $ do
 608     lift (waitForType :: RootstockIO Ledger)
 609     lift (waitForType :: RootstockIO RecordedTransaction)
 610     waitForImprovement
 611
 612 submitAndWait :: [Transaction] -> ExceptionalRootstock ()
 613 submitAndWait txs = do
 614   submitUntilSequenceCatchup txs
 615   waitForImprovement
 616
 617 getTransitRates :: RootstockIO (NodeEntity -> Double)
 618 getTransitRates = do
 619   peers <- catMaybes . Set.toList . Set.map peerOfNodeEntity . nodes
 620     <$> gets valueSimplex
 621   trm <- buildMap peers $ \peer -> transferRate <$> getCurrentAccountInfo peer
 622   return $ \x -> fromMaybe 1 $ peerOfNodeEntity x >>= flip Map.lookup trm
 623
 624 startRunning :: RootstockIO ()
 625 startRunning = do
 626   mavs <- runSqlQuery $ do
 627     mcurAc <- getCurrentAction
 628     case mcurAc of
 629       Nothing     -> error $ show DatabaseNotSetUp
 630       Just curAc  ->
 631         if actionEntityFinished curAc
 632           then do
 633             actId <- startAction Running
 634             vs <- readValueSimplex
 635             return $ Just (actId, vs)
 636           else return Nothing
 637   case mavs of
 638     Nothing -> do
 639       waitForType :: RootstockIO Ledger
 640       startRunning
 641     Just (actId, vs) -> do
 642       putAction actId
 643       putValueSimplex vs
 644       getAndPutSequence
 645
 646 ensureRunning :: RootstockIO ()
 647 ensureRunning =
 648   unlessM (join $ runSqlQuery <$> ownActionGoingQuery)
 649     startRunning
 650
 651 marketMakerLoop :: RootstockIO ()
 652 marketMakerLoop = do
 653   runErrorT $ do
 654     clearAndUpdate
 655     lift
 656         ( makeTransactions
 657         <$> gets valueSimplex
 658         <*> getTransitRates
 659         <*> gets nextSequence
 660         )
 661       >>= submitAndWait
 662   ensureRunning
 663   marketMakerLoop
 664
 665
 666 --------------------------------------------------------------------------------
 667 getLineBal :: AccountLines -> IOULine -> ExceptionalRootstock Double
 668 getLineBal acLines fundLine = do
 669   lineBal <- case lookupLine acLines fundLine of
 670     Nothing -> throwError LineNotFound
 671     Just amount -> return $ getQuantity amount
 672   throwIf NonPositiveLine $ lineBal <= 0
 673   return lineBal
 674
 675 setupDatabase :: IOULine -> ExceptionalRootstock ()
 676 setupDatabase fundLine = do
 677   isEmpt <- lift $ valueSimplexEmpty
 678   throwIf DatabaseExists $ not isEmpt
 679   lift $ runWebsocket subscribeLedger
 680   acInfo <- lift getAccountInfo
 681   let dropsBal = getQuantity $ lookupXRP acInfo
 682   throwIf InsufficientForReserve $ dropsBal <= 0
 683   acLines <- lift getAccountLines
 684   lineBal <- getLineBal acLines fundLine
 685   lift $ runSqlQuery $ do
 686     xrpNodeEntity   <- insertReturnEntity $ Node {nodeFund = XRP}
 687     lineNodeEntity  <- insertReturnEntity $ Node {nodeFund = IOUFund fundLine}
 688     writeValueSimplex acInfo acLines $
 689       flip fromFunction (Set.fromList [xrpNodeEntity, lineNodeEntity]) $ \x _ ->
 690         if x == xrpNodeEntity
 691         then dropsBal
 692         else lineBal
 693
 694 addCurrency :: IOULine -> Double -> ExceptionalRootstock ()
 695 addCurrency fundLine priceInDrops = do
 696   mxrpNodeEntity <- lift $ runSqlQuery $ getBy $ NodeUnique XRP
 697   xrpNodeEntity <- maybe (throwError DatabaseNotSetUp) return mxrpNodeEntity
 698   throwIf NonPositivePrice $ priceInDrops <= 0
 699   let lineFund = IOUFund fundLine
 700   alreadyPresent <-
 701     isJust <$> (lift $ runSqlQuery $ getBy $ NodeUnique lineFund)
 702   throwIf CurrencyAlreadyPresent alreadyPresent
 703   lift $ runWebsocket subscribeLedgerAndAccount
 704   lift $ getAndPutSequence
 705   clearAndUpdate
 706   acLines <- lift getAccountLines
 707   lineBal <- getLineBal acLines fundLine
 708   vs <- lift $ gets valueSimplex
 709   throwIf NewOutweighsOld $
 710     priceInDrops * lineBal >= totalValue vs xrpNodeEntity
 711   acInfo <- lift getAccountInfo
 712   lift $ runSqlQuery $ do
 713     lineNodeEntity <- insertReturnEntity $ Node {nodeFund = lineFund}
 714     writeValueSimplex acInfo acLines $
 715       addNode vs lineNodeEntity lineBal xrpNodeEntity priceInDrops
 716
 717 report :: RootstockIO ()
 718 report = do
 719   now <- liftIO getCurrentTime
 720   (vs, lastInterventionTime) <- runSqlQuery $ do
 721     [Value (Just lastInterventionTime)] <- select $ from $ \acEnt -> do
 722       where_ $ acEnt ^. ActionLogAction !=. val Running
 723       orderBy [desc $ acEnt ^. ActionLogStart]
 724       limit 1
 725       return $ acEnt ^. ActionLogEnd
 726     vs <- readValueSimplexAt lastInterventionTime
 727     return (vs, lastInterventionTime)
 728   vs' <- gets valueSimplex
 729   let xs = nodes vs
 730   liftIO $ do
 731     let xys = distinctPairsOneWay xs
 732     let v = sqrt .! linkValueSquared vs
 733     let v' = sqrt .! linkValueSquared vs'
 734     forM_ xys $ \(x, y) -> mapM_ putStrLn
 735       [ show $ nodeFund $ entityVal x
 736       , show $ nodeFund $ entityVal y
 737       , show $
 738         (v' x y / v x y)
 739           ** ((60 * 60 * 24 * 365)
 740             / (fromRational $ toRational $
 741               diffUTCTime now lastInterventionTime))
 742       , ""
 743       ]
 744     let
 745       x0 = Set.findMin xs
 746       p = flip (price vs') x0
 747       x0Gain = flip sumWith xys $ \(x, y) ->
 748         2 * sqrt (p x) * sqrt (p y) * (v' x y - v x y)
 749     forM_ xs $ \x -> mapM_ putStrLn
 750       [ show $ nodeFund $ entityVal x
 751       , show $ totalValue vs' x
 752       , show $ x0Gain / p x
 753       , ""
 754       ]
 755
 756
 757 --------------------------------------------------------------------------------
 758 runRootstock :: RootstockIO a -> Rootstock -> IO a
 759 runRootstock = evalStateT
 760
 761 marketMaker :: RootstockIO ()
 762 marketMaker = do
 763   isEmpt <- valueSimplexEmpty
 764   when isEmpt $ error $ show DatabaseNotSetUp
 765   runWebsocket subscribeLedgerAndAccount
 766   startRunning
 767   rs <- get
 768   liftIO $ catch (runRootstock marketMakerLoop rs) $ \e -> do
 769       flip runSqlPersistM (sql rs) $ do
 770         curAc <- fromJust <$> getCurrentAction
 771         if actionRunning curAc
 772           then
 773             endAction
 774               (entityKey curAc)
 775               $ fromException e `elem` map Just [ThreadKilled, UserInterrupt]
 776           else return ()
 777       putStrLn $ "Exiting on: " ++ show e
 778
 779 rippleInteract :: WS.ClientApp ()
 780 rippleInteract conn = do
 781   -- Fork a thread that writes WS data to stdout
 782   _ <- forkIO $ forever $ do
 783       msg <- WS.receiveData conn
 784       liftIO $ T.putStrLn msg
 785
 786   runRipple subscribeAccount
 787
 788   -- Read from stdin and write to WS
 789   let loop = do
 790           line <- T.getLine
 791           unless (T.null line) $ WS.sendTextData conn line >> loop
 792
 793   loop
 794   WS.sendClose conn ("Bye!" :: Text)
 795
 796 readSecret :: IO String
 797 readSecret = readProcess "gpg" ["-o", "-", secretFile] ""
 798
 799 readSqlPass :: IO BS.ByteString
 800 readSqlPass = readProcess "gpg" ["-o", "-", sqlPassFile] "" >>= return . BS.pack
 801
 802 runRipple :: WS.ClientApp a -> IO a
 803 runRipple app = WS.runClient "qoheleth" 5006 "/" app
 804
 805 runRippleWithSecret :: RootstockIO a -> IO a
 806 runRippleWithSecret app = do
 807   sec <- readSecret
 808   sqlPass <- readSqlPass
 809   withPostgresqlConn (BS.concat [connString, sqlPass]) $ \sqlConn -> do
 810     vs <- flip runSqlPersistM sqlConn $ do
 811       runMigration migrateAll
 812       readValueSimplex
 813     runRipple $ \wsConn ->
 814       runRootstock app $ Rootstock
 815         { websocket     = wsConn
 816         , secret        = sec
 817         , sql           = sqlConn
 818         , valueSimplex  = vs
 819         , nextSequence  = 0
 820         , rsAction      = noAction
 821         }
 822
 823 main :: IO ()
 824 main = do
 825   args <- getArgs
 826   case args of
 827     ["setup", currency, peer] -> runRippleWithSecret $ intervene InitialSetup $
 828       setupDatabase $ IOULine
 829         { peerAccount   = T.pack peer
 830         , lineCurrency  = T.pack currency
 831         }
 832     ["run"] -> runRippleWithSecret marketMaker
 833     ["addCurrency", currency, peer, priceInXRP] ->
 834       runRippleWithSecret $ intervene AddNode $ addCurrency
 835         ( IOULine
 836           { peerAccount   = T.pack peer
 837           , lineCurrency  = T.pack currency
 838           }
 839         )
 840         $ read priceInXRP * 1000000
 841     ["report"] -> runRippleWithSecret report
 842     ["interact"] -> runRipple rippleInteract
 843     _ -> putStrLn "Command not understood"
 844