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