1 --------------------------------------------------------------------------------
2 {-# LANGUAGE FlexibleContexts
14 --------------------------------------------------------------------------------
15 import Prelude
hiding (catch)
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
(aifM
, awhenM
, unlessM
)
22 import Control
.Monad
.Trans
(lift
, liftIO
)
23 import Control
.Monad
.Trans
.Error
(ErrorT
(..), mapErrorT
, throwError
)
24 import Control
.Monad
.Trans
.State
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)
32 import qualified Data
.Map
as Map
33 import Data
.Maybe (catMaybes, fromJust, fromMaybe, isJust, listToMaybe)
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
45 import qualified Network
.WebSockets
as WS
46 import Numeric
(showFFloat)
47 import Ripple
.WebSockets
(RippleResult
(RippleResult
))
48 import RootstockException
(RootstockException
(..))
49 import System
.Environment
(getArgs)
50 import System
.Process
(readProcess
)
51 import Util
.ApproxEq
((~~
=))
52 import Util
.Either (doLeft
, isRight
)
53 import Util
.Error
(throwIf
)
54 import Util
.Foldable
(sumWith
)
55 import Util
.Function
((.!))
56 import Util
.Monad
((>>=*), buildMap
)
57 import Util
.Persist
(insertReturnEntity
)
58 import Util
.Set
(distinctPairs
, distinctPairsOneWay
)
62 --------------------------------------------------------------------------------
63 data AccountInfo
= AccountInfo
64 { dropsBalance
:: Integer
65 , currentSequence
:: Integer
66 , transferRate
:: Double
69 data IOUAmount
= IOUAmount
71 , iouQuantity
:: Double
75 newtype AccountLines
= AccountLines
[IOUAmount
]
83 = OfferCreate Amount Amount
Integer (Maybe Integer)
84 | OfferCancel
Integer Integer
90 , offerSequence
:: Integer
93 newtype Offers
= Offers
[Offer
]
96 { ledgerIndex
:: Integer
100 data RecordedTransaction
= RecordedTransaction
102 share
[mkPersist sqlSettings
, mkMigrate
"migrateAll"] [persistLowerCase|
112 FundStatusUnique fundId time
118 HalfLinkUnique root branch time
130 type NodeEntity
= Entity Node
131 type ValueSimplexND
= ValueSimplex NodeEntity
Double
133 data Rootstock
= Rootstock
135 , websocket
:: WS
.Connection
137 , valueSimplex
:: ValueSimplexND
138 , nextSequence
:: Integer
139 , rsAction
:: ActionLogId
142 type RootstockIO
= StateT Rootstock
IO
143 type ExceptionalRootstock
= ErrorT RootstockException RootstockIO
146 --------------------------------------------------------------------------------
147 instance ToJSON Amount
where
148 toJSON
(Drops numDrops
) = toJSON
$ show numDrops
149 toJSON
(IOU iou
) = object
150 [ "currency" .= lineCurrency
(iouLine iou
)
151 , "issuer" .= peerAccount
(iouLine iou
)
152 , "value" .= showFFloat Nothing
(iouQuantity iou
) ""
155 instance ToJSON Transaction
where
156 toJSON
(OfferCreate toSell toBuy curSeq maybeOldOfferSequence
) = object
$
157 [ "TransactionType" .= ("OfferCreate" :: Text
)
158 , "Account" .= account
160 , "Sequence" .= curSeq
162 , "TakerPays" .= toBuy
163 , "TakerGets" .= toSell
166 (\oldOfferSequence
-> ["OfferSequence" .= show oldOfferSequence
])
167 maybeOldOfferSequence
168 toJSON
(OfferCancel curSeq oldOfferSequence
) = object
$
169 [ "TransactionType" .= ("OfferCancel" :: Text
)
170 , "Account" .= account
172 , "Sequence" .= curSeq
173 , "OfferSequence" .= oldOfferSequence
176 instance FromJSON AccountInfo
where
177 parseJSON
(Object obj
) = do
178 accountData
<- obj
.: "account_data"
180 <$> (accountData
.: "Balance" >>= return . read)
181 <*> accountData
.: "Sequence"
182 <*> (maybe 1 (/1000000000) <$> accountData
.:?
"TransferRate")
183 parseJSON
value = fail $
184 "Not an account info response:\n" ++ (BSL8
.unpack
$ encode
value)
186 instance FromJSON IOUAmount
where
187 parseJSON
(Object obj
) = IOUAmount
190 <*> obj
.: "currency")
191 <*> (obj
.: "balance" >>= return . read)
192 parseJSON
value = fail $
193 "Not an account line:\n" ++ (BSL8
.unpack
$ encode
value)
195 instance FromJSON AccountLines
where
196 parseJSON
(Object obj
) = AccountLines
<$> obj
.: "lines"
197 parseJSON
value = fail $
198 "Not a list of account lines:\n" ++ (BSL8
.unpack
$ encode
value)
200 instance FromJSON Amount
where
201 parseJSON
(Object obj
) = IOU
<$> (IOUAmount
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)
210 instance FromJSON Offer
where
211 parseJSON
(Object obj
) = Offer
212 <$> obj
.: "taker_gets"
213 <*> obj
.: "taker_pays"
215 parseJSON
value = fail $
216 "Not an offer:\n" ++ (BSL8
.unpack
$ encode
value)
218 instance FromJSON Offers
where
219 parseJSON
(Object obj
) = Offers
<$> obj
.: "offers"
220 parseJSON
value = fail $
221 "Not a list of offers:\n" ++ (BSL8
.unpack
$ encode
value)
223 instance FromJSON Ledger
where
224 parseJSON
(Object obj
) = Ledger
225 <$> obj
.: "ledger_index"
227 parseJSON
value = fail $
228 "Not a ledger:\n" ++ (BSL8
.unpack
$ encode
value)
230 instance FromJSON RecordedTransaction
where
231 parseJSON
(Object obj
) = do
232 objType
<- obj
.: "type"
233 if objType
== ("transaction" :: Text
)
234 then return RecordedTransaction
236 "Not a recorded transaction:\n" ++ (BSL8
.unpack
$ encode
$ Object obj
)
237 parseJSON
value = fail $
238 "Not a recorded transaction:\n" ++ (BSL8
.unpack
$ encode
value)
241 --------------------------------------------------------------------------------
242 secretFile
, rsignPath
, sqlPassFile
:: FilePath
243 secretFile
= "/home/tim/Documents/passwords/ripple-secret.gpg"
245 "/home/tim/build/ripple/ripple-lib/node_modules/ripple-lib/bin/rsign.js"
246 sqlPassFile
= "/home/tim/Documents/passwords/sql-password.gpg"
248 connString
:: BS
.ByteString
249 connString
= "host=localhost port=5432 user=tim dbname=rootstock-test password="
252 account
= "rpY4wdftAiEH5y5uzxC2XAvy3G27UyeQKS"
254 fee
, tfSell
, reserve
:: Integer
259 generosity
, halfSpread
:: Double
263 noAction
:: ActionLogId
264 noAction
= Key PersistNull
266 lookupXRP
:: AccountInfo
-> Amount
267 lookupXRP acInfo
= Drops
$ dropsBalance acInfo
- reserve
269 lookupLine
:: AccountLines
-> IOULine
-> Maybe Amount
270 lookupLine
(AccountLines
lines) fundLine
= do
271 foundLine
<- find ((fundLine
==) . iouLine
) lines
272 return $ IOU foundLine
274 lookupFund
:: AccountInfo
-> AccountLines
-> Fund
-> Maybe Amount
275 lookupFund acInfo _ XRP
= Just
$ lookupXRP acInfo
276 lookupFund _ acLines
(IOUFund fundLine
) = lookupLine acLines fundLine
278 getQuantity
:: Amount
-> Double
279 getQuantity
(Drops n
) = fromInteger n
280 getQuantity
(IOU iou
) = iouQuantity iou
282 getSequence
:: Transaction
-> Integer
283 getSequence
(OfferCreate _ _ curSeq _
) = curSeq
284 getSequence
(OfferCancel curSeq _
) = curSeq
286 lookupGetQuantity
:: AccountInfo
-> AccountLines
-> NodeEntity
-> Double
287 lookupGetQuantity acInfo acLines
=
288 fromMaybe 0 . liftM getQuantity
.
289 lookupFund acInfo acLines
. nodeFund
. entityVal
291 fromNodeEntity
:: a
-> (IOULine
-> a
) -> NodeEntity
-> a
292 fromNodeEntity d f x
= case nodeFund
$ entityVal x
of
296 amount
:: Double -> NodeEntity
-> Amount
298 fromNodeEntity
(Drops
$ round q
) $ \l
->
299 IOU
$ IOUAmount
{iouLine
= l
, iouQuantity
= q
}
301 peerOfNodeEntity
:: NodeEntity
-> Maybe Text
302 peerOfNodeEntity
= fromNodeEntity Nothing
$ Just
. peerAccount
304 actionFinished
:: ActionLog
-> Bool
305 actionFinished
= isJust . actionLogEnd
307 actionEntityFinished
:: Entity ActionLog
-> Bool
308 actionEntityFinished
= actionFinished
. entityVal
310 actionRunning
:: Entity ActionLog
-> Bool
311 actionRunning acEnt
=
312 actionLogAction
(entityVal acEnt
) == Running
313 && not (actionEntityFinished acEnt
)
315 updatedValueSimplexWithGenerosity
::
316 Double -> ValueSimplexND
-> AccountInfo
-> AccountLines
-> ValueSimplexND
317 updatedValueSimplexWithGenerosity gen vs acInfo acLines
=
318 multiUpdate vs
$ \nodeEnt
->
319 let actual
= lookupGetQuantity acInfo acLines nodeEnt
in
320 case nodeFund
$ entityVal nodeEnt
of
324 updatedValueSimplex
::
325 ValueSimplexND
-> AccountInfo
-> AccountLines
-> ValueSimplexND
326 updatedValueSimplex
= updatedValueSimplexWithGenerosity
0
329 ValueSimplexND
-> (NodeEntity
-> Double) -> Integer -> [Transaction
]
330 makeTransactions vs trf nextSeq
=
332 (flip zipWith $ Set
.toList
$ distinctPairs
$ nodes vs
)
334 $ \(x0
, x1
) curSeq
->
335 let (q0
, q1
) = linkOptimumAtPrice vs x0 x1
$ halfSpread
* price vs x0 x1
in
336 OfferCreate
(amount
(-q0
/ trf x0
) x0
) (amount q1 x1
) curSeq Nothing
338 --------------------------------------------------------------------------------
339 signTransaction
:: Transaction
-> RootstockIO
String
340 signTransaction tx
= do
342 blobNewLine
<- lift
$ readProcess
343 rsignPath
[sec
, BSL8
.unpack
$ encode tx
] ""
344 return $ init blobNewLine
347 --------------------------------------------------------------------------------
348 getSqlConnection
:: RootstockIO Connection
349 getSqlConnection
= gets sql
351 runSqlQuery
:: SqlPersistM a
-> RootstockIO a
352 runSqlQuery query
= do
353 sqlConn
<- getSqlConnection
354 lift
$ runSqlPersistM query sqlConn
356 getNodeEntities
:: SqlPersistM
[NodeEntity
]
357 getNodeEntities
= select
$ from
return
359 readValueSimplexAt
:: UTCTime
-> SqlPersistM ValueSimplexND
360 readValueSimplexAt time
= do
361 nodeSet
<- Set
.fromList
<$> getNodeEntities
362 qMap
<- buildMap
(Set
.toList
$ distinctPairs nodeSet
) $ \(x
, y
) -> do
363 [Value q
] <- select
$ from
$ \hl
-> do
365 $ hl ^
. HalfLinkRoot
==. val
(entityKey x
)
366 &&. hl ^
. HalfLinkBranch
==. val
(entityKey y
)
367 &&. hl ^
. HalfLinkTime
<=. val time
368 orderBy
[desc
$ hl ^
. HalfLinkTime
]
370 return $ hl ^
. HalfLinkQuantity
372 return $ fromFunction
(curry $ flip (Map
.findWithDefault
0) qMap
) nodeSet
374 readValueSimplex
:: SqlPersistM ValueSimplexND
375 readValueSimplex
= liftIO getCurrentTime
>>= readValueSimplexAt
378 AccountInfo
-> AccountLines
-> ValueSimplexND
-> SqlPersistM
()
379 writeValueSimplex acInfo acLines vs
= do
380 time
<- liftIO getCurrentTime
381 insertMany
$ flip map (Set
.toList
$ nodes vs
) $ \nodeEnt
-> FundStatus
382 { fundStatusFundId
= entityKey nodeEnt
383 , fundStatusQuantity
= lookupGetQuantity acInfo acLines nodeEnt
384 , fundStatusTime
= time
386 forM_
(distinctPairs
$ nodes vs
) $ \(x
, y
) -> insert_
$ HalfLink
387 { halfLinkRoot
= entityKey x
388 , halfLinkBranch
= entityKey y
389 , halfLinkQuantity
= vsLookup vs x y
390 , halfLinkTime
= time
393 warn
:: Text
-> SqlPersistM
()
395 now
<- liftIO getCurrentTime
397 { warningWarning
= warning
401 getCurrentAction
:: SqlPersistM
(Maybe (Entity ActionLog
))
402 getCurrentAction
= liftM listToMaybe $ select
$ from
$ \ac
-> do
403 orderBy
[desc
$ ac ^
. ActionLogStart
]
407 startAction
:: Action
-> SqlPersistM ActionLogId
408 startAction action
= do
409 start
<- liftIO getCurrentTime
411 { actionLogAction
= action
412 , actionLogStart
= start
413 , actionLogEnd
= Nothing
414 , actionLogSuccess
= Nothing
417 endAction
:: ActionLogId
-> Bool -> SqlPersistM
()
418 endAction actionId success
= do
419 end
<- liftIO getCurrentTime
421 [ ActionLogEnd
=. Just end
422 , ActionLogSuccess
=. Just success
425 putAction
:: ActionLogId
-> RootstockIO
()
426 putAction actionId
= modify
$ \rs
-> rs
{rsAction
= actionId
}
428 intervene
:: Action
-> ExceptionalRootstock
() -> RootstockIO
()
429 intervene action intervention
= do
430 actionId
<- runSqlQuery
$ do
431 awhenM getCurrentAction
$ \curAc
->
432 unless (actionEntityFinished curAc
) $
433 if actionLogAction
(entityVal curAc
) == Running
434 then endAction
(entityKey curAc
) True
435 else error "Another intervention appears to be running"
438 result
<- runErrorT intervention
439 doLeft
(lift
. putStrLn . show) result
440 runSqlQuery
$ endAction actionId
$ isRight result
443 --------------------------------------------------------------------------------
444 runWebsocket
:: WS
.ClientApp a
-> RootstockIO a
445 runWebsocket app
= gets websocket
>>= lift
. app
447 receiveData
:: WS
.WebSocketsData a
=> RootstockIO a
448 receiveData
= runWebsocket WS
.receiveData
450 sendTextData
:: WS
.WebSocketsData a
=> a
-> RootstockIO
()
451 sendTextData x
= runWebsocket
$ flip WS
.sendTextData x
453 waitForType
:: FromJSON a
=> RootstockIO a
455 encoded
<- receiveData
456 case decode encoded
of
458 lift
$ putStrLn ("Skipping:\n" ++ (BSL8
.unpack encoded
))
461 lift
$ putStrLn ("Using:\n" ++ (BSL8
.unpack encoded
))
464 waitForResponseWithId
:: (Eq
id, FromJSON
id, FromJSON a
)
465 => id -> RootstockIO
(Maybe a
)
466 waitForResponseWithId idSought
= do
467 RippleResult i x
<- waitForType
468 if i
== Just idSought
469 then return $ either (const Nothing
) Just x
470 else waitForResponseWithId idSought
472 askUntilAnswered
:: FromJSON a
=> [Pair
] -> RootstockIO a
473 askUntilAnswered question
= do
474 qTime
<- liftIO getCurrentTime
475 sendTextData
$ encode
$ object
$ ("id" .= qTime
) : question
476 aifM
(waitForResponseWithId qTime
) return $ do
477 waitForType
:: RootstockIO Ledger
478 askUntilAnswered question
480 signAndSend
:: Transaction
-> RootstockIO
()
482 txBlob
<- signTransaction tx
483 sendTextData
$ encode
$ object
484 [ "command" .= ("submit" :: Text
)
485 , "tx_blob" .= txBlob
488 subscribe
:: [Pair
] -> WS
.ClientApp
()
490 flip WS
.sendTextData
$ encode
$ object
$
491 ["command" .= ("subscribe" :: Text
)] ++ options
493 subscribeLedger
:: WS
.ClientApp
()
494 subscribeLedger
= subscribe
["streams" .= ["ledger" :: Text
]]
496 subscribeAccount
:: WS
.ClientApp
()
497 subscribeAccount
= subscribe
["accounts" .= [account
]]
499 subscribeLedgerAndAccount
:: WS
.ClientApp
()
500 subscribeLedgerAndAccount
= subscribe
501 [ "streams" .= ["ledger" :: Text
]
502 , "accounts" .= [account
]
505 queryOwnAccount
:: FromJSON a
=> Text
-> RootstockIO a
506 queryOwnAccount command
= askUntilAnswered
507 [ "command" .= command
508 , "account" .= account
509 , "ledger_index" .= ("validated" :: Text
)
512 getAccountInfo
:: RootstockIO AccountInfo
513 getAccountInfo
= queryOwnAccount
"account_info"
515 getAccountLines
:: RootstockIO AccountLines
516 getAccountLines
= queryOwnAccount
"account_lines"
518 getAccountOffers
:: RootstockIO Offers
519 getAccountOffers
= queryOwnAccount
"account_offers"
521 getCurrentAccountInfo
:: Text
-> RootstockIO AccountInfo
522 getCurrentAccountInfo peer
= askUntilAnswered
523 [ "command" .= ("account_info" :: Text
)
525 , "ledger_index" .= ("current" :: Text
)
528 valueSimplexEmpty
:: RootstockIO
Bool
529 valueSimplexEmpty
= isEmpty
<$> gets valueSimplex
531 putValueSimplex
:: ValueSimplexND
-> RootstockIO
()
532 putValueSimplex vs
= modify
$ \rs
-> rs
{valueSimplex
= vs
}
534 putSequence
:: Integer -> RootstockIO
()
535 putSequence nextSeq
= modify
$ \rs
-> rs
{nextSequence
= nextSeq
}
537 getAndPutSequence
:: RootstockIO
()
539 currentSequence
<$> getCurrentAccountInfo account
>>= putSequence
541 ownActionGoingQuery
:: RootstockIO
(SqlPersistM
Bool)
542 ownActionGoingQuery
= do
543 actId
<- gets rsAction
544 return $ maybe False (not . actionFinished
) <$> P
.get actId
546 ifRunning
:: SqlPersistM
() -> ExceptionalRootstock
()
548 goingQ
<- lift ownActionGoingQuery
549 mapErrorT runSqlQuery
$ do
550 going
<- lift
$ goingQ
551 throwIf NotRunning
$ not going
554 checkRunning
:: ExceptionalRootstock
()
555 checkRunning
= ifRunning
$ return ()
557 submitUntilSequenceCatchup
' :: [Transaction
] -> ExceptionalRootstock
()
558 submitUntilSequenceCatchup
' txs
= unless (null txs
) $ do
560 forM_ txs
$ lift
. signAndSend
561 lift
(waitForType
:: RootstockIO Ledger
)
562 curSeq
<- currentSequence
<$> lift getAccountInfo
563 submitUntilSequenceCatchup
' $ dropWhile ((curSeq
>) . getSequence
) txs
565 submitUntilSequenceCatchup
:: [Transaction
] -> ExceptionalRootstock
()
566 submitUntilSequenceCatchup txs
= do
567 lift
$ putSequence
=<< (toInteger (length txs
) +) <$> gets nextSequence
568 submitUntilSequenceCatchup
' txs
570 clearAndUpdate
:: ExceptionalRootstock
()
571 {- Must have subscribed to ledger updates for this to work -}
573 Offers offerList
<- lift getAccountOffers
576 acInfo
<- lift getAccountInfo
577 acLines
<- lift getAccountLines
578 vs
<- lift
$ gets valueSimplex
579 let vs
' = updatedValueSimplex vs acInfo acLines
580 when (status
(~~
=) vs
' /= OK
) $ error "Invalid updated ValueSimplex!"
582 unless (strictlySuperior
(~~
=) vs
' vs
) $ do
584 vs
'' = updatedValueSimplexWithGenerosity generosity vs acInfo acLines
586 = " non-superior ValueSimplex (generosity: "
587 `T
.append` T
.pack
(show generosity
)
589 if strictlySuperior
(~~
=) vs
'' vs
590 then warn
$ "Slightly" `T
.append` warning
591 else error $ "Seriously" ++ T
.unpack warning
592 writeValueSimplex acInfo acLines vs
'
593 lift
$ putValueSimplex vs
'
595 curSeq
<- lift
$ gets nextSequence
596 submitUntilSequenceCatchup
$ zipWith
597 (\off sequ
-> OfferCancel sequ
$ offerSequence off
)
602 getUpdatedValueSimplexWithAccountInfo
::
603 AccountInfo
-> RootstockIO ValueSimplexND
604 getUpdatedValueSimplexWithAccountInfo acInfo
=
605 updatedValueSimplex
<$> gets valueSimplex
<*> pure acInfo
<*> getAccountLines
607 getUpdatedValueSimplex
:: RootstockIO ValueSimplexND
608 getUpdatedValueSimplex
=
609 getUpdatedValueSimplexWithAccountInfo
=<< getAccountInfo
611 strictlySuperiorToCurrent
:: ValueSimplexND
-> RootstockIO
Bool
612 strictlySuperiorToCurrent vs
' = strictlySuperior
(~~
=) vs
' <$> gets valueSimplex
614 waitForImprovement
:: ExceptionalRootstock
()
615 waitForImprovement
= do
617 unlessM
(lift
$ strictlySuperiorToCurrent
=<< getUpdatedValueSimplex
) $ do
618 lift
(waitForType
:: RootstockIO Ledger
)
619 lift
(waitForType
:: RootstockIO RecordedTransaction
)
622 submitAndWait
:: [Transaction
] -> ExceptionalRootstock
()
623 submitAndWait txs
= do
624 submitUntilSequenceCatchup txs
627 getTransitRates
:: RootstockIO
(NodeEntity
-> Double)
629 peers
<- catMaybes . Set
.toList
. Set
.map peerOfNodeEntity
. nodes
630 <$> gets valueSimplex
631 trm
<- buildMap peers
$ \peer
-> transferRate
<$> getCurrentAccountInfo peer
632 return $ \x
-> fromMaybe 1 $ peerOfNodeEntity x
>>= flip Map
.lookup trm
634 startRunning
:: RootstockIO
()
636 mavs
<- runSqlQuery
$ do
637 mcurAc
<- getCurrentAction
639 Nothing
-> error $ show DatabaseNotSetUp
641 if actionEntityFinished curAc
643 actId
<- startAction Running
644 vs
<- readValueSimplex
645 return $ Just
(actId
, vs
)
649 waitForType
:: RootstockIO Ledger
651 Just
(actId
, vs
) -> do
656 ensureRunning
:: RootstockIO
()
658 unlessM
(join $ runSqlQuery
<$> ownActionGoingQuery
)
661 marketMakerLoop
:: RootstockIO
()
667 <$> gets valueSimplex
669 <*> gets nextSequence
676 --------------------------------------------------------------------------------
677 getLineBal
:: AccountLines
-> IOULine
-> ExceptionalRootstock
Double
678 getLineBal acLines fundLine
= do
679 lineBal
<- case lookupLine acLines fundLine
of
680 Nothing
-> throwError LineNotFound
681 Just amount
-> return $ getQuantity amount
682 throwIf NonPositiveLine
$ lineBal
<= 0
685 setupDatabase
:: IOULine
-> ExceptionalRootstock
()
686 setupDatabase fundLine
= do
687 isEmpt
<- lift
$ valueSimplexEmpty
688 throwIf DatabaseExists
$ not isEmpt
689 lift
$ runWebsocket subscribeLedger
690 acInfo
<- lift getAccountInfo
691 let dropsBal
= getQuantity
$ lookupXRP acInfo
692 throwIf InsufficientForReserve
$ dropsBal
<= 0
693 acLines
<- lift getAccountLines
694 lineBal
<- getLineBal acLines fundLine
695 lift
$ runSqlQuery
$ do
696 xrpNodeEntity
<- insertReturnEntity
$ Node
{nodeFund
= XRP
}
697 lineNodeEntity
<- insertReturnEntity
$ Node
{nodeFund
= IOUFund fundLine
}
698 writeValueSimplex acInfo acLines
$
699 flip fromFunction
(Set
.fromList
[xrpNodeEntity
, lineNodeEntity
]) $ \x _
->
700 if x
== xrpNodeEntity
704 addCurrency
:: IOULine
-> Double -> ExceptionalRootstock
()
705 addCurrency fundLine priceInDrops
= do
706 mxrpNodeEntity
<- lift
$ runSqlQuery
$ getBy
$ NodeUnique XRP
707 xrpNodeEntity
<- maybe (throwError DatabaseNotSetUp
) return mxrpNodeEntity
708 throwIf NonPositivePrice
$ priceInDrops
<= 0
709 let lineFund
= IOUFund fundLine
711 isJust <$> (lift
$ runSqlQuery
$ getBy
$ NodeUnique lineFund
)
712 throwIf CurrencyAlreadyPresent alreadyPresent
713 lift
$ runWebsocket subscribeLedgerAndAccount
714 lift
$ getAndPutSequence
716 acLines
<- lift getAccountLines
717 lineBal
<- getLineBal acLines fundLine
718 vs
<- lift
$ gets valueSimplex
719 throwIf NewOutweighsOld
$
720 priceInDrops
* lineBal
>= totalValue vs xrpNodeEntity
721 acInfo
<- lift getAccountInfo
722 lift
$ runSqlQuery
$ do
723 lineNodeEntity
<- insertReturnEntity
$ Node
{nodeFund
= lineFund
}
724 writeValueSimplex acInfo acLines
$
725 addNode vs lineNodeEntity lineBal xrpNodeEntity priceInDrops
727 report
:: RootstockIO
()
729 now
<- liftIO getCurrentTime
730 (vs
, lastInterventionTime
) <- runSqlQuery
$ do
731 [Value
(Just lastInterventionTime
)] <- select
$ from
$ \acEnt
-> do
732 where_
$ acEnt ^
. ActionLogAction
!=. val Running
733 orderBy
[desc
$ acEnt ^
. ActionLogStart
]
735 return $ acEnt ^
. ActionLogEnd
736 vs
<- readValueSimplexAt lastInterventionTime
737 return (vs
, lastInterventionTime
)
738 vs
' <- gets valueSimplex
741 let xys
= distinctPairsOneWay xs
742 let v
= sqrt .! linkValueSquared vs
743 let v
' = sqrt .! linkValueSquared vs
'
744 forM_ xys
$ \(x
, y
) -> mapM_ putStrLn
745 [ show $ nodeFund
$ entityVal x
746 , show $ nodeFund
$ entityVal y
749 ** ((60 * 60 * 24 * 365)
750 / (fromRational $ toRational $
751 diffUTCTime now lastInterventionTime
))
756 p
= flip (price vs
') x0
757 x0Gain
= flip sumWith xys
$ \(x
, y
) ->
758 2 * sqrt (p x
) * sqrt (p y
) * (v
' x y
- v x y
)
759 forM_ xs
$ \x
-> mapM_ putStrLn
760 [ show $ nodeFund
$ entityVal x
761 , show $ totalValue vs
' x
762 , show $ x0Gain
/ p x
767 --------------------------------------------------------------------------------
768 runRootstock
:: RootstockIO a
-> Rootstock
-> IO a
769 runRootstock
= evalStateT
771 marketMaker
:: RootstockIO
()
773 isEmpt
<- valueSimplexEmpty
774 when isEmpt
$ error $ show DatabaseNotSetUp
775 runWebsocket subscribeLedgerAndAccount
778 liftIO
$ catch (runRootstock marketMakerLoop rs
) $ \e
-> do
779 flip runSqlPersistM
(sql rs
) $ do
780 curAc
<- fromJust <$> getCurrentAction
781 if actionRunning curAc
785 $ fromException e `
elem`
map Just
[ThreadKilled
, UserInterrupt
]
787 putStrLn $ "Exiting on: " ++ show e
789 rippleInteract
:: WS
.ClientApp
()
790 rippleInteract conn
= do
791 -- Fork a thread that writes WS data to stdout
792 _
<- forkIO
$ forever
$ do
793 msg
<- WS
.receiveData conn
794 liftIO
$ T
.putStrLn msg
796 runRipple subscribeAccount
798 -- Read from stdin and write to WS
801 unless (T
.null line
) $ WS
.sendTextData conn line
>> loop
804 WS
.sendClose conn
("Bye!" :: Text
)
806 readSecret
:: IO String
807 readSecret
= readProcess
"gpg" ["-o", "-", secretFile
] ""
809 readSqlPass
:: IO BS
.ByteString
810 readSqlPass
= readProcess
"gpg" ["-o", "-", sqlPassFile
] "" >>= return . BS
.pack
812 runRipple
:: WS
.ClientApp a
-> IO a
813 runRipple app
= WS
.runClient
"s1.ripple.com" 443 "/" app
815 runRippleWithSecret
:: RootstockIO a
-> IO a
816 runRippleWithSecret app
= do
818 sqlPass
<- readSqlPass
819 withPostgresqlConn
(BS
.concat [connString
, sqlPass
]) $ \sqlConn
-> do
820 vs
<- flip runSqlPersistM sqlConn
$ do
821 runMigration migrateAll
823 runRipple
$ \wsConn
->
824 runRootstock app
$ Rootstock
830 , rsAction
= noAction
837 ["setup", currency
, peer
] -> runRippleWithSecret
$ intervene InitialSetup
$
838 setupDatabase
$ IOULine
839 { peerAccount
= T
.pack peer
840 , lineCurrency
= T
.pack currency
842 ["run"] -> runRippleWithSecret marketMaker
843 ["addCurrency", currency
, peer
, priceInXRP
] ->
844 runRippleWithSecret
$ intervene AddNode
$ addCurrency
846 { peerAccount
= T
.pack peer
847 , lineCurrency
= T
.pack currency
850 $ read priceInXRP
* 1000000
851 ["report"] -> runRippleWithSecret report
852 _
-> putStrLn "Command not understood"