mirror of
https://github.com/urbit/shrub.git
synced 2024-12-21 09:51:36 +03:00
Elliot Glaysher
GitHub
commit
db5ea2145d
@ -1,7 +1,8 @@
|
||||
{-# OPTIONS_GHC -Werror -Wall #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
||||
module CLI (parseArgs, Cmd(..), New(..), Run(..), Bug(..), Opts(..)) where
|
||||
module CLI (parseArgs, Cmd(..), BootType(..), New(..), Run(..), Bug(..),
|
||||
Opts(..)) where
|
||||
|
||||
import ClassyPrelude
|
||||
import Options.Applicative
|
||||
@ -19,19 +20,27 @@ data Opts = Opts
|
||||
, oDryRun :: Bool
|
||||
, oVerbose :: Bool
|
||||
, oAmesPort :: Maybe Word16
|
||||
, oProf :: Bool
|
||||
, oTrace :: Bool
|
||||
, oCollectFx :: Bool
|
||||
, oLocalhost :: Bool
|
||||
, oOffline :: Bool
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data BootType
|
||||
= BootComet
|
||||
| BootFake Text
|
||||
| BootFromKeyfile FilePath
|
||||
deriving (Show)
|
||||
|
||||
data New = New
|
||||
{ nPillPath :: FilePath
|
||||
, nShipAddr :: Text
|
||||
, nPierPath :: Maybe FilePath -- Derived from ship name if not specified.
|
||||
, nArvoDir :: Maybe FilePath
|
||||
, nBootFake :: Bool
|
||||
-- TODO: Pill path needs to become optional; need to default to either the
|
||||
-- git hash version or the release version per current vere.
|
||||
{ nPillPath :: FilePath
|
||||
, nPierPath :: Maybe FilePath -- Derived from ship name if not specified.
|
||||
, nArvoDir :: Maybe FilePath
|
||||
, nBootType :: BootType
|
||||
, nLite :: Bool
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
@ -62,6 +71,10 @@ data Bug
|
||||
, bFirstEvt :: Word64
|
||||
, bFinalEvt :: Word64
|
||||
}
|
||||
| CheckDawn
|
||||
{ bKeyfilePath :: FilePath
|
||||
}
|
||||
| CheckComet
|
||||
deriving (Show)
|
||||
|
||||
data Cmd
|
||||
@ -115,27 +128,44 @@ parseArgs = do
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
newComet :: Parser BootType
|
||||
newComet = flag' BootComet
|
||||
( long "comet"
|
||||
<> help "Boot a new comet")
|
||||
|
||||
newFakeship :: Parser BootType
|
||||
newFakeship = BootFake <$> strOption
|
||||
(short 'F'
|
||||
<> long "fake"
|
||||
<> metavar "SHIP"
|
||||
<> help "Boot a fakeship")
|
||||
|
||||
newFromKeyfile :: Parser BootType
|
||||
newFromKeyfile = BootFromKeyfile <$> strOption
|
||||
(short 'k'
|
||||
<> long "keyfile"
|
||||
<> metavar "KEYFILE"
|
||||
<> help "Boot from a keyfile")
|
||||
|
||||
new :: Parser New
|
||||
new = do
|
||||
nShipAddr <- strArgument
|
||||
$ metavar "SHIP"
|
||||
<> help "Ship address"
|
||||
|
||||
nPierPath <- optional
|
||||
$ strArgument
|
||||
$ metavar "PIER"
|
||||
<> help "Path to pier"
|
||||
|
||||
nBootType <- newComet <|> newFakeship <|> newFromKeyfile
|
||||
|
||||
nPillPath <- strOption
|
||||
$ short 'B'
|
||||
<> long "pill"
|
||||
<> metavar "PILL"
|
||||
<> help "Path to pill file"
|
||||
|
||||
nBootFake <- switch
|
||||
$ short 'F'
|
||||
<> long "fake"
|
||||
<> help "Create a fake ship"
|
||||
nLite <- switch
|
||||
$ short 'l'
|
||||
<> long "lite"
|
||||
<> help "Boots ship in lite mode"
|
||||
|
||||
nArvoDir <- option auto
|
||||
$ metavar "PATH"
|
||||
@ -180,10 +210,10 @@ opts = do
|
||||
<> help "Dry run -- Don't persist"
|
||||
<> hidden
|
||||
|
||||
oProf <- switch $ short 'p'
|
||||
<> long "profile"
|
||||
<> help "Enable profiling"
|
||||
<> hidden
|
||||
oTrace <- switch $ short 't'
|
||||
<> long "trace"
|
||||
<> help "Enable tracing"
|
||||
<> hidden
|
||||
|
||||
oLocalhost <- switch $ short 'L'
|
||||
<> long "local"
|
||||
@ -226,6 +256,9 @@ valPill = do
|
||||
pierPath :: Parser FilePath
|
||||
pierPath = strArgument (metavar "PIER" <> help "Path to pier")
|
||||
|
||||
keyfilePath :: Parser FilePath
|
||||
keyfilePath = strArgument (metavar "KEYFILE" <> help "Path to key file")
|
||||
|
||||
firstEv :: Parser Word64
|
||||
firstEv = option auto $ long "first"
|
||||
<> metavar "FST"
|
||||
@ -247,6 +280,9 @@ checkFx = ValidateFX <$> pierPath <*> firstEv <*> lastEv
|
||||
browseEvs :: Parser Bug
|
||||
browseEvs = EventBrowser <$> pierPath
|
||||
|
||||
checkDawn :: Parser Bug
|
||||
checkDawn = CheckDawn <$> keyfilePath
|
||||
|
||||
bugCmd :: Parser Cmd
|
||||
bugCmd = fmap CmdBug
|
||||
$ subparser
|
||||
@ -270,6 +306,14 @@ bugCmd = fmap CmdBug
|
||||
( info (checkFx <**> helper)
|
||||
$ progDesc "Parse all data in event log"
|
||||
)
|
||||
<> command "dawn"
|
||||
( info (checkDawn <**> helper)
|
||||
$ progDesc "Test run dawn"
|
||||
)
|
||||
<> command "comet"
|
||||
( info (pure CheckComet)
|
||||
$ progDesc "Shows the list of stars accepting comets"
|
||||
)
|
||||
|
||||
conCmd :: Parser Cmd
|
||||
conCmd = do
|
||||
|
||||
@ -87,9 +87,10 @@ import UrbitPrelude
|
||||
import Arvo
|
||||
import Data.Acquire
|
||||
import Data.Conduit
|
||||
import Data.Conduit.List hiding (replicate, take)
|
||||
import Data.Conduit.List hiding (catMaybes, map, replicate, take)
|
||||
import Data.RAcquire
|
||||
import Noun hiding (Parser)
|
||||
import Noun.Atom
|
||||
import RIO.Directory
|
||||
import Vere.Pier
|
||||
import Vere.Pier.Types
|
||||
@ -102,14 +103,18 @@ import Data.Default (def)
|
||||
import KingApp (runApp)
|
||||
import System.Environment (getProgName)
|
||||
import System.Posix.Signals (Handler(Catch), installHandler, sigTERM)
|
||||
import System.Random (randomIO)
|
||||
import Text.Show.Pretty (pPrint)
|
||||
import Urbit.Time (Wen)
|
||||
import Vere.Dawn
|
||||
import Vere.LockFile (lockFile)
|
||||
|
||||
import qualified CLI as CLI
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Text as T
|
||||
import qualified EventBrowser as EventBrowser
|
||||
import qualified System.IO.LockFile.Internal as Lock
|
||||
import qualified Urbit.Ob as Ob
|
||||
import qualified Vere.Log as Log
|
||||
import qualified Vere.Pier as Pier
|
||||
import qualified Vere.Serf as Serf
|
||||
@ -130,8 +135,26 @@ removeFileIfExists pax = do
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
tryBootFromPill :: HasLogFunc e => FilePath -> FilePath -> Ship -> RIO e ()
|
||||
tryBootFromPill pillPath shipPath ship = do
|
||||
toSerfFlags :: CLI.Opts -> Serf.Flags
|
||||
toSerfFlags CLI.Opts{..} = catMaybes m
|
||||
where
|
||||
-- TODO: This is not all the flags.
|
||||
m = [ from oQuiet Serf.Quiet
|
||||
, from oTrace Serf.Trace
|
||||
, from oHashless Serf.Hashless
|
||||
, from oQuiet Serf.Quiet
|
||||
, from oVerbose Serf.Verbose
|
||||
, from oDryRun Serf.DryRun
|
||||
]
|
||||
from True flag = Just flag
|
||||
from False _ = Nothing
|
||||
|
||||
|
||||
tryBootFromPill :: HasLogFunc e
|
||||
=> FilePath -> FilePath -> Bool -> Serf.Flags -> Ship
|
||||
-> LegacyBootEvent
|
||||
-> RIO e ()
|
||||
tryBootFromPill pillPath shipPath lite flags ship boot = do
|
||||
rwith bootedPier $ \(serf, log, ss) -> do
|
||||
logTrace "Booting"
|
||||
logTrace $ displayShow ss
|
||||
@ -142,7 +165,7 @@ tryBootFromPill pillPath shipPath ship = do
|
||||
where
|
||||
bootedPier = do
|
||||
lockFile shipPath
|
||||
Pier.booted pillPath shipPath [] ship
|
||||
Pier.booted pillPath shipPath lite flags ship boot
|
||||
|
||||
runAcquire :: (MonadUnliftIO m, MonadIO m)
|
||||
=> Acquire a -> m a
|
||||
@ -152,17 +175,17 @@ runRAcquire :: (MonadUnliftIO (m e), MonadIO (m e), MonadReader e (m e))
|
||||
=> RAcquire e a -> m e a
|
||||
runRAcquire act = rwith act pure
|
||||
|
||||
tryPlayShip :: HasLogFunc e => FilePath -> RIO e ()
|
||||
tryPlayShip shipPath = do
|
||||
tryPlayShip :: HasLogFunc e => FilePath -> Serf.Flags -> RIO e ()
|
||||
tryPlayShip shipPath flags = do
|
||||
runRAcquire $ do
|
||||
lockFile shipPath
|
||||
rio $ logTrace "RESUMING SHIP"
|
||||
sls <- Pier.resumed shipPath []
|
||||
sls <- Pier.resumed shipPath flags
|
||||
rio $ logTrace "SHIP RESUMED"
|
||||
Pier.pier shipPath Nothing sls
|
||||
|
||||
tryResume :: HasLogFunc e => FilePath -> RIO e ()
|
||||
tryResume shipPath = do
|
||||
tryResume :: HasLogFunc e => FilePath -> Serf.Flags -> RIO e ()
|
||||
tryResume shipPath flags = do
|
||||
rwith resumedPier $ \(serf, log, ss) -> do
|
||||
logTrace (displayShow ss)
|
||||
threadDelay 500000
|
||||
@ -172,12 +195,12 @@ tryResume shipPath = do
|
||||
where
|
||||
resumedPier = do
|
||||
lockFile shipPath
|
||||
Pier.resumed shipPath []
|
||||
Pier.resumed shipPath flags
|
||||
|
||||
tryFullReplay :: HasLogFunc e => FilePath -> RIO e ()
|
||||
tryFullReplay shipPath = do
|
||||
tryFullReplay :: HasLogFunc e => FilePath -> Serf.Flags -> RIO e ()
|
||||
tryFullReplay shipPath flags = do
|
||||
wipeSnapshot
|
||||
tryResume shipPath
|
||||
tryResume shipPath flags
|
||||
where
|
||||
wipeSnapshot = do
|
||||
logTrace "wipeSnapshot"
|
||||
@ -263,7 +286,7 @@ testPill pax showPil showSeq = do
|
||||
pill <- fromNounErr pillNoun & either (throwIO . uncurry ParseErr) pure
|
||||
|
||||
putStrLn "Using pill to generate boot sequence."
|
||||
bootSeq <- generateBootSeq zod pill
|
||||
bootSeq <- generateBootSeq zod pill False (Fake $ Ship 0)
|
||||
|
||||
putStrLn "Validate jam/cue and toNoun/fromNoun on pill value"
|
||||
reJam <- validateNounVal pill
|
||||
@ -311,14 +334,73 @@ validateNounVal inpVal = do
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
newShip :: HasLogFunc e => CLI.New -> CLI.Opts -> RIO e ()
|
||||
newShip CLI.New{..} _ = do
|
||||
tryBootFromPill nPillPath pierPath (Ship 0)
|
||||
newShip :: forall e. HasLogFunc e => CLI.New -> CLI.Opts -> RIO e ()
|
||||
newShip CLI.New{..} opts
|
||||
| CLI.BootComet <- nBootType = do
|
||||
putStrLn "boot: retrieving list of stars currently accepting comets"
|
||||
starList <- dawnCometList
|
||||
putStrLn ("boot: " ++ (tshow $ length starList) ++
|
||||
" star(s) currently accepting comets")
|
||||
putStrLn "boot: mining a comet"
|
||||
eny <- io $ randomIO
|
||||
let seed = mineComet (Set.fromList starList) eny
|
||||
putStrLn ("boot: found comet " ++ (renderShip (sShip seed)))
|
||||
bootFromSeed seed
|
||||
|
||||
| CLI.BootFake name <- nBootType = do
|
||||
ship <- shipFrom name
|
||||
tryBootFromPill nPillPath (pierPath name) nLite flags ship (Fake ship)
|
||||
|
||||
| CLI.BootFromKeyfile keyFile <- nBootType = do
|
||||
text <- readFileUtf8 keyFile
|
||||
asAtom <- case cordToUW (Cord $ T.strip text) of
|
||||
Nothing -> error "Couldn't parse keyfile. Hint: keyfiles start with 0w?"
|
||||
Just (UW a) -> pure a
|
||||
|
||||
asNoun <- cueExn asAtom
|
||||
seed :: Seed <- case fromNoun asNoun of
|
||||
Nothing -> error "Keyfile does not seem to contain a seed."
|
||||
Just s -> pure s
|
||||
|
||||
bootFromSeed seed
|
||||
|
||||
where
|
||||
pierPath = fromMaybe ("./" <> unpack nShipAddr) nPierPath
|
||||
shipFrom :: Text -> RIO e Ship
|
||||
shipFrom name = case Ob.parsePatp name of
|
||||
Left x -> error "Invalid ship name"
|
||||
Right p -> pure $ Ship $ fromIntegral $ Ob.fromPatp p
|
||||
|
||||
pierPath :: Text -> FilePath
|
||||
pierPath name = case nPierPath of
|
||||
Just x -> x
|
||||
Nothing -> "./" <> unpack name
|
||||
|
||||
nameFromShip :: Ship -> RIO e Text
|
||||
nameFromShip s = name
|
||||
where
|
||||
nameWithSig = Ob.renderPatp $ Ob.patp $ fromIntegral s
|
||||
name = case stripPrefix "~" nameWithSig of
|
||||
Nothing -> error "Urbit.ob didn't produce string with ~"
|
||||
Just x -> pure x
|
||||
|
||||
bootFromSeed :: Seed -> RIO e ()
|
||||
bootFromSeed seed = do
|
||||
ethReturn <- dawnVent seed
|
||||
|
||||
case ethReturn of
|
||||
Left x -> error $ unpack x
|
||||
Right dawn -> do
|
||||
let ship = sShip $ dSeed dawn
|
||||
path <- pierPath <$> nameFromShip ship
|
||||
tryBootFromPill nPillPath path nLite flags ship (Dawn dawn)
|
||||
|
||||
flags = toSerfFlags opts
|
||||
|
||||
|
||||
|
||||
runShip :: HasLogFunc e => CLI.Run -> CLI.Opts -> RIO e ()
|
||||
runShip (CLI.Run pierPath) _ = tryPlayShip pierPath
|
||||
runShip (CLI.Run pierPath) opts = tryPlayShip pierPath (toSerfFlags opts)
|
||||
|
||||
|
||||
startBrowser :: HasLogFunc e => FilePath -> RIO e ()
|
||||
startBrowser pierPath = runRAcquire $ do
|
||||
@ -326,6 +408,39 @@ startBrowser pierPath = runRAcquire $ do
|
||||
log <- Log.existing (pierPath <> "/.urb/log")
|
||||
rio $ EventBrowser.run log
|
||||
|
||||
cordToUW :: Cord -> Maybe UW
|
||||
cordToUW = fromNoun . toNoun
|
||||
|
||||
checkDawn :: HasLogFunc e => FilePath -> RIO e ()
|
||||
checkDawn keyfilePath = do
|
||||
-- The keyfile is a jammed Seed then rendered in UW format
|
||||
text <- readFileUtf8 keyfilePath
|
||||
asAtom <- case cordToUW (Cord $ T.strip text) of
|
||||
Nothing -> error "Couldn't parse keyfile. Hint: keyfiles start with 0w?"
|
||||
Just (UW a) -> pure a
|
||||
|
||||
asNoun <- cueExn asAtom
|
||||
seed :: Seed <- case fromNoun asNoun of
|
||||
Nothing -> error "Keyfile does not seem to contain a seed."
|
||||
Just s -> pure s
|
||||
|
||||
print $ show seed
|
||||
|
||||
e <- dawnVent seed
|
||||
print $ show e
|
||||
|
||||
|
||||
checkComet :: HasLogFunc e => RIO e ()
|
||||
checkComet = do
|
||||
starList <- dawnCometList
|
||||
putStrLn "Stars currently accepting comets:"
|
||||
let starNames = map (Ob.renderPatp . Ob.patp . fromIntegral) starList
|
||||
print starNames
|
||||
putStrLn "Trying to mine a comet..."
|
||||
eny <- io $ randomIO
|
||||
let s = mineComet (Set.fromList starList) eny
|
||||
print s
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
mainTid <- myThreadId
|
||||
@ -342,6 +457,8 @@ main = do
|
||||
CLI.CmdBug (CLI.ValidatePill pax pil seq) -> testPill pax pil seq
|
||||
CLI.CmdBug (CLI.ValidateEvents pax f l) -> checkEvs pax f l
|
||||
CLI.CmdBug (CLI.ValidateFX pax f l) -> checkFx pax f l
|
||||
CLI.CmdBug (CLI.CheckDawn pax) -> checkDawn pax
|
||||
CLI.CmdBug CLI.CheckComet -> checkComet
|
||||
CLI.CmdCon port -> connTerm port
|
||||
|
||||
|
||||
|
||||
@ -135,14 +135,14 @@ data Blit
|
||||
-- Manual instance to not save the noun/atom in Sag/Sav, because these can be
|
||||
-- megabytes and makes king hang.
|
||||
instance Show Blit where
|
||||
show (Bel ()) = "Bel ()"
|
||||
show (Clr ()) = "Clr ()"
|
||||
show (Hop x) = "Hop " ++ (show x)
|
||||
show (Lin c) = "Lin " ++ (show c)
|
||||
show (Mor ()) = "Mor ()"
|
||||
show (Bel ()) = "Bel ()"
|
||||
show (Clr ()) = "Clr ()"
|
||||
show (Hop x) = "Hop " ++ (show x)
|
||||
show (Lin c) = "Lin " ++ (show c)
|
||||
show (Mor ()) = "Mor ()"
|
||||
show (Sag path _) = "Sag " ++ (show path)
|
||||
show (Sav path _) = "Sav " ++ (show path)
|
||||
show (Url c) = "Url " ++ (show c)
|
||||
show (Url c) = "Url " ++ (show c)
|
||||
|
||||
{-
|
||||
%blip -- TODO
|
||||
@ -152,7 +152,7 @@ instance Show Blit where
|
||||
-}
|
||||
data TermEf
|
||||
= TermEfBlit (UD, ()) [Blit]
|
||||
| TermEfInit (UD, ()) ()
|
||||
| TermEfInit (UD, ()) Ship
|
||||
| TermEfLogo Path ()
|
||||
| TermEfMass Path Noun -- Irrelevant
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
@ -9,18 +9,18 @@ import Arvo.Common (Header(..), HttpEvent)
|
||||
import Arvo.Common (AmesDest, Ipv4, Ipv6, Port, Turf)
|
||||
import Arvo.Common (ReOrg(..), reorgThroughNoun)
|
||||
|
||||
import qualified Crypto.Sign.Ed25519 as Ed
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Char8 as C
|
||||
import qualified Network.HTTP.Types.Method as H
|
||||
|
||||
|
||||
-- Misc Types ------------------------------------------------------------------
|
||||
|
||||
type Pass = Atom -- Public Key
|
||||
type Rift = Atom -- Continuity number
|
||||
type Life = Word -- Number of Azimoth key revs.
|
||||
type Bloq = Atom -- TODO
|
||||
type Ring = Atom -- Private Key
|
||||
type Oath = Atom -- Signature
|
||||
|
||||
|
||||
-- Parsed URLs -----------------------------------------------------------------
|
||||
|
||||
type Host = Either Turf Ipv4
|
||||
@ -36,15 +36,85 @@ deriveNoun ''PUrl
|
||||
|
||||
-- Dawn Records ----------------------------------------------------------------
|
||||
|
||||
data Seed = Seed Ship Life Ring (Maybe Oath)
|
||||
padByteString :: BS.ByteString -> Int -> BS.ByteString
|
||||
padByteString bs length | remaining > 0 = bs <> (BS.replicate remaining 0)
|
||||
| otherwise = bs
|
||||
where remaining = (length - (BS.length bs))
|
||||
|
||||
-- A Pass is the Atom concatenation of 'b', the public encryption key, and the
|
||||
-- public authentication key. (see +pass-from-eth.)
|
||||
data Pass = Pass { passSign :: Ed.PublicKey, passCrypt :: Ed.PublicKey }
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
passToBS :: Pass -> BS.ByteString
|
||||
passToBS Pass{..} = C.singleton 'b' <>
|
||||
(Ed.unPublicKey passSign) <>
|
||||
(Ed.unPublicKey passCrypt)
|
||||
|
||||
instance ToNoun Pass where
|
||||
toNoun p = Atom $ (passToBS p) ^. from atomBytes
|
||||
|
||||
instance FromNoun Pass where
|
||||
parseNoun n = named "Pass" $ do
|
||||
MkBytes unpadded <- parseNoun n
|
||||
let bs = padByteString unpadded 65
|
||||
when ((C.head bs) /= 'b') $ do
|
||||
fail "Expecting 'b' prefix in public key structure"
|
||||
let removedPrefix = C.tail bs
|
||||
let passSign = Ed.PublicKey (take 32 removedPrefix)
|
||||
let passCrypt = Ed.PublicKey (drop 32 removedPrefix)
|
||||
unless ((length $ Ed.unPublicKey passSign) == 32) $
|
||||
error "Sign pubkey not 32 bytes"
|
||||
unless ((length $ Ed.unPublicKey passCrypt) == 32) $
|
||||
error "Crypt pubkey not 32 bytes"
|
||||
pure $ Pass{..}
|
||||
|
||||
-- A Ring isn't the secret keys: it's the ByteString input which generates both
|
||||
-- the public key and the secret key. A Ring is the concatenation of 'B', the
|
||||
-- encryption key derivation seed, and the authentication key derivation
|
||||
-- seed. These aren't actually private keys, but public/private keypairs which
|
||||
-- can be derived from these seeds.
|
||||
data Ring = Ring { ringSign :: BS.ByteString, ringCrypt :: BS.ByteString }
|
||||
deriving (Eq)
|
||||
|
||||
instance ToNoun Ring where
|
||||
toNoun Ring{..} =
|
||||
Atom $ bs ^. from atomBytes
|
||||
where
|
||||
bs = C.singleton 'B' <> ringSign <> ringCrypt
|
||||
|
||||
instance FromNoun Ring where
|
||||
parseNoun n = named "Ring" $ do
|
||||
MkBytes unpadded <- parseNoun n
|
||||
let bs = padByteString unpadded 65
|
||||
when ((C.head bs) /= 'B') $ do
|
||||
fail "Expecting 'B' prefix in public key structure"
|
||||
let removedPrefix = C.tail bs
|
||||
let ringSign = (take 32 removedPrefix)
|
||||
let ringCrypt = (drop 32 removedPrefix)
|
||||
unless ((length ringSign) == 32) $
|
||||
error "Sign seed not 32 bytes"
|
||||
unless ((length ringCrypt) == 32) $
|
||||
error "Crypt seed not 32 bytes"
|
||||
pure $ Ring ringSign ringCrypt
|
||||
|
||||
instance Show Ring where
|
||||
show r = "(Ring <<seed>> <<seed>>)"
|
||||
|
||||
data Seed = Seed
|
||||
{ sShip :: Ship
|
||||
, sLife :: Life
|
||||
, sRing :: Ring
|
||||
, sOath :: (Maybe Oath)
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
type Public = (Life, HoonMap Life Pass)
|
||||
|
||||
data Dnses = Dnses { dPri::Cord, dSec::Cord, dTer::Cord }
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
type EthAddr = Bytes -- 20 bytes
|
||||
type EthAddr = Atom --Bytes -- 20 bytes
|
||||
type ContNum = Word
|
||||
|
||||
data EthPoint = EthPoint
|
||||
@ -52,41 +122,20 @@ data EthPoint = EthPoint
|
||||
, epNet :: Maybe (Life, Pass, ContNum, (Bool, Ship), Maybe Ship)
|
||||
, epKid :: Maybe (EthAddr, HoonSet Ship)
|
||||
}
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
data EthEventId = EthEventId
|
||||
{ eeiBlock :: Atom
|
||||
, eeiLog :: Atom
|
||||
}
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
data EthBookmark = EthBookmark
|
||||
{ ebHeard :: HoonSet EthEventId
|
||||
, ebLatestBlock :: Atom
|
||||
}
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
data Snap = Snap (HoonMap Ship Public)
|
||||
(Dnses, HoonMap Ship EthPoint)
|
||||
EthBookmark
|
||||
deriving (Eq, Ord, Show)
|
||||
deriving (Eq, Show)
|
||||
|
||||
data Dawn = MkDawn
|
||||
{ dSeed :: Seed
|
||||
, dShip :: Ship
|
||||
, dCzar :: HoonMap Ship (Life, Pass)
|
||||
, dTurf :: [Turf]
|
||||
, dBloq :: Bloq
|
||||
, dNode :: (Maybe PUrl)
|
||||
, dSnap :: (Maybe Snap)
|
||||
{ dSeed :: Seed
|
||||
, dSponsor :: [(Ship, EthPoint)]
|
||||
, dCzar :: HoonMap Ship (Rift, Life, Pass)
|
||||
, dTurf :: [Turf]
|
||||
, dBloq :: Bloq
|
||||
, dNode :: (Maybe PUrl)
|
||||
}
|
||||
deriving (Eq, Ord, Show)
|
||||
deriving (Eq, Show)
|
||||
|
||||
deriveNoun ''EthEventId
|
||||
deriveNoun ''EthBookmark
|
||||
deriveNoun ''Dnses
|
||||
deriveNoun ''EthPoint
|
||||
deriveNoun ''Snap
|
||||
deriveNoun ''Seed
|
||||
deriveNoun ''Dawn
|
||||
|
||||
@ -187,8 +236,8 @@ deriveNoun ''BehnEv
|
||||
-- Newt Events -----------------------------------------------------------------
|
||||
|
||||
data NewtEv
|
||||
= NewtEvBarn (Atom, ()) ()
|
||||
| NewtEvCrud Path Cord Tang
|
||||
= NewtEvBarn (KingId, ()) ()
|
||||
| NewtEvCrud Path Cord Tang
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
deriveNoun ''NewtEv
|
||||
@ -209,7 +258,7 @@ deriveNoun ''SyncEv
|
||||
data LegacyBootEvent
|
||||
= Fake Ship
|
||||
| Dawn Dawn
|
||||
deriving (Eq, Ord, Show)
|
||||
deriving (Eq, Show)
|
||||
|
||||
data ArrowKey = D | L | R | U
|
||||
deriving (Eq, Ord, Show)
|
||||
@ -230,7 +279,7 @@ data TermEv
|
||||
| TermEvBoot (UD, ()) Bool LegacyBootEvent
|
||||
| TermEvHail (UD, ()) ()
|
||||
| TermEvCrud Path Cord Tang
|
||||
deriving (Eq, Ord, Show)
|
||||
deriving (Eq, Show)
|
||||
|
||||
deriveNoun ''LegacyBootEvent
|
||||
deriveNoun ''ArrowKey
|
||||
@ -250,7 +299,7 @@ data BlipEv
|
||||
| BlipEvNewt NewtEv
|
||||
| BlipEvSync SyncEv
|
||||
| BlipEvTerm TermEv
|
||||
deriving (Eq, Ord, Show)
|
||||
deriving (Eq, Show)
|
||||
|
||||
deriveNoun ''BlipEv
|
||||
|
||||
@ -287,7 +336,7 @@ deriveNoun ''ZuseEv
|
||||
data Ev
|
||||
= EvBlip BlipEv
|
||||
| EvVane Vane
|
||||
deriving (Eq, Ord, Show)
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance ToNoun Ev where
|
||||
toNoun = \case
|
||||
|
||||
5
pkg/king/lib/Azimuth/Azimuth.hs
Normal file
5
pkg/king/lib/Azimuth/Azimuth.hs
Normal file
@ -0,0 +1,5 @@
|
||||
module Azimuth.Azimuth where
|
||||
|
||||
import Network.Ethereum.Contract.TH
|
||||
|
||||
[abiFrom|lib/Azimuth/azimuth.json|]
|
||||
1
pkg/king/lib/Azimuth/azimuth.json
Normal file
1
pkg/king/lib/Azimuth/azimuth.json
Normal file
File diff suppressed because one or more lines are too long
@ -7,7 +7,7 @@ module Noun.Conversions
|
||||
, Cord(..), Knot(..), Term(..), Tape(..), Tour(..)
|
||||
, BigTape(..), BigCord(..)
|
||||
, Wall
|
||||
, UD(..), UV(..)
|
||||
, UD(..), UV(..), UW(..)
|
||||
, Mug(..), Path(..), EvilPath(..), Ship(..)
|
||||
, Lenient(..), pathToFilePath, filePathToPath
|
||||
) where
|
||||
@ -102,6 +102,37 @@ instance FromNoun UD where
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
uTypeAddDots :: String -> String
|
||||
uTypeAddDots = reverse . go . reverse
|
||||
where
|
||||
go s = if null tel then hed
|
||||
else hed <> "." <> go tel
|
||||
where
|
||||
hed = take 5 s
|
||||
tel = drop 5 s
|
||||
|
||||
convertToU :: [Char] -> [Char] -> Atom -> String
|
||||
convertToU baseMap prefix = go []
|
||||
where
|
||||
go acc 0 = "0" <> prefix <> uTypeAddDots acc
|
||||
go acc n = go (char n : acc) (n `div` len)
|
||||
|
||||
char n = baseMap !! (fromIntegral (n `mod` len))
|
||||
|
||||
len = fromIntegral (length baseMap)
|
||||
|
||||
convertFromU :: (Char -> Maybe Atom) -> Char -> Atom -> String -> Maybe Atom
|
||||
convertFromU fetch prefix length = \case
|
||||
('0':prefix:cs) -> go (0, 0) (reverse cs)
|
||||
_ -> Nothing
|
||||
where
|
||||
go (i, acc) [] = pure acc
|
||||
go (i, acc) ('.' : cs) = go (i, acc) cs
|
||||
go (i, acc) (c : cs) = do
|
||||
n <- fetch c
|
||||
go (i+1, acc+(length^i)*n) cs
|
||||
|
||||
|
||||
-- @uv
|
||||
newtype UV = UV { unUV :: Atom }
|
||||
deriving newtype (Eq, Ord, Show, Num, Enum, Real, Integral)
|
||||
@ -117,36 +148,14 @@ instance FromNoun UV where
|
||||
Just uv -> pure (UV uv)
|
||||
|
||||
fromUV :: String -> Maybe Atom
|
||||
fromUV = \case
|
||||
('0':'v':cs) -> go (0, 0) (reverse cs)
|
||||
_ -> Nothing
|
||||
where
|
||||
go (i, acc) [] = pure acc
|
||||
go (i, acc) ('.' : cs) = go (i, acc) cs
|
||||
go (i, acc) (c : cs) = do
|
||||
n <- uvCharNum c
|
||||
go (i+1, acc+(32^i)*n) cs
|
||||
fromUV = convertFromU uvCharNum 'v' (fromIntegral $ length base32Chars)
|
||||
|
||||
toUV :: Atom -> String
|
||||
toUV = go []
|
||||
where
|
||||
go acc 0 = "0v" <> uvAddDots acc
|
||||
go acc n = go (char n : acc) (n `div` 32)
|
||||
|
||||
char n = base32Chars !! (fromIntegral (n `mod` 32))
|
||||
toUV = convertToU base32Chars "v"
|
||||
|
||||
base32Chars :: [Char]
|
||||
base32Chars = (['0'..'9'] <> ['a'..'v'])
|
||||
|
||||
uvAddDots :: String -> String
|
||||
uvAddDots = reverse . go . reverse
|
||||
where
|
||||
go s = if null tel then hed
|
||||
else hed <> "." <> go tel
|
||||
where
|
||||
hed = take 5 s
|
||||
tel = drop 5 s
|
||||
|
||||
uvCharNum :: Char -> Maybe Atom
|
||||
uvCharNum = \case
|
||||
'0' -> pure 0
|
||||
@ -183,6 +192,98 @@ uvCharNum = \case
|
||||
'v' -> pure 31
|
||||
_ -> Nothing
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- @uw
|
||||
newtype UW = UW { unUW :: Atom }
|
||||
deriving newtype (Eq, Ord, Show, Num, Enum, Real, Integral)
|
||||
|
||||
instance ToNoun UW where
|
||||
toNoun = toNoun . Cord . pack . toUW . fromIntegral . unUW
|
||||
|
||||
instance FromNoun UW where
|
||||
parseNoun n = do
|
||||
Cord c <- parseNoun n
|
||||
case fromUW $ unpack c of
|
||||
Nothing -> fail ("Invalid @uw: " <> unpack c)
|
||||
Just uw -> pure (UW uw)
|
||||
|
||||
fromUW :: String -> Maybe Atom
|
||||
fromUW = convertFromU uwCharNum 'w' (fromIntegral $ length base64Chars)
|
||||
|
||||
toUW :: Atom -> String
|
||||
toUW = convertToU base64Chars "w"
|
||||
|
||||
base64Chars :: [Char]
|
||||
base64Chars = (['0'..'9'] <> ['a'..'z'] <> ['A'..'Z'] <> ['-', '~'])
|
||||
|
||||
uwCharNum :: Char -> Maybe Atom
|
||||
uwCharNum = \case
|
||||
'0' -> pure 0
|
||||
'1' -> pure 1
|
||||
'2' -> pure 2
|
||||
'3' -> pure 3
|
||||
'4' -> pure 4
|
||||
'5' -> pure 5
|
||||
'6' -> pure 6
|
||||
'7' -> pure 7
|
||||
'8' -> pure 8
|
||||
'9' -> pure 9
|
||||
'a' -> pure 10
|
||||
'b' -> pure 11
|
||||
'c' -> pure 12
|
||||
'd' -> pure 13
|
||||
'e' -> pure 14
|
||||
'f' -> pure 15
|
||||
'g' -> pure 16
|
||||
'h' -> pure 17
|
||||
'i' -> pure 18
|
||||
'j' -> pure 19
|
||||
'k' -> pure 20
|
||||
'l' -> pure 21
|
||||
'm' -> pure 22
|
||||
'n' -> pure 23
|
||||
'o' -> pure 24
|
||||
'p' -> pure 25
|
||||
'q' -> pure 26
|
||||
'r' -> pure 27
|
||||
's' -> pure 28
|
||||
't' -> pure 29
|
||||
'u' -> pure 30
|
||||
'v' -> pure 31
|
||||
'w' -> pure 32
|
||||
'x' -> pure 33
|
||||
'y' -> pure 34
|
||||
'z' -> pure 35
|
||||
'A' -> pure 36
|
||||
'B' -> pure 37
|
||||
'C' -> pure 38
|
||||
'D' -> pure 39
|
||||
'E' -> pure 40
|
||||
'F' -> pure 41
|
||||
'G' -> pure 42
|
||||
'H' -> pure 43
|
||||
'I' -> pure 44
|
||||
'J' -> pure 45
|
||||
'K' -> pure 46
|
||||
'L' -> pure 47
|
||||
'M' -> pure 48
|
||||
'N' -> pure 49
|
||||
'O' -> pure 50
|
||||
'P' -> pure 51
|
||||
'Q' -> pure 52
|
||||
'R' -> pure 53
|
||||
'S' -> pure 54
|
||||
'T' -> pure 55
|
||||
'U' -> pure 56
|
||||
'V' -> pure 57
|
||||
'W' -> pure 58
|
||||
'X' -> pure 59
|
||||
'Y' -> pure 60
|
||||
'Z' -> pure 61
|
||||
'-' -> pure 62
|
||||
'~' -> pure 63
|
||||
_ -> Nothing
|
||||
|
||||
|
||||
-- Char ------------------------------------------------------------------------
|
||||
|
||||
@ -7,27 +7,26 @@ import Network.Socket hiding (recvFrom, sendTo)
|
||||
import Network.Socket.ByteString
|
||||
import Vere.Pier.Types
|
||||
|
||||
import qualified Urbit.Time as Time
|
||||
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.Map as M
|
||||
import qualified Urbit.Ob as Ob
|
||||
import qualified Urbit.Time as Time
|
||||
|
||||
-- Types -----------------------------------------------------------------------
|
||||
|
||||
data AmesDrv = AmesDrv
|
||||
{ aIsLive :: IORef Bool
|
||||
, aSocket :: Socket
|
||||
, aWakeTimer :: Async ()
|
||||
, aListener :: Async ()
|
||||
{ aTurfs :: TVar (Maybe [Turf])
|
||||
, aGalaxies :: IORef (M.Map Galaxy (Async (), TQueue ByteString))
|
||||
, aSocket :: Socket
|
||||
, aWakeTimer :: Async ()
|
||||
, aListener :: Async ()
|
||||
, aSendingQueue :: TQueue (SockAddr, ByteString)
|
||||
, aSendingThread :: Async ()
|
||||
}
|
||||
|
||||
data NetworkMode = Fake | Real
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
{-
|
||||
data GalaxyInfo = GalaxyInfo { ip :: Ipv4, age :: Time.Unix }
|
||||
deriving (Eq, Ord, Show)
|
||||
-}
|
||||
|
||||
|
||||
-- Utils -----------------------------------------------------------------------
|
||||
|
||||
galaxyPort :: NetworkMode -> Galaxy -> PortNumber
|
||||
@ -36,20 +35,23 @@ galaxyPort Real (Galaxy g) = fromIntegral g + 13337
|
||||
|
||||
listenPort :: NetworkMode -> Ship -> PortNumber
|
||||
listenPort m s | s < 256 = galaxyPort m (fromIntegral s)
|
||||
listenPort m _ = 0
|
||||
listenPort m _ = 0
|
||||
|
||||
localhost :: HostAddress
|
||||
localhost = tupleToHostAddress (127,0,0,1)
|
||||
|
||||
inaddrAny :: HostAddress
|
||||
inaddrAny = tupleToHostAddress (0,0,0,0)
|
||||
|
||||
okayFakeAddr :: AmesDest -> Bool
|
||||
okayFakeAddr = \case
|
||||
ADGala _ _ -> True
|
||||
ADIpv4 _ p (Ipv4 a) -> a == localhost
|
||||
|
||||
destSockAddr :: NetworkMode -> AmesDest -> SockAddr
|
||||
destSockAddr m = \case
|
||||
ADGala _ g -> SockAddrInet (galaxyPort m g) localhost
|
||||
ADIpv4 _ p a -> SockAddrInet (fromIntegral p) (unIpv4 a)
|
||||
fakeSockAddr :: AmesDest -> SockAddr
|
||||
fakeSockAddr = \case
|
||||
ADGala _ g -> SockAddrInet (galaxyPort Fake g) localhost
|
||||
ADIpv4 _ p a -> SockAddrInet (fromIntegral p) localhost
|
||||
|
||||
barnEv :: KingId -> Ev
|
||||
barnEv inst =
|
||||
@ -89,63 +91,181 @@ _turfText = intercalate "." . reverse . fmap unCord . unTurf
|
||||
|
||||
TODO verify that the KingIds match on effects.
|
||||
-}
|
||||
ames :: KingId -> Ship -> Maybe Port -> QueueEv
|
||||
-> ([Ev], Acquire (EffCb e NewtEf))
|
||||
ames inst who mPort enqueueEv =
|
||||
ames :: forall e. HasLogFunc e
|
||||
=> KingId -> Ship -> Bool -> Maybe Port -> QueueEv
|
||||
-> ([Ev], RAcquire e (EffCb e NewtEf))
|
||||
ames inst who isFake mPort enqueueEv =
|
||||
(initialEvents, runAmes)
|
||||
where
|
||||
initialEvents :: [Ev]
|
||||
initialEvents = [barnEv inst]
|
||||
|
||||
runAmes :: Acquire (EffCb e NewtEf)
|
||||
runAmes :: RAcquire e (EffCb e NewtEf)
|
||||
runAmes = do
|
||||
drv <- mkAcquire start stop
|
||||
pure (io . handleEffect drv)
|
||||
drv <- mkRAcquire start stop
|
||||
pure (handleEffect drv)
|
||||
|
||||
start :: IO AmesDrv
|
||||
start :: RIO e AmesDrv
|
||||
start = do
|
||||
vLiv <- newIORef False
|
||||
time <- async runTimer
|
||||
sock <- bindSock
|
||||
hear <- async (waitPacket sock)
|
||||
pure $ AmesDrv vLiv sock time hear
|
||||
aTurfs <- newTVarIO Nothing
|
||||
aGalaxies <- newIORef mempty
|
||||
aSocket <- bindSock
|
||||
aWakeTimer <- async runTimer
|
||||
aListener <- async (waitPacket aSocket)
|
||||
aSendingQueue <- newTQueueIO
|
||||
aSendingThread <- async (sendingThread aSendingQueue aSocket)
|
||||
pure $ AmesDrv{..}
|
||||
|
||||
netMode :: NetworkMode
|
||||
netMode = Fake
|
||||
netMode = if isFake then Fake else Real
|
||||
|
||||
stop :: AmesDrv -> IO ()
|
||||
stop (AmesDrv{..}) = do
|
||||
stop :: AmesDrv -> RIO e ()
|
||||
stop AmesDrv{..} = do
|
||||
galaxies <- readIORef aGalaxies
|
||||
mapM_ (cancel . fst) galaxies
|
||||
|
||||
cancel aSendingThread
|
||||
cancel aWakeTimer
|
||||
cancel aListener
|
||||
close' aSocket
|
||||
io $ close' aSocket
|
||||
|
||||
runTimer :: IO ()
|
||||
runTimer :: RIO e ()
|
||||
runTimer = forever $ do
|
||||
threadDelay (300 * 1000000) -- 300 seconds
|
||||
atomically (enqueueEv wakeEv)
|
||||
|
||||
bindSock :: IO Socket
|
||||
bindSock :: RIO e Socket
|
||||
bindSock = do
|
||||
let ourPort = maybe (listenPort netMode who) fromIntegral mPort
|
||||
s <- socket AF_INET Datagram defaultProtocol
|
||||
() <- bind s (SockAddrInet ourPort localhost)
|
||||
s <- io $ socket AF_INET Datagram defaultProtocol
|
||||
|
||||
logTrace $ displayShow ("(ames) Binding to port ", ourPort)
|
||||
let addr = SockAddrInet ourPort $
|
||||
if isFake then localhost else inaddrAny
|
||||
() <- io $ bind s addr
|
||||
|
||||
pure s
|
||||
|
||||
waitPacket :: Socket -> IO ()
|
||||
waitPacket :: Socket -> RIO e ()
|
||||
waitPacket s = forever $ do
|
||||
(bs, addr) <- recvFrom s 4096
|
||||
wen <- Time.now
|
||||
(bs, addr) <- io $ recvFrom s 4096
|
||||
logTrace $ displayShow ("(ames) Received packet from ", addr)
|
||||
wen <- io $ Time.now
|
||||
case addr of
|
||||
SockAddrInet p a -> atomically (enqueueEv $ hearEv wen p a bs)
|
||||
_ -> pure ()
|
||||
|
||||
handleEffect :: AmesDrv -> NewtEf -> IO ()
|
||||
handleEffect AmesDrv{..} = \case
|
||||
handleEffect :: AmesDrv -> NewtEf -> RIO e ()
|
||||
handleEffect drv@AmesDrv{..} = \case
|
||||
NewtEfTurf (_id, ()) turfs -> do
|
||||
writeIORef aIsLive True
|
||||
atomically $ writeTVar aTurfs (Just turfs)
|
||||
|
||||
NewtEfSend (_id, ()) dest (MkBytes bs) -> do
|
||||
live <- readIORef aIsLive
|
||||
when live $ do
|
||||
when (netMode == Real || okayFakeAddr dest) $ do
|
||||
void $ sendTo aSocket bs $ destSockAddr netMode dest
|
||||
atomically (readTVar aTurfs) >>= \case
|
||||
Nothing -> pure ()
|
||||
Just turfs -> (sendPacket drv netMode dest bs)
|
||||
|
||||
sendPacket :: AmesDrv -> NetworkMode -> AmesDest -> ByteString -> RIO e ()
|
||||
|
||||
sendPacket AmesDrv{..} Fake dest bs = do
|
||||
when (okayFakeAddr dest) $ do
|
||||
atomically $ writeTQueue aSendingQueue ((fakeSockAddr dest), bs)
|
||||
|
||||
sendPacket AmesDrv{..} Real (ADGala wen galaxy) bs = do
|
||||
galaxies <- readIORef aGalaxies
|
||||
queue <- case M.lookup galaxy galaxies of
|
||||
Just (_, queue) -> pure queue
|
||||
Nothing -> do
|
||||
inQueue <- newTQueueIO
|
||||
thread <- async $ galaxyResolver galaxy aTurfs inQueue aSendingQueue
|
||||
modifyIORef (aGalaxies) (M.insert galaxy (thread, inQueue))
|
||||
pure inQueue
|
||||
|
||||
atomically $ writeTQueue queue bs
|
||||
|
||||
sendPacket AmesDrv{..} Real (ADIpv4 _ p a) bs = do
|
||||
let addr = SockAddrInet (fromIntegral p) (unIpv4 a)
|
||||
atomically $ writeTQueue aSendingQueue (addr, bs)
|
||||
|
||||
-- An outbound queue of messages. We can only write to a socket from one
|
||||
-- thread, so coalesce those writes here.
|
||||
sendingThread :: TQueue (SockAddr, ByteString) -> Socket -> RIO e ()
|
||||
sendingThread queue socket = forever $ do
|
||||
(dest, bs) <- atomically $ readTQueue queue
|
||||
logTrace $ displayShow ("(ames) Sending packet to ", socket, dest)
|
||||
bytesSent <- io $ sendTo socket bs dest
|
||||
let len = BS.length bs
|
||||
when (bytesSent /= len) $ do
|
||||
logDebug $ displayShow
|
||||
("(ames) Only sent ", bytesSent, " of ", (length bs))
|
||||
|
||||
-- Asynchronous thread per galaxy which handles domain resolution, and can
|
||||
-- block its own queue of ByteStrings to send.
|
||||
--
|
||||
-- Maybe perform the resolution asynchronously, injecting into the resolver
|
||||
-- queue as a message.
|
||||
--
|
||||
-- TODO: Figure out how the real haskell time library works.
|
||||
galaxyResolver :: Galaxy -> TVar (Maybe [Turf]) -> TQueue ByteString
|
||||
-> TQueue (SockAddr, ByteString)
|
||||
-> RIO e ()
|
||||
galaxyResolver galaxy turfVar incoming outgoing =
|
||||
loop Nothing Time.unixEpoch
|
||||
where
|
||||
loop :: Maybe SockAddr -> Time.Wen -> RIO e ()
|
||||
loop lastGalaxyIP lastLookupTime = do
|
||||
packet <- atomically $ readTQueue incoming
|
||||
|
||||
checkIP lastGalaxyIP lastLookupTime >>= \case
|
||||
(Nothing, t) -> do
|
||||
-- We've failed to lookup the IP. Drop the outbound packet
|
||||
-- because we have no IP for our galaxy, including possible
|
||||
-- previous IPs.
|
||||
logDebug $ displayShow
|
||||
("(ames) Dropping packet; no ip for galaxy ", galaxy)
|
||||
loop Nothing t
|
||||
(Just ip, t) -> do
|
||||
queueSendToGalaxy ip packet
|
||||
loop (Just ip) t
|
||||
|
||||
checkIP :: Maybe SockAddr -> Time.Wen
|
||||
-> RIO e (Maybe SockAddr, Time.Wen)
|
||||
checkIP lastIP lastLookupTime = do
|
||||
current <- io $ Time.now
|
||||
if (Time.gap current lastLookupTime ^. Time.secs) < 300
|
||||
then pure (lastIP, lastLookupTime)
|
||||
else do
|
||||
toCheck <- fromMaybe [] <$> atomically (readTVar turfVar)
|
||||
mybIp <- resolveFirstIP lastIP toCheck
|
||||
timeAfterResolution <- io $ Time.now
|
||||
pure (mybIp, timeAfterResolution)
|
||||
|
||||
resolveFirstIP :: Maybe SockAddr -> [Turf] -> RIO e (Maybe SockAddr)
|
||||
resolveFirstIP prevIP [] = do
|
||||
-- print ("ames: czar at %s: not found (b)\n")
|
||||
logDebug $ displayShow
|
||||
("(ames) Failed to lookup IP for ", galaxy)
|
||||
pure prevIP
|
||||
|
||||
resolveFirstIP prevIP (x:xs) = do
|
||||
hostname <- buildDNS galaxy x
|
||||
let portstr = show $ galaxyPort Real galaxy
|
||||
listIPs <- io $ getAddrInfo Nothing (Just hostname) (Just portstr)
|
||||
case listIPs of
|
||||
[] -> resolveFirstIP prevIP xs
|
||||
(y:ys) -> do
|
||||
logDebug $ displayShow
|
||||
("(ames) Looked up ", hostname, portstr, y)
|
||||
pure $ Just $ addrAddress y
|
||||
|
||||
buildDNS :: Galaxy -> Turf -> RIO e String
|
||||
buildDNS (Galaxy g) turf = do
|
||||
let nameWithSig = Ob.renderPatp $ Ob.patp $ fromIntegral g
|
||||
name <- case stripPrefix "~" nameWithSig of
|
||||
Nothing -> error "Urbit.ob didn't produce string with ~"
|
||||
Just x -> pure (unpack x)
|
||||
pure $ name ++ "." ++ (unpack $ _turfText turf)
|
||||
|
||||
queueSendToGalaxy :: SockAddr -> ByteString -> RIO e ()
|
||||
queueSendToGalaxy inet packet = do
|
||||
atomically $ writeTQueue outgoing (inet, packet)
|
||||
|
||||
309
pkg/king/lib/Vere/Dawn.hs
Normal file
309
pkg/king/lib/Vere/Dawn.hs
Normal file
@ -0,0 +1,309 @@
|
||||
module Vere.Dawn where
|
||||
|
||||
import Arvo.Common
|
||||
import Arvo.Event hiding (Address)
|
||||
import UrbitPrelude hiding (Call, rights, to)
|
||||
|
||||
import Data.Bits (xor)
|
||||
import Data.List (nub)
|
||||
import Data.Text (splitOn)
|
||||
import Network.Ethereum.Account
|
||||
import Network.Ethereum.Api.Eth
|
||||
import Network.Ethereum.Api.Provider
|
||||
import Network.Ethereum.Api.Types hiding (blockNumber)
|
||||
import Network.Ethereum.Web3
|
||||
import Network.HTTP.Client.TLS
|
||||
|
||||
import qualified Azimuth.Azimuth as AZ
|
||||
import qualified Crypto.Hash.SHA512 as SHA512
|
||||
import qualified Crypto.Sign.Ed25519 as Ed
|
||||
import qualified Data.Binary as B
|
||||
import qualified Data.ByteArray as BA
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Char8 as C
|
||||
import qualified Network.Ethereum.Ens as Ens
|
||||
import qualified Network.HTTP.Client as C
|
||||
import qualified Urbit.Ob as Ob
|
||||
|
||||
-- During boot, use the infura provider
|
||||
provider = HttpProvider
|
||||
"https://mainnet.infura.io/v3/196a7f37c7d54211b4a07904ec73ad87"
|
||||
|
||||
-- Conversion Utilities --------------------------------------------------------
|
||||
|
||||
-- Takes the web3's bytes representation and changes the endianness.
|
||||
bytes32ToBS :: BytesN 32 -> ByteString
|
||||
bytes32ToBS = reverse . BA.pack . BA.unpack
|
||||
|
||||
toBloq :: Quantity -> Bloq
|
||||
toBloq = fromIntegral . unQuantity
|
||||
|
||||
passFromEth :: BytesN 32 -> BytesN 32 -> UIntN 32 -> Pass
|
||||
passFromEth enc aut sut | sut /= 1 =
|
||||
Pass (Ed.PublicKey mempty) (Ed.PublicKey mempty)
|
||||
passFromEth enc aut sut =
|
||||
Pass (decode aut) (decode enc)
|
||||
where
|
||||
decode = Ed.PublicKey . bytes32ToBS
|
||||
|
||||
clanFromShip :: Ship -> Ob.Class
|
||||
clanFromShip = Ob.clan . Ob.patp . fromIntegral
|
||||
|
||||
shipSein :: Ship -> Ship
|
||||
shipSein = Ship . fromIntegral . Ob.fromPatp . Ob.sein . Ob.patp . fromIntegral
|
||||
|
||||
renderShip :: Ship -> Text
|
||||
renderShip = Ob.renderPatp . Ob.patp . fromIntegral
|
||||
|
||||
-- Data Validation -------------------------------------------------------------
|
||||
|
||||
-- for =(who.seed `@`fix:ex:cub)
|
||||
-- getFingerprintFromKey :: Ring -> Atom
|
||||
-- getFingerprintFromKey = undefined
|
||||
|
||||
-- Derive public key structure from the key derivation seed structure
|
||||
getPassFromRing :: Ring -> Pass
|
||||
getPassFromRing Ring{..} = Pass{..}
|
||||
where
|
||||
passCrypt = decode ringCrypt
|
||||
passSign = decode ringSign
|
||||
decode = fst . fromJust . Ed.createKeypairFromSeed_
|
||||
fromJust = \case
|
||||
Nothing -> error "Invalid seed passed to createKeypairFromSeed"
|
||||
Just x -> x
|
||||
|
||||
-- Azimuth Functions -----------------------------------------------------------
|
||||
|
||||
-- Perform a request to azimuth at a certain block number
|
||||
withAzimuth :: Quantity
|
||||
-> Address
|
||||
-> DefaultAccount Web3 a
|
||||
-> Web3 a
|
||||
withAzimuth bloq azimuth action =
|
||||
withAccount () $
|
||||
withParam (to .~ azimuth) $
|
||||
withParam (block .~ BlockWithNumber bloq)
|
||||
action
|
||||
|
||||
-- Retrieves the EthPoint information for an individual point.
|
||||
retrievePoint :: Quantity -> Address -> Ship -> Web3 EthPoint
|
||||
retrievePoint bloq azimuth ship =
|
||||
withAzimuth bloq azimuth $ do
|
||||
(encryptionKey,
|
||||
authenticationKey,
|
||||
hasSponsor,
|
||||
active,
|
||||
escapeRequested,
|
||||
sponsor,
|
||||
escapeTo,
|
||||
cryptoSuite,
|
||||
keyRevision,
|
||||
continuityNum) <- AZ.points (fromIntegral ship)
|
||||
|
||||
let escapeState = if escapeRequested
|
||||
then Just $ Ship $ fromIntegral escapeTo
|
||||
else Nothing
|
||||
|
||||
-- The hoon version also sets this to all 0s and then does nothing with it.
|
||||
let epOwn = (0, 0, 0, 0)
|
||||
|
||||
let epNet = if not active
|
||||
then Nothing
|
||||
else Just
|
||||
( fromIntegral keyRevision
|
||||
, passFromEth encryptionKey authenticationKey cryptoSuite
|
||||
, fromIntegral continuityNum
|
||||
, (hasSponsor, Ship (fromIntegral sponsor))
|
||||
, escapeState
|
||||
)
|
||||
|
||||
-- TODO: wtf?
|
||||
let epKid = case clanFromShip ship of
|
||||
Ob.Galaxy -> Just (0, setToHoonSet mempty)
|
||||
Ob.Star -> Just (0, setToHoonSet mempty)
|
||||
_ -> Nothing
|
||||
|
||||
pure EthPoint{..}
|
||||
|
||||
-- Retrieves information about all the galaxies from Ethereum.
|
||||
retrieveGalaxyTable :: Quantity -> Address -> Web3 (Map Ship (Rift, Life, Pass))
|
||||
retrieveGalaxyTable bloq azimuth =
|
||||
withAzimuth bloq azimuth $ mapFromList <$> mapM getRow [0..255]
|
||||
where
|
||||
getRow idx = do
|
||||
(encryptionKey, authenticationKey, _, _, _, _, _, cryptoSuite,
|
||||
keyRev, continuity) <- AZ.points idx
|
||||
pure ( fromIntegral idx
|
||||
, ( fromIntegral continuity
|
||||
, fromIntegral keyRev
|
||||
, passFromEth encryptionKey authenticationKey cryptoSuite
|
||||
)
|
||||
)
|
||||
|
||||
-- Reads the three Ames domains from Ethereum, removing duplicates
|
||||
readAmesDomains :: Quantity -> Address -> Web3 [Turf]
|
||||
readAmesDomains bloq azimuth =
|
||||
withAzimuth bloq azimuth $ nub <$> mapM getTurf [0..2]
|
||||
where
|
||||
getTurf idx =
|
||||
Turf . fmap Cord . reverse . splitOn "." <$> AZ.dnsDomains idx
|
||||
|
||||
|
||||
validateShipAndGetImmediateSponsor :: Quantity -> Address -> Seed -> Web3 Ship
|
||||
validateShipAndGetImmediateSponsor block azimuth (Seed ship life ring oaf) =
|
||||
case clanFromShip ship of
|
||||
Ob.Comet -> validateComet
|
||||
Ob.Moon -> validateMoon
|
||||
_ -> validateRest
|
||||
where
|
||||
validateComet = do
|
||||
-- TODO: All validation of the comet.
|
||||
-- A comet address is the fingerprint of the keypair
|
||||
-- when (ship /= (x ring.seed)) (Left "todo: key mismatch")
|
||||
-- A comet can never be breached
|
||||
-- when live Left "comet already booted"
|
||||
-- TODO: the parent must be launched check?
|
||||
pure (shipSein ship)
|
||||
|
||||
validateMoon = do
|
||||
-- TODO: The current code in zuse does nothing, but we should be able to
|
||||
-- try to validate the oath against the current as exists planet on
|
||||
-- chain.
|
||||
pure $ shipSein ship
|
||||
|
||||
validateRest = do
|
||||
putStrLn ("boot: retrieving " ++ renderShip ship ++ "'s public keys")
|
||||
|
||||
whoP <- retrievePoint block azimuth ship
|
||||
case epNet whoP of
|
||||
Nothing -> fail "ship not keyed"
|
||||
Just (netLife, pass, contNum, (hasSponsor, who), _) -> do
|
||||
when (netLife /= life) $
|
||||
fail ("keyfile life mismatch; keyfile claims life " ++
|
||||
show life ++ ", but Azimuth claims life " ++
|
||||
show netLife)
|
||||
when ((getPassFromRing ring) /= pass) $
|
||||
fail "keyfile does not match blockchain"
|
||||
-- TODO: The hoon code does a breach check, but the C code never
|
||||
-- supplies the data necessary for it to function.
|
||||
pure who
|
||||
|
||||
|
||||
-- Walk through the sponsorship chain retrieving the actual sponsorship chain
|
||||
-- as it exists on Ethereum.
|
||||
getSponsorshipChain :: Quantity -> Address -> Ship -> Web3 [(Ship,EthPoint)]
|
||||
getSponsorshipChain block azimuth = loop
|
||||
where
|
||||
loop ship = do
|
||||
putStrLn ("boot: retrieving keys for sponsor " ++ renderShip ship)
|
||||
ethPoint <- retrievePoint block azimuth ship
|
||||
|
||||
case (clanFromShip ship, epNet ethPoint) of
|
||||
(Ob.Comet, _) -> fail "Comets cannot be sponsors"
|
||||
(Ob.Moon, _) -> fail "Moons cannot be sponsors"
|
||||
|
||||
(Ob.Galaxy, Nothing) ->
|
||||
fail $ unpack ("Galaxy " ++ renderShip ship ++ " not booted")
|
||||
|
||||
(Ob.Galaxy, Just _) -> pure [(ship, ethPoint)]
|
||||
|
||||
(_, Nothing) ->
|
||||
fail $ unpack ("Ship " ++ renderShip ship ++ " not booted")
|
||||
|
||||
(_, Just (_, _, _, (has, sponsor), _)) -> do
|
||||
case has of
|
||||
False -> fail $ unpack ("Ship " ++ renderShip ship ++
|
||||
" has no sponsor")
|
||||
True -> do
|
||||
chain <- loop sponsor
|
||||
pure $ chain ++ [(ship, ethPoint)]
|
||||
|
||||
|
||||
-- Produces either an error or a validated boot event structure.
|
||||
dawnVent :: Seed -> RIO e (Either Text Dawn)
|
||||
dawnVent dSeed@(Seed ship life ring oaf) = do
|
||||
ret <- runWeb3' provider $ do
|
||||
block <- blockNumber
|
||||
putStrLn ("boot: ethereum block #" ++ tshow block)
|
||||
|
||||
putStrLn "boot: retrieving azimuth contract"
|
||||
azimuth <- withAccount () $ Ens.resolve "azimuth.eth"
|
||||
|
||||
immediateSponsor <- validateShipAndGetImmediateSponsor block azimuth dSeed
|
||||
dSponsor <- getSponsorshipChain block azimuth immediateSponsor
|
||||
|
||||
putStrLn "boot: retrieving galaxy table"
|
||||
dCzar <- mapToHoonMap <$> retrieveGalaxyTable block azimuth
|
||||
|
||||
putStrLn "boot: retrieving network domains"
|
||||
dTurf <- readAmesDomains block azimuth
|
||||
|
||||
let dBloq = toBloq block
|
||||
let dNode = Nothing
|
||||
pure $ MkDawn{..}
|
||||
|
||||
case ret of
|
||||
Left x -> pure $ Left $ tshow x
|
||||
Right y -> pure $ Right y
|
||||
|
||||
|
||||
dawnCometList :: RIO e [Ship]
|
||||
dawnCometList = do
|
||||
-- Get the jamfile with the list of stars accepting comets right now.
|
||||
manager <- io $ C.newManager tlsManagerSettings
|
||||
request <- io $ C.parseRequest "https://bootstrap.urbit.org/comet-stars.jam"
|
||||
response <- io $ C.httpLbs (C.setRequestCheckStatus request) manager
|
||||
let body = toStrict $ C.responseBody response
|
||||
|
||||
noun <- cueBS body & either throwIO pure
|
||||
fromNounErr noun & either (throwIO . uncurry ParseErr) pure
|
||||
|
||||
|
||||
-- Comet Mining ----------------------------------------------------------------
|
||||
|
||||
-- TODO: Comet mining doesn't seem to work and I'm guessing it's because I'm
|
||||
-- screwing up the math below.
|
||||
|
||||
-- TODO: This might be entirely wrong. What happens with a or b is longer?
|
||||
mix :: BS.ByteString -> BS.ByteString -> BS.ByteString
|
||||
mix a b = BS.pack $ BS.zipWith xor a b
|
||||
|
||||
-- TODO: a/b ordering?
|
||||
shaf :: BS.ByteString -> BS.ByteString -> BS.ByteString
|
||||
shaf salt ruz = (mix a b)
|
||||
where
|
||||
haz = shas salt ruz
|
||||
a = (drop 32 haz)
|
||||
b = (take 32 haz)
|
||||
|
||||
shas :: BS.ByteString -> BS.ByteString -> BS.ByteString
|
||||
shas salt ruz =
|
||||
SHA512.hash $ mix salt $ SHA512.hash ruz
|
||||
|
||||
cometFingerprint :: Pass -> Ship -- Word128
|
||||
cometFingerprint = Ship . B.decode . fromStrict . (shas bfig) . passToBS
|
||||
where
|
||||
bfig = C.pack "bfig"
|
||||
|
||||
tryMineComet :: Set Ship -> Word64 -> Maybe Seed
|
||||
tryMineComet ships seed =
|
||||
if member shipSponsor ships
|
||||
then Just $ Seed shipName 1 ring Nothing
|
||||
else Nothing
|
||||
where
|
||||
-- Hash the incoming seed into a 64 bytes.
|
||||
baseHash = SHA512.hash $ toStrict $ B.encode seed
|
||||
signSeed = (take 32 baseHash)
|
||||
ringSeed = (drop 32 baseHash)
|
||||
ring = Ring signSeed ringSeed
|
||||
pass = getPassFromRing ring
|
||||
shipName = cometFingerprint pass
|
||||
shipSponsor = shipSein shipName
|
||||
|
||||
mineComet :: Set Ship -> Word64 -> Seed
|
||||
mineComet ships = loop
|
||||
where
|
||||
loop eny =
|
||||
case (tryMineComet ships eny) of
|
||||
Nothing -> loop (eny + 1)
|
||||
Just x -> x
|
||||
@ -13,9 +13,10 @@ import Vere.Pier.Types
|
||||
|
||||
import Vere.Http
|
||||
|
||||
import qualified Data.Map as M
|
||||
import qualified Network.HTTP.Client as H
|
||||
import qualified Network.HTTP.Types as HT
|
||||
import qualified Data.Map as M
|
||||
import qualified Network.HTTP.Client as H
|
||||
import qualified Network.HTTP.Client.TLS as TLS
|
||||
import qualified Network.HTTP.Types as HT
|
||||
|
||||
-- Types -----------------------------------------------------------------------
|
||||
|
||||
@ -45,18 +46,25 @@ cvtRespHeaders resp =
|
||||
where
|
||||
heads = convertHeaders (H.responseHeaders resp)
|
||||
|
||||
bornEv :: KingId -> Ev
|
||||
bornEv king =
|
||||
EvBlip $ BlipEvHttpClient $ HttpClientEvBorn (king, ()) ()
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
client :: forall e. HasLogFunc e
|
||||
=> KingId -> QueueEv -> ([Ev], RAcquire e (EffCb e HttpClientEf))
|
||||
client kingId enqueueEv = ([], runHttpClient)
|
||||
client kingId enqueueEv = (initialEvents, runHttpClient)
|
||||
where
|
||||
initialEvents :: [Ev]
|
||||
initialEvents = [bornEv kingId]
|
||||
|
||||
runHttpClient :: RAcquire e (EffCb e HttpClientEf)
|
||||
runHttpClient = handleEffect <$> mkRAcquire start stop
|
||||
|
||||
start :: RIO e (HttpClientDrv)
|
||||
start = HttpClientDrv <$>
|
||||
(io $ H.newManager H.defaultManagerSettings) <*>
|
||||
(io $ H.newManager TLS.tlsManagerSettings) <*>
|
||||
newTVarIO M.empty
|
||||
|
||||
stop :: HttpClientDrv -> RIO e ()
|
||||
|
||||
@ -48,18 +48,20 @@ setupPierDirectory shipPath = do
|
||||
genEntropy :: RIO e Word512
|
||||
genEntropy = fromIntegral . view (from atomBytes) <$> io (Ent.getEntropy 64)
|
||||
|
||||
generateBootSeq :: Ship -> Pill -> RIO e BootSeq
|
||||
generateBootSeq ship Pill{..} = do
|
||||
generateBootSeq :: Ship -> Pill -> Bool -> LegacyBootEvent -> RIO e BootSeq
|
||||
generateBootSeq ship Pill{..} lite boot = do
|
||||
ent <- genEntropy
|
||||
let ovums = preKern ent <> pKernelOvums <> pUserspaceOvums
|
||||
pure $ BootSeq ident pBootFormulas ovums
|
||||
where
|
||||
ident = LogIdentity ship True (fromIntegral $ length pBootFormulas)
|
||||
preKern ent =
|
||||
[ EvBlip $ BlipEvArvo $ ArvoEvWhom () ship
|
||||
, EvBlip $ BlipEvArvo $ ArvoEvWack () ent
|
||||
, EvBlip $ BlipEvTerm $ TermEvBoot (1,()) False (Fake (who ident))
|
||||
]
|
||||
ident = LogIdentity ship isFake (fromIntegral $ length pBootFormulas)
|
||||
preKern ent = [ EvBlip $ BlipEvArvo $ ArvoEvWhom () ship
|
||||
, EvBlip $ BlipEvArvo $ ArvoEvWack () ent
|
||||
, EvBlip $ BlipEvTerm $ TermEvBoot (1,()) lite boot
|
||||
]
|
||||
isFake = case boot of
|
||||
Fake _ -> True
|
||||
_ -> False
|
||||
|
||||
|
||||
-- Write a batch of jobs into the event log ------------------------------------
|
||||
@ -84,16 +86,16 @@ writeJobs log !jobs = do
|
||||
-- Boot a new ship. ------------------------------------------------------------
|
||||
|
||||
booted :: HasLogFunc e
|
||||
=> FilePath -> FilePath -> Serf.Flags -> Ship
|
||||
=> FilePath -> FilePath -> Bool -> Serf.Flags -> Ship -> LegacyBootEvent
|
||||
-> RAcquire e (Serf e, EventLog, SerfState)
|
||||
booted pillPath pierPath flags ship = do
|
||||
booted pillPath pierPath lite flags ship boot = do
|
||||
rio $ logTrace "LOADING PILL"
|
||||
|
||||
pill <- io (loadFile pillPath >>= either throwIO pure)
|
||||
|
||||
rio $ logTrace "PILL LOADED"
|
||||
|
||||
seq@(BootSeq ident x y) <- rio $ generateBootSeq ship pill
|
||||
seq@(BootSeq ident x y) <- rio $ generateBootSeq ship pill lite boot
|
||||
|
||||
rio $ logTrace "BootSeq Computed"
|
||||
|
||||
@ -182,10 +184,11 @@ pier pierPath mPort (serf, log, ss) = do
|
||||
|
||||
swapMVar (sStderr serf) (atomically . Term.trace muxed)
|
||||
|
||||
let ship = who (Log.identity log)
|
||||
let logId = Log.identity log
|
||||
let ship = who logId
|
||||
|
||||
let (bootEvents, startDrivers) =
|
||||
drivers pierPath inst ship mPort
|
||||
drivers pierPath inst ship (isFake logId) mPort
|
||||
(writeTQueue computeQ)
|
||||
shutdownEvent
|
||||
(sz, muxed)
|
||||
@ -215,6 +218,9 @@ pier pierPath mPort (serf, log, ss) = do
|
||||
Left (txt, exn) -> logError $ displayShow ("Somthing died", txt, exn)
|
||||
Right tag -> logError $ displayShow ("something simply exited", tag)
|
||||
|
||||
atomically $ (Term.spin muxed) (Just "shutdown")
|
||||
|
||||
|
||||
death :: Text -> Async () -> STM (Either (Text, SomeException) Text)
|
||||
death tag tid = do
|
||||
waitCatchSTM tid <&> \case
|
||||
@ -241,14 +247,15 @@ data Drivers e = Drivers
|
||||
}
|
||||
|
||||
drivers :: HasLogFunc e
|
||||
=> FilePath -> KingId -> Ship -> Maybe Port -> (Ev -> STM ()) -> STM()
|
||||
=> FilePath -> KingId -> Ship -> Bool -> Maybe Port -> (Ev -> STM ())
|
||||
-> STM()
|
||||
-> (TSize.Window Word, Term.Client)
|
||||
-> ([Ev], RAcquire e (Drivers e))
|
||||
drivers pierPath inst who mPort plan shutdownSTM termSys =
|
||||
drivers pierPath inst who isFake mPort plan shutdownSTM termSys =
|
||||
(initialEvents, runDrivers)
|
||||
where
|
||||
(behnBorn, runBehn) = behn inst plan
|
||||
(amesBorn, runAmes) = ames inst who mPort plan
|
||||
(amesBorn, runAmes) = ames inst who isFake mPort plan
|
||||
(httpBorn, runHttp) = serv pierPath inst plan
|
||||
(clayBorn, runClay) = clay pierPath inst plan
|
||||
(irisBorn, runIris) = client inst plan
|
||||
@ -256,7 +263,7 @@ drivers pierPath inst who mPort plan shutdownSTM termSys =
|
||||
initialEvents = mconcat [behnBorn, clayBorn, amesBorn, httpBorn,
|
||||
termBorn, irisBorn]
|
||||
runDrivers = do
|
||||
dNewt <- liftAcquire $ runAmes
|
||||
dNewt <- runAmes
|
||||
dBehn <- liftAcquire $ runBehn
|
||||
dAmes <- pure $ const $ pure ()
|
||||
dHttpClient <- runIris
|
||||
|
||||
@ -49,7 +49,7 @@ deriveNoun ''Pill
|
||||
-- Jobs ------------------------------------------------------------------------
|
||||
|
||||
data Work = Work EventId Mug Wen Ev
|
||||
deriving (Eq, Ord, Show)
|
||||
deriving (Eq, Show)
|
||||
|
||||
data LifeCyc = LifeCyc EventId Mug Nock
|
||||
deriving (Eq, Show)
|
||||
|
||||
@ -421,7 +421,7 @@ bootFromSeq serf (BootSeq ident nocks ovums) = do
|
||||
muckOvum ov eId mug wen = DoWork $ Work eId mug wen ov
|
||||
|
||||
bootMsg = "Booting " ++ (fakeStr (isFake ident)) ++
|
||||
(Ob.render (Ob.patp (fromIntegral (who ident))))
|
||||
(Ob.renderPatp (Ob.patp (fromIntegral (who ident))))
|
||||
fakeStr True = "fake "
|
||||
fakeStr False = ""
|
||||
|
||||
|
||||
@ -37,9 +37,11 @@ dependencies:
|
||||
- classy-prelude
|
||||
- conduit
|
||||
- containers
|
||||
- cryptohash-sha512
|
||||
- data-default
|
||||
- data-fix
|
||||
- directory
|
||||
- ed25519
|
||||
- entropy
|
||||
- exceptions
|
||||
- extra
|
||||
@ -51,6 +53,7 @@ dependencies:
|
||||
- hashable
|
||||
- hashtables
|
||||
- http-client
|
||||
- http-client-tls
|
||||
- http-types
|
||||
- integer-gmp
|
||||
- iproute
|
||||
@ -59,6 +62,7 @@ dependencies:
|
||||
- lmdb
|
||||
- lock-file
|
||||
- megaparsec
|
||||
- memory
|
||||
- mtl
|
||||
- multimap
|
||||
- murmur3
|
||||
@ -103,6 +107,7 @@ dependencies:
|
||||
- wai-conduit
|
||||
- warp
|
||||
- warp-tls
|
||||
- web3
|
||||
- websockets
|
||||
|
||||
default-extensions:
|
||||
|
||||
@ -35,11 +35,13 @@ turfEf = NewtEfTurf (0, ()) []
|
||||
sendEf :: Galaxy -> Wen -> Bytes -> NewtEf
|
||||
sendEf g w bs = NewtEfSend (0, ()) (ADGala w g) bs
|
||||
|
||||
runGala :: Word8 -> RAcquire e (TQueue Ev, EffCb e NewtEf)
|
||||
runGala :: forall e. (HasLogFunc e)
|
||||
=> Word8 -> RAcquire e (TQueue Ev, EffCb e NewtEf)
|
||||
runGala point = do
|
||||
q <- newTQueueIO
|
||||
let (_, runAmes) = ames pid (fromIntegral point) Nothing (writeTQueue q)
|
||||
cb ← liftAcquire runAmes
|
||||
let (_, runAmes) =
|
||||
ames pid (fromIntegral point) True Nothing (writeTQueue q)
|
||||
cb ← runAmes
|
||||
rio $ cb turfEf
|
||||
pure (q, cb)
|
||||
|
||||
@ -66,7 +68,7 @@ sendThread cb (to, val) = void $ mkRAcquire start cancel
|
||||
zodSelfMsg :: Property
|
||||
zodSelfMsg = forAll arbitrary (ioProperty . runApp . runTest)
|
||||
where
|
||||
runTest :: Bytes -> RIO e Bool
|
||||
runTest :: HasLogFunc e => Bytes -> RIO e Bool
|
||||
runTest val = runRAcquire $ do
|
||||
(zodQ, zod) <- runGala 0
|
||||
() <- sendThread zod (0, val)
|
||||
@ -75,13 +77,13 @@ zodSelfMsg = forAll arbitrary (ioProperty . runApp . runTest)
|
||||
twoTalk :: Property
|
||||
twoTalk = forAll arbitrary (ioProperty . runApp . runTest)
|
||||
where
|
||||
runTest :: (Word8, Word8, Bytes) -> RIO e Bool
|
||||
runTest :: HasLogFunc e => (Word8, Word8, Bytes) -> RIO e Bool
|
||||
runTest (aliceShip, bobShip, val) =
|
||||
if aliceShip == bobShip
|
||||
then pure True
|
||||
else go aliceShip bobShip val
|
||||
|
||||
go :: Word8 -> Word8 -> Bytes -> RIO e Bool
|
||||
go :: HasLogFunc e => Word8 -> Word8 -> Bytes -> RIO e Bool
|
||||
go aliceShip bobShip val = runRAcquire $ do
|
||||
(aliceQ, alice) <- runGala aliceShip
|
||||
(bobQ, bob) <- runGala bobShip
|
||||
|
||||
@ -41,7 +41,6 @@ timerFires = forAll arbitrary (ioProperty . runApp . runTest)
|
||||
rwith (liftAcquire $ snd $ behn king (writeTQueue q)) $ \cb -> do
|
||||
cb (BehnEfDoze (king, ()) (Just (2^20)))
|
||||
t <- atomically $ readTQueue q
|
||||
print t
|
||||
pure True
|
||||
|
||||
|
||||
|
||||
@ -2,21 +2,22 @@ module Main (main) where
|
||||
|
||||
import ClassyPrelude
|
||||
|
||||
import RIO.Directory
|
||||
import Test.QuickCheck hiding ((.&.))
|
||||
import Test.Tasty
|
||||
import Test.Tasty.QuickCheck
|
||||
import Test.Tasty.TH
|
||||
import RIO.Directory
|
||||
|
||||
import System.Environment (setEnv)
|
||||
import Control.Concurrent (runInBoundThread)
|
||||
import System.Environment (setEnv)
|
||||
|
||||
import qualified LogTests
|
||||
import qualified DeriveNounTests
|
||||
import qualified ArvoTests
|
||||
import qualified AmesTests
|
||||
import qualified ArvoTests
|
||||
import qualified BehnTests
|
||||
import qualified DeriveNounTests
|
||||
import qualified HoonMapSetTests
|
||||
import qualified LogTests
|
||||
import qualified NounConversionTests
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
@ -28,5 +29,6 @@ main = do
|
||||
, AmesTests.tests
|
||||
, LogTests.tests
|
||||
, BehnTests.tests
|
||||
, NounConversionTests.tests
|
||||
, HoonMapSetTests.tests
|
||||
]
|
||||
|
||||
70
pkg/king/test/NounConversionTests.hs
Normal file
70
pkg/king/test/NounConversionTests.hs
Normal file
@ -0,0 +1,70 @@
|
||||
module NounConversionTests (tests) where
|
||||
|
||||
import Arvo.Event
|
||||
import Noun.Conversions
|
||||
import UrbitPrelude
|
||||
|
||||
import Data.Maybe
|
||||
import Test.QuickCheck hiding ((.&.))
|
||||
import Test.QuickCheck.Gen
|
||||
import Test.QuickCheck.Random
|
||||
import Test.Tasty
|
||||
import Test.Tasty.QuickCheck
|
||||
import Test.Tasty.TH
|
||||
|
||||
import qualified Crypto.Sign.Ed25519 as Ed
|
||||
|
||||
-- String Representations of Atoms ---------------------------------------------
|
||||
|
||||
instance Arbitrary UV where
|
||||
arbitrary = UV <$> arbitrarySizedNatural
|
||||
|
||||
instance Arbitrary UW where
|
||||
arbitrary = UW <$> arbitrarySizedNatural
|
||||
|
||||
vRoundTrip :: UV -> Bool
|
||||
vRoundTrip uv = Just uv == (fromNoun $ toNoun $ uv)
|
||||
|
||||
wRoundTrip :: UW -> Bool
|
||||
wRoundTrip uw = Just uw == (fromNoun $ toNoun uw)
|
||||
|
||||
-- Cryptographic Point Representations -----------------------------------------
|
||||
|
||||
data ThirtyTwoByteString = ThirtyTwoByteString ByteString
|
||||
deriving (Show)
|
||||
|
||||
data KeyPair = KeyPair (Ed.PublicKey, Ed.SecretKey)
|
||||
deriving (Show)
|
||||
|
||||
instance Arbitrary ThirtyTwoByteString where
|
||||
arbitrary = (ThirtyTwoByteString . pack) <$> (vector 32)
|
||||
|
||||
instance Arbitrary KeyPair where
|
||||
arbitrary =
|
||||
(KeyPair . fromJust . Ed.createKeypairFromSeed_ . pack) <$> (vector 32)
|
||||
|
||||
|
||||
passRoundTrip :: KeyPair -> KeyPair -> Bool
|
||||
passRoundTrip (KeyPair (signPubkey, _)) (KeyPair (cryptPubkey, _)) =
|
||||
(Just p) == (fromNoun $ toNoun p)
|
||||
where
|
||||
p = Pass signPubkey cryptPubkey
|
||||
|
||||
|
||||
ringRoundTrip :: ThirtyTwoByteString -> ThirtyTwoByteString -> Bool
|
||||
ringRoundTrip (ThirtyTwoByteString signSeed) (ThirtyTwoByteString cryptSeed) =
|
||||
(Just r) == (fromNoun $ toNoun r)
|
||||
where
|
||||
r = Ring signSeed cryptSeed
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
tests :: TestTree
|
||||
tests =
|
||||
testGroup "Noun"
|
||||
[ testProperty "0v0 printing/parsing round trip" $ vRoundTrip
|
||||
, testProperty "0w0 printing/parsing round trip" $ wRoundTrip
|
||||
, testProperty "Pass round trip" $ passRoundTrip
|
||||
, testProperty "Ring round trip" $ ringRoundTrip
|
||||
]
|
||||
@ -8,7 +8,7 @@ extra-deps:
|
||||
- flat-0.3.4@sha256:002a0e0ae656ea8cc02a772d0bcb6ea7dbd7f2e79070959cc748ad1e7138eb38
|
||||
- base58-bytestring-0.1.0@sha256:a1da72ee89d5450bac1c792d9fcbe95ed7154ab7246f2172b57bd4fd9b5eab79
|
||||
- lock-file-0.7.0.0@sha256:3ad84b5e454145e1d928063b56abb96db24a99a21b493989520e58fa0ab37b00
|
||||
- urbit-hob-0.1.0@sha256:ad893bb71ffcf9500820213c12cfa2544e8757ab143ebb45f9c7cc48c7536e11
|
||||
- urbit-hob-0.3.0@sha256:4871bd8ad01171ae5d4e50a344f4b8757e9eee80f62ab40a80f5311cd443b115
|
||||
|
||||
nix:
|
||||
packages:
|
||||
|
||||
Loading…
Reference in New Issue
Block a user