rootstock.hs

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