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 queryOwnAccount :: FromJSON a => Text -> RootstockIO a
 548 queryOwnAccount command = do
 549   sendTextData $ encode $ object
 550     [ "command" .= command
 551     , "account" .= account
 552     , "ledger_index" .= ("validated" :: Text)
 553     ]
 554   waitForType
 555
 556 getAccountInfo :: RootstockIO AccountInfo
 557 getAccountInfo = queryOwnAccount "account_info"
 558
 559 getAccountLines :: RootstockIO AccountLines
 560 getAccountLines = queryOwnAccount "account_lines"
 561
 562 getAccountOffers :: RootstockIO Offers
 563 getAccountOffers = queryOwnAccount "account_offers"
 564
 565 getCurrentAccountInfo :: Text -> RootstockIO AccountInfo
 566 getCurrentAccountInfo peer = do
 567   sendTextData $ encode $ object
 568     [ "command" .= ("account_info" :: Text)
 569     , "account" .= peer
 570     , "ledger_index" .= ("current" :: Text)
 571     ]
 572   waitForType
 573
 574 valueSimplexEmpty :: RootstockIO Bool
 575 valueSimplexEmpty = isEmpty <$> gets valueSimplex
 576
 577 putValueSimplex :: ValueSimplexND -> RootstockIO ()
 578 putValueSimplex vs = modify $ \rs -> rs {valueSimplex = vs}
 579
 580 putSequence :: Integer -> RootstockIO ()
 581 putSequence nextSeq = modify $ \rs -> rs {nextSequence = nextSeq}
 582
 583 getAndPutSequence :: RootstockIO ()
 584 getAndPutSequence =
 585   currentSequence <$> getCurrentAccountInfo account >>= putSequence
 586
 587 ownActionGoingQuery :: RootstockIO (SqlPersistM Bool)
 588 ownActionGoingQuery = do
 589   actId <- gets rsAction
 590   return $ maybe False (not . actionFinished) <$> P.get actId
 591
 592 ifRunning :: SqlPersistM () -> ExceptionalRootstock ()
 593 ifRunning query = do
 594   goingQ <- lift ownActionGoingQuery
 595   mapErrorT runSqlQuery $ do
 596     going <- lift $ goingQ
 597     throwIf NotRunning $ not going
 598     lift query
 599
 600 checkRunning :: ExceptionalRootstock ()
 601 checkRunning = ifRunning $ return ()
 602
 603 submitUntilSequenceCatchup' :: [Transaction] -> ExceptionalRootstock ()
 604 submitUntilSequenceCatchup' txs = unless (null txs) $ do
 605   checkRunning
 606   forM_ txs $ lift . signAndSend
 607   lift (waitForType :: RootstockIO Ledger)
 608   curSeq <- currentSequence <$> lift getAccountInfo
 609   submitUntilSequenceCatchup' $ dropWhile ((curSeq >) . getSequence) txs
 610
 611 submitUntilSequenceCatchup :: [Transaction] -> ExceptionalRootstock ()
 612 submitUntilSequenceCatchup txs = do
 613   lift $ putSequence =<< (toInteger (length txs) +) <$> gets nextSequence
 614   submitUntilSequenceCatchup' txs
 615
 616 clearAndUpdate :: ExceptionalRootstock ()
 617 {- Must have subscribed to ledger updates for this to work -}
 618 clearAndUpdate = do
 619   Offers offerList <- lift getAccountOffers
 620   if null offerList
 621   then do
 622     acInfo <- lift getAccountInfo
 623     acLines <- lift getAccountLines
 624     vs <- lift $ gets valueSimplex
 625     let vs' = updatedValueSimplex vs acInfo acLines
 626     when (status (~~=) vs' /= OK) $ error "Invalid updated ValueSimplex!"
 627     ifRunning $ do
 628       unless (strictlySuperior (~~=) vs' vs) $ do
 629         let
 630           vs'' = updatedValueSimplexWithGenerosity generosity vs acInfo acLines
 631           warning
 632             =           " non-superior ValueSimplex (generosity: "
 633             `T.append`  T.pack (show generosity)
 634             `T.append`  ")"
 635         if strictlySuperior (~~=) vs'' vs
 636           then warn $ "Slightly" `T.append` warning
 637           else error $ "Seriously" ++ T.unpack warning
 638       writeValueSimplex acInfo acLines vs'
 639     lift $ putValueSimplex vs'
 640   else do
 641     curSeq <- lift $ gets nextSequence
 642     submitUntilSequenceCatchup $ zipWith
 643       (\off sequ -> OfferCancel sequ $ offerSequence off)
 644       offerList
 645       [curSeq ..]
 646     clearAndUpdate
 647
 648 getUpdatedValueSimplexWithAccountInfo ::
 649   AccountInfo -> RootstockIO ValueSimplexND
 650 getUpdatedValueSimplexWithAccountInfo acInfo =
 651   updatedValueSimplex <$> gets valueSimplex <*> pure acInfo <*> getAccountLines
 652
 653 getUpdatedValueSimplex :: RootstockIO ValueSimplexND
 654 getUpdatedValueSimplex =
 655   getUpdatedValueSimplexWithAccountInfo =<< getAccountInfo
 656
 657 strictlySuperiorToCurrent :: ValueSimplexND -> RootstockIO Bool
 658 strictlySuperiorToCurrent vs' = strictlySuperior (~~=) vs' <$> gets valueSimplex
 659
 660 waitForImprovement :: ExceptionalRootstock ()
 661 waitForImprovement = do
 662   checkRunning
 663   unlessM (lift $ strictlySuperiorToCurrent =<< getUpdatedValueSimplex) $ do
 664     lift (waitForType :: RootstockIO Ledger)
 665     lift (waitForType :: RootstockIO RecordedTransaction)
 666     waitForImprovement
 667
 668 submitAndWait :: [Transaction] -> ExceptionalRootstock ()
 669 submitAndWait txs = do
 670   submitUntilSequenceCatchup txs
 671   waitForImprovement
 672
 673 getTransitRates :: RootstockIO (NodeEntity -> Double)
 674 getTransitRates = do
 675   peers <- catMaybes . Set.toList . Set.map peerOfNodeEntity . nodes
 676     <$> gets valueSimplex
 677   trm <- buildMap peers $ \peer -> transferRate <$> getCurrentAccountInfo peer
 678   return $ \x -> fromMaybe 1 $ peerOfNodeEntity x >>= flip Map.lookup trm
 679
 680 startRunning :: RootstockIO ()
 681 startRunning = do
 682   mavs <- runSqlQuery $ do
 683     mcurAc <- getCurrentAction
 684     case mcurAc of
 685       Nothing     -> error $ show DatabaseNotSetUp
 686       Just curAc  ->
 687         if actionEntityFinished curAc
 688           then do
 689             actId <- startAction Running
 690             vs <- readValueSimplex
 691             return $ Just (actId, vs)
 692           else return Nothing
 693   case mavs of
 694     Nothing -> do
 695       waitForType :: RootstockIO Ledger
 696       startRunning
 697     Just (actId, vs) -> do
 698       putAction actId
 699       putValueSimplex vs
 700       getAndPutSequence
 701
 702 ensureRunning :: RootstockIO ()
 703 ensureRunning =
 704   unlessM (join $ runSqlQuery <$> ownActionGoingQuery)
 705     startRunning
 706
 707 marketMakerLoop :: RootstockIO ()
 708 marketMakerLoop = do
 709   runErrorT $ do
 710     clearAndUpdate
 711     lift
 712         ( makeTransactions
 713         <$> gets valueSimplex
 714         <*> getTransitRates
 715         <*> gets nextSequence
 716         )
 717       >>= submitAndWait
 718   ensureRunning
 719   marketMakerLoop
 720
 721
 722 --------------------------------------------------------------------------------
 723 getLineBal :: AccountLines -> IOULine -> ExceptionalRootstock Double
 724 getLineBal acLines fundLine = do
 725   lineBal <- case lookupLine acLines fundLine of
 726     Nothing -> throwError LineNotFound
 727     Just amount -> return $ getQuantity amount
 728   throwIf NonPositiveLine $ lineBal <= 0
 729   return lineBal
 730
 731 setupDatabase :: IOULine -> ExceptionalRootstock ()
 732 setupDatabase fundLine = do
 733   isEmpt <- lift $ valueSimplexEmpty
 734   throwIf DatabaseExists $ not isEmpt
 735   acInfo <- lift getAccountInfo
 736   let dropsBal = getQuantity $ lookupXRP acInfo
 737   throwIf InsufficientForReserve $ dropsBal <= 0
 738   acLines <- lift getAccountLines
 739   lineBal <- getLineBal acLines fundLine
 740   lift $ runSqlQuery $ do
 741     xrpNodeEntity   <- insertReturnEntity $ Node {nodeFund = XRP}
 742     lineNodeEntity  <- insertReturnEntity $ Node {nodeFund = IOUFund fundLine}
 743     writeValueSimplex acInfo acLines $
 744       flip fromFunction (Set.fromList [xrpNodeEntity, lineNodeEntity]) $ \x _ ->
 745         if x == xrpNodeEntity
 746         then dropsBal
 747         else lineBal
 748
 749 addCurrency :: IOULine -> Double -> ExceptionalRootstock ()
 750 addCurrency fundLine priceInXRP = do
 751   mxrpNodeEntity <- lift $ runSqlQuery $ getBy $ NodeUnique XRP
 752   xrpNodeEntity <- maybe (throwError DatabaseNotSetUp) return mxrpNodeEntity
 753   throwIf NonPositivePrice $ priceInXRP <= 0
 754   let lineFund = IOUFund fundLine
 755   alreadyPresent <-
 756     isJust <$> (lift $ runSqlQuery $ getBy $ NodeUnique lineFund)
 757   throwIf CurrencyAlreadyPresent alreadyPresent
 758   lift $ getAndPutSequence
 759   clearAndUpdate
 760   acLines <- lift getAccountLines
 761   lineBal <- getLineBal acLines fundLine
 762   vs <- lift $ gets valueSimplex
 763   throwIf NewOutweighsOld $ priceInXRP * lineBal >= totalValue vs xrpNodeEntity
 764   acInfo <- lift getAccountInfo
 765   lift $ runSqlQuery $ do
 766     lineNodeEntity <- insertReturnEntity $ Node {nodeFund = lineFund}
 767     writeValueSimplex acInfo acLines $
 768       addNode vs lineNodeEntity lineBal xrpNodeEntity priceInXRP
 769
 770
 771 --------------------------------------------------------------------------------
 772 {- getLinkEntities :: RootstockIO [Entity Link]
 773 getLinkEntities = runSqlQuery $ select $ from return
 774
 775 getLinks :: RootstockIO [Link]
 776 getLinks = liftM (map entityVal) getLinkEntities
 777
 778 waitForAction :: RootstockIO Offers
 779 waitForAction = do
 780   sendTextData $ encode $ object
 781     [ "command" .= ("account_offers" :: Text)
 782     , "account" .= account
 783     ]
 784   offers <- waitForType
 785   links <- getLinks
 786   if all (bothOffersPresent offers) links
 787   then do
 788     RecordedTransaction <- waitForType
 789     waitForAction
 790   else return offers
 791
 792 currentLinkStatus :: LinkId -> RootstockIO (Maybe LinkStatus)
 793 currentLinkStatus linkId = do
 794   statusList <- runSqlQuery $ select $ from $ \status -> do
 795     where_ $ status ^. LinkStatusLinkId ==. val linkId
 796     orderBy [desc $ status ^. LinkStatusTimestamp]
 797     limit 1
 798     return status
 799   return $ liftM entityVal $ listToMaybe statusList
 800
 801 submitLinkOffers :: AccountInfo -> AccountLines ->
 802   Offers -> Entity Link -> Integer -> RootstockIO Integer
 803 submitLinkOffers acInfo acLines offers (Entity linkId link) curSeq = do
 804   if bothOffersPresent offers link
 805   then return curSeq
 806   else do
 807     maybeHSpread <- liftM (liftM linkStatusHalfSpread) $
 808       currentLinkStatus linkId
 809     let
 810       left = linkLeft link
 811       right = linkRight link
 812       feeForCalcs XRP = fromInteger $ 3 * fee
 813       feeForCalcs _ = 0
 814       leftFeeForCalcs = feeForCalcs left
 815       rightFeeForCalcs = feeForCalcs right
 816     case
 817       ( lookupFund acInfo acLines left
 818       , lookupFund acInfo acLines right
 819       , maybeHSpread
 820       ) of
 821       (Just leftTotal, Just rightTotal, Just hSpread) -> do
 822         now <- lift getCurrentTime
 823         runSqlQuery $ do
 824           insert $ HalfLink left right (getQuantity leftTotal) now
 825           insert $ HalfLink right left (getQuantity rightTotal) now
 826         nextSeq <- submitSellOffer
 827           leftTotal rightTotal
 828           leftFeeForCalcs rightFeeForCalcs hSpread
 829           offers curSeq
 830         submitSellOffer
 831           rightTotal leftTotal
 832           rightFeeForCalcs leftFeeForCalcs hSpread
 833           offers nextSeq
 834       _ -> do
 835         lift $ putStrLn
 836           "The link status or one of the lines of credit wasn't found"
 837         return curSeq
 838
 839 marketMakerLoop :: RootstockIO ()
 840 marketMakerLoop = do
 841   offers <- waitForAction
 842   sendTextData $ encode $ object
 843     [ "command" .= ("account_info" :: Text)
 844     , "account" .= account
 845     ]
 846   acInfo <- waitForType
 847   sendTextData $ encode $ object
 848     [ "command" .= ("account_lines" :: Text)
 849     , "account" .= account
 850     ]
 851   acLines <- waitForType
 852   linkEntities <- getLinkEntities
 853   currentSequence acInfo >>=*
 854     map (submitLinkOffers acInfo acLines offers) linkEntities
 855   marketMakerLoop
 856
 857 marketMaker :: RootstockIO ()
 858 marketMaker = do
 859   subscribeAccount
 860   marketMakerLoop
 861
 862 insertOldLink :: OldLink -> RootstockIO ()
 863 insertOldLink link = do
 864   now <- lift getCurrentTime
 865   runSqlQuery $ do
 866     linkId <- insert $ Link (leftFund link) (rightFund link)
 867     insert $ LinkStatus linkId (halfSpread link) now
 868   return () -}
 869
 870
 871 --------------------------------------------------------------------------------
 872 runRootstock :: RootstockIO a -> Rootstock -> IO a
 873 runRootstock = evalStateT
 874
 875 marketMaker :: RootstockIO ()
 876 marketMaker = do
 877   isEmpt <- valueSimplexEmpty
 878   when isEmpt $ error $ show DatabaseNotSetUp
 879   runWebsocket $ subscribe
 880     [ "streams"   .= ["ledger" :: Text]
 881     , "accounts"  .= [account]
 882     ]
 883   startRunning
 884   rs <- get
 885   liftIO $ catch (runRootstock marketMakerLoop rs) $ \e -> do
 886       flip runSqlPersistM (sql rs) $ do
 887         curAc <- fromJust <$> getCurrentAction
 888         if actionRunning curAc
 889           then
 890             endAction
 891               (entityKey curAc)
 892               $ fromException e `elem` map Just [ThreadKilled, UserInterrupt]
 893           else return ()
 894       putStrLn $ "Exiting on: " ++ show e
 895
 896 rippleInteract :: WS.ClientApp ()
 897 rippleInteract conn = do
 898   -- Fork a thread that writes WS data to stdout
 899   _ <- forkIO $ forever $ do
 900       msg <- WS.receiveData conn
 901       liftIO $ T.putStrLn msg
 902
 903   runRipple subscribeAccount
 904
 905   -- Read from stdin and write to WS
 906   let loop = do
 907           line <- T.getLine
 908           unless (T.null line) $ WS.sendTextData conn line >> loop
 909
 910   loop
 911   WS.sendClose conn ("Bye!" :: Text)
 912
 913 readSecret :: IO String
 914 readSecret = readProcess "gpg" ["-o", "-", secretFile] ""
 915
 916 readSqlPass :: IO BS.ByteString
 917 readSqlPass = readProcess "gpg" ["-o", "-", sqlPassFile] "" >>= return . BS.pack
 918
 919 runRipple :: WS.ClientApp a -> IO a
 920 runRipple app = WS.runClient "s1.ripple.com" 443 "/" app
 921
 922 runRippleWithSecret :: RootstockIO a -> IO a
 923 runRippleWithSecret app = do
 924   sec <- readSecret
 925   sqlPass <- readSqlPass
 926   withPostgresqlConn (BS.concat [connString, sqlPass]) $ \sqlConn -> do
 927     vs <- flip runSqlPersistM sqlConn $ do
 928       runMigration migrateAll
 929       readValueSimplex
 930     runRipple $ \wsConn ->
 931       runRootstock app $ Rootstock
 932         { websocket     = wsConn
 933         , secret        = sec
 934         , sql           = sqlConn
 935         , valueSimplex  = vs
 936         , nextSequence  = 0
 937         , rsAction      = noAction
 938         }
 939
 940 {- insertOldLinks :: IO ()
 941 insertOldLinks = runRippleWithSecret $ sequence_ $ map insertOldLink oldLinks -}
 942
 943 main :: IO ()
 944 main = do
 945   args <- getArgs
 946   case args of
 947     ["setup", currency, peer] -> runRippleWithSecret $ intervene InitialSetup $
 948       setupDatabase $ IOULine
 949         { peerAccount   = T.pack peer
 950         , lineCurrency  = T.pack currency
 951         }
 952     ["run"] -> runRippleWithSecret marketMaker
 953     ["addCurrency", currency, peer, priceInXRP] ->
 954       runRippleWithSecret $ intervene AddNode $ addCurrency
 955         ( IOULine
 956           { peerAccount   = T.pack peer
 957           , lineCurrency  = T.pack currency
 958           }
 959         )
 960         $ read priceInXRP
 961     _ -> putStrLn "Command not understood"
 962