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, liftM, unless, when)
  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     when (status (~~=) vs' /= OK) $ error "Invalid updated ValueSimplex!"
 556     if strictlySuperior (~~=) vs' vs
 557       then return ()
 558       else do
 559         let
 560           vs'' = updatedValueSimplexWithGenerosity generosity vs acInfo acLines
 561           warning
 562             =           " non-superior ValueSimplex (generosity: "
 563             `T.append`  T.pack (show generosity)
 564             `T.append`  ")"
 565         if strictlySuperior (~~=) vs'' vs
 566           then runSqlQuery $ warn $ "Slightly" `T.append` warning
 567           else error $ "Seriously" ++ T.unpack warning
 568     runSqlQuery $ writeValueSimplex acInfo acLines vs'
 569     modify $ \rs -> rs {valueSimplex = vs'}
 570   else do
 571     forM_ (zip offerList [currentSequence acInfo ..]) $ \(off, seq) ->
 572       signAndSend $ OfferCancel seq $ offerSequence off
 573     waitForType :: RootstockIO Ledger
 574     clearAndUpdate
 575
 576 getUpdatedValueSimplexWithAccountInfo ::
 577   AccountInfo -> RootstockIO ValueSimplexND
 578 getUpdatedValueSimplexWithAccountInfo acInfo =
 579   updatedValueSimplex <$> gets valueSimplex <*> pure acInfo <*> getAccountLines
 580
 581 getUpdatedValueSimplex :: RootstockIO ValueSimplexND
 582 getUpdatedValueSimplex =
 583   getUpdatedValueSimplexWithAccountInfo =<< getAccountInfo
 584
 585 strictlySuperiorToCurrent :: ValueSimplexND -> RootstockIO Bool
 586 strictlySuperiorToCurrent vs' = strictlySuperior (~~=) vs' <$> gets valueSimplex
 587
 588 waitForImprovement :: RootstockIO ()
 589 waitForImprovement = do
 590   waitForType :: RootstockIO Ledger
 591   waitForType :: RootstockIO RecordedTransaction
 592   improvement <- strictlySuperiorToCurrent =<< getUpdatedValueSimplex
 593   if improvement
 594     then return ()
 595     else waitForImprovement
 596
 597 submitAndWait :: [Transaction] -> RootstockIO ()
 598 submitAndWait txs = do
 599   forM_ txs signAndSend
 600   waitForType :: RootstockIO Ledger
 601   acInfo <- getAccountInfo
 602   improvement <-
 603     strictlySuperiorToCurrent =<< getUpdatedValueSimplexWithAccountInfo acInfo
 604   if improvement
 605     then return ()
 606     else case dropWhile ((currentSequence acInfo >) . getSequence) txs of
 607       []    -> waitForImprovement
 608       txs'  -> submitAndWait txs'
 609
 610 getTransitRates :: RootstockIO (NodeEntity -> Double)
 611 getTransitRates = do
 612   peers <- catMaybes . Set.toList . Set.map peerOfNodeEntity . nodes
 613     <$> gets valueSimplex
 614   trm <- buildMap peers $ \peer -> transferRate <$> getPeerAccountInfo peer
 615   return $ \x -> fromMaybe 1 $ peerOfNodeEntity x >>= flip Map.lookup trm
 616
 617 marketMakerLoop :: RootstockIO ()
 618 marketMakerLoop = do
 619   clearAndUpdate
 620   makeTransactions <$> gets valueSimplex <*> getTransitRates <*> getAccountInfo
 621     >>= submitAndWait
 622   marketMakerLoop
 623
 624
 625 --------------------------------------------------------------------------------
 626 throwIf :: (Error e, Monad m) => Bool -> e -> ErrorT e m ()
 627 throwIf test err = if test then throwError err else return ()
 628
 629 setupDatabase :: IOULine -> ExceptionalRootstock
 630 setupDatabase fundLine = do
 631   existingNodes <- lift $ runSqlQuery getNodeEntities
 632   throwIf (not $ null existingNodes) "Database already has nodes"
 633   acInfo <- lift getAccountInfo
 634   let dropsBal = getQuantity $ lookupXRP acInfo
 635   throwIf (dropsBal <= 0) "Not enough XRP to meet desired reserve"
 636   acLines <- lift getAccountLines
 637   lineBal <- case lookupLine acLines fundLine of
 638     Nothing -> throwError "Requested IOU line not found"
 639     Just amount -> return $ getQuantity amount
 640   throwIf (lineBal <= 0) "Non-positive balance in requested IOU line"
 641   let xrpNode   = Node {nodeFund = XRP}
 642       lineNode  = Node {nodeFund = IOUFund fundLine}
 643   lift $ runSqlQuery $ do
 644     xrpId   <- insert xrpNode
 645     lineId  <- insert lineNode
 646     let xrpNodeEntity   = Entity {entityKey = xrpId,  entityVal = xrpNode}
 647         lineNodeEntity  = Entity {entityKey = lineId, entityVal = lineNode}
 648     writeValueSimplex acInfo acLines $
 649       flip fromFunction (Set.fromList [xrpNodeEntity, lineNodeEntity]) $ \x _ ->
 650         if x == xrpNodeEntity
 651         then dropsBal
 652         else lineBal
 653
 654
 655 --------------------------------------------------------------------------------
 656 {- getLinkEntities :: RootstockIO [Entity Link]
 657 getLinkEntities = runSqlQuery $ select $ from return
 658
 659 getLinks :: RootstockIO [Link]
 660 getLinks = liftM (map entityVal) getLinkEntities
 661
 662 waitForAction :: RootstockIO Offers
 663 waitForAction = do
 664   sendTextData $ encode $ object
 665     [ "command" .= ("account_offers" :: Text)
 666     , "account" .= account
 667     ]
 668   offers <- waitForType
 669   links <- getLinks
 670   if all (bothOffersPresent offers) links
 671   then do
 672     RecordedTransaction <- waitForType
 673     waitForAction
 674   else return offers
 675
 676 currentLinkStatus :: LinkId -> RootstockIO (Maybe LinkStatus)
 677 currentLinkStatus linkId = do
 678   statusList <- runSqlQuery $ select $ from $ \status -> do
 679     where_ $ status ^. LinkStatusLinkId ==. val linkId
 680     orderBy [desc $ status ^. LinkStatusTimestamp]
 681     limit 1
 682     return status
 683   return $ liftM entityVal $ listToMaybe statusList
 684
 685 submitLinkOffers :: AccountInfo -> AccountLines ->
 686   Offers -> Entity Link -> Integer -> RootstockIO Integer
 687 submitLinkOffers acInfo acLines offers (Entity linkId link) curSeq = do
 688   if bothOffersPresent offers link
 689   then return curSeq
 690   else do
 691     maybeHSpread <- liftM (liftM linkStatusHalfSpread) $
 692       currentLinkStatus linkId
 693     let
 694       left = linkLeft link
 695       right = linkRight link
 696       feeForCalcs XRP = fromInteger $ 3 * fee
 697       feeForCalcs _ = 0
 698       leftFeeForCalcs = feeForCalcs left
 699       rightFeeForCalcs = feeForCalcs right
 700     case
 701       ( lookupFund acInfo acLines left
 702       , lookupFund acInfo acLines right
 703       , maybeHSpread
 704       ) of
 705       (Just leftTotal, Just rightTotal, Just hSpread) -> do
 706         now <- lift getCurrentTime
 707         runSqlQuery $ do
 708           insert $ HalfLink left right (getQuantity leftTotal) now
 709           insert $ HalfLink right left (getQuantity rightTotal) now
 710         nextSeq <- submitSellOffer
 711           leftTotal rightTotal
 712           leftFeeForCalcs rightFeeForCalcs hSpread
 713           offers curSeq
 714         submitSellOffer
 715           rightTotal leftTotal
 716           rightFeeForCalcs leftFeeForCalcs hSpread
 717           offers nextSeq
 718       _ -> do
 719         lift $ putStrLn
 720           "The link status or one of the lines of credit wasn't found"
 721         return curSeq
 722
 723 marketMakerLoop :: RootstockIO ()
 724 marketMakerLoop = do
 725   offers <- waitForAction
 726   sendTextData $ encode $ object
 727     [ "command" .= ("account_info" :: Text)
 728     , "account" .= account
 729     ]
 730   acInfo <- waitForType
 731   sendTextData $ encode $ object
 732     [ "command" .= ("account_lines" :: Text)
 733     , "account" .= account
 734     ]
 735   acLines <- waitForType
 736   linkEntities <- getLinkEntities
 737   currentSequence acInfo >>=*
 738     map (submitLinkOffers acInfo acLines offers) linkEntities
 739   marketMakerLoop
 740
 741 marketMaker :: RootstockIO ()
 742 marketMaker = do
 743   subscribeAccount
 744   marketMakerLoop
 745
 746 insertOldLink :: OldLink -> RootstockIO ()
 747 insertOldLink link = do
 748   now <- lift getCurrentTime
 749   runSqlQuery $ do
 750     linkId <- insert $ Link (leftFund link) (rightFund link)
 751     insert $ LinkStatus linkId (halfSpread link) now
 752   return () -}
 753
 754
 755 --------------------------------------------------------------------------------
 756 runRootstock :: RootstockIO a -> Rootstock -> IO a
 757 runRootstock = evalStateT
 758
 759 marketMaker :: RootstockIO ()
 760 marketMaker = do
 761   runWebsocket $ subscribe
 762     [ "streams"   .= ["ledger" :: Text]
 763     , "accounts"  .= [account]
 764     ]
 765   result <- runErrorT $ do
 766     mapErrorT runSqlQuery $ do
 767       curAc <- lift getCurrentAction
 768       throwIf
 769         (not $ actionFinished curAc)
 770         "Another process hasn't yet cleanly finished with the database"
 771       lift $ startAction Running
 772     rs <- lift get
 773     liftIO $ catch (runRootstock marketMakerLoop rs) $ \e -> do
 774       flip runSqlPersistM (sql rs) $ do
 775         curAc <- getCurrentAction
 776         if (actionLogAction (entityVal curAc) == Running
 777             && not (actionFinished curAc))
 778           then
 779             endAction
 780               (entityKey curAc)
 781               $ fromException e `elem` map Just [ThreadKilled, UserInterrupt]
 782           else return ()
 783       putStrLn $ "Exiting on: " ++ show e
 784   doLeft (lift . putStrLn) result
 785
 786 rippleInteract :: WS.ClientApp ()
 787 rippleInteract conn = do
 788   -- Fork a thread that writes WS data to stdout
 789   _ <- forkIO $ forever $ do
 790       msg <- WS.receiveData conn
 791       liftIO $ T.putStrLn msg
 792
 793   runRipple subscribeAccount
 794
 795   -- Read from stdin and write to WS
 796   let loop = do
 797           line <- T.getLine
 798           unless (T.null line) $ WS.sendTextData conn line >> loop
 799
 800   loop
 801   WS.sendClose conn ("Bye!" :: Text)
 802
 803 readSecret :: IO String
 804 readSecret = readProcess "gpg" ["-o", "-", secretFile] ""
 805
 806 readSqlPass :: IO BS.ByteString
 807 readSqlPass = readProcess "gpg" ["-o", "-", sqlPassFile] "" >>= return . BS.pack
 808
 809 runRipple :: WS.ClientApp a -> IO a
 810 runRipple app = WS.runClient "s1.ripple.com" 443 "/" app
 811
 812 runRippleWithSecret :: RootstockIO a -> IO a
 813 runRippleWithSecret app = do
 814   sec <- readSecret
 815   sqlPass <- readSqlPass
 816   withPostgresqlConn (BS.concat [connString, sqlPass]) $ \sqlConn -> do
 817     vs <- flip runSqlPersistM sqlConn $ do
 818       runMigration migrateAll
 819       readValueSimplex
 820     runRipple $ \wsConn ->
 821       runRootstock app $ Rootstock
 822         { websocket     = wsConn
 823         , secret        = sec
 824         , sql           = sqlConn
 825         , valueSimplex  = vs
 826         }
 827
 828 {- insertOldLinks :: IO ()
 829 insertOldLinks = runRippleWithSecret $ sequence_ $ map insertOldLink oldLinks -}
 830
 831 main :: IO ()
 832 main = do
 833   args <- getArgs
 834   case args of
 835     ["setup", currency, peer] -> runRippleWithSecret $ intervene InitialSetup $
 836       setupDatabase $ IOULine
 837         { peerAccount   = T.pack peer
 838         , lineCurrency  = T.pack currency
 839         }
 840     _ -> putStrLn "Command not understood"
 841