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