mirror of
https://github.com/urbit/shrub.git
synced 2024-12-20 09:21:42 +03:00
Merge remote-tracking branch 'origin/master' into release/next-vere
This commit is contained in:
Philip Monk
commit
f7697719fb
@ -155,8 +155,7 @@ let
|
||||
contents = {
|
||||
"${name}/urbit" = "${urbit}/bin/urbit";
|
||||
"${name}/urbit-worker" = "${urbit}/bin/urbit-worker";
|
||||
# temporarily removed for compatibility reasons
|
||||
# "${name}/urbit-king" = "${urbit-king}/bin/urbit-king";
|
||||
"${name}/urbit-king" = "${urbit-king}/bin/urbit-king";
|
||||
};
|
||||
};
|
||||
|
||||
|
||||
@ -12,6 +12,7 @@
|
||||
-}
|
||||
module Urbit.Arvo.Common
|
||||
( KingId(..), ServId(..)
|
||||
, Vere(..), Wynn(..)
|
||||
, Json, JsonNode(..)
|
||||
, Desk(..), Mime(..)
|
||||
, Port(..), Turf(..)
|
||||
@ -21,9 +22,10 @@ module Urbit.Arvo.Common
|
||||
, AmesDest, Ipv4(..), Ipv6(..), Patp(..), Galaxy, AmesAddress(..)
|
||||
) where
|
||||
|
||||
import Urbit.Prelude hiding (Term)
|
||||
import Urbit.Prelude
|
||||
|
||||
import Control.Monad.Fail (fail)
|
||||
import Data.Bits
|
||||
|
||||
import qualified Network.HTTP.Types.Method as H
|
||||
import qualified Urbit.Ob as Ob
|
||||
@ -45,6 +47,25 @@ newtype KingId = KingId { unKingId :: UV }
|
||||
newtype ServId = ServId { unServId :: UV }
|
||||
deriving newtype (Eq, Ord, Show, Num, Enum, Integral, Real, FromNoun, ToNoun)
|
||||
|
||||
-- Arvo Version Negotiation ----------------------------------------------------
|
||||
|
||||
-- Information about the king runtime passed to Arvo.
|
||||
data Vere = Vere { vereName :: Term,
|
||||
vereRev :: [Cord],
|
||||
vereWynn :: Wynn }
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
instance ToNoun Vere where
|
||||
toNoun Vere{..} = toNoun ((vereName, vereRev), vereWynn)
|
||||
|
||||
instance FromNoun Vere where
|
||||
parseNoun n = named "Vere" $ do
|
||||
((vereName, vereRev), vereWynn) <- parseNoun n
|
||||
pure $ Vere {..}
|
||||
|
||||
-- A list of names and their kelvin numbers, used in version negotiations.
|
||||
newtype Wynn = Wynn { unWynn :: [(Term, Word)] }
|
||||
deriving newtype (Eq, Ord, Show, FromNoun, ToNoun)
|
||||
|
||||
-- Http Common -----------------------------------------------------------------
|
||||
|
||||
@ -112,7 +133,7 @@ deriveNoun ''HttpServerConf
|
||||
-- Desk and Mime ---------------------------------------------------------------
|
||||
|
||||
newtype Desk = Desk { unDesk :: Cord }
|
||||
deriving newtype (Eq, Ord, Show, ToNoun, FromNoun)
|
||||
deriving newtype (Eq, Ord, Show, ToNoun, FromNoun, IsString)
|
||||
|
||||
data Mime = Mime Path File
|
||||
deriving (Eq, Ord, Show)
|
||||
@ -146,7 +167,14 @@ newtype Port = Port { unPort :: Word16 }
|
||||
|
||||
-- @if
|
||||
newtype Ipv4 = Ipv4 { unIpv4 :: Word32 }
|
||||
deriving newtype (Eq, Ord, Show, Enum, Real, Integral, Num, ToNoun, FromNoun)
|
||||
deriving newtype (Eq, Ord, Enum, Real, Integral, Num, ToNoun, FromNoun)
|
||||
|
||||
instance Show Ipv4 where
|
||||
show (Ipv4 i) =
|
||||
show ((shiftL i 24) .&. 0xff) ++ "." ++
|
||||
show ((shiftL i 16) .&. 0xff) ++ "." ++
|
||||
show ((shiftL i 8) .&. 0xff) ++ "." ++
|
||||
show (i .&. 0xff)
|
||||
|
||||
-- @is
|
||||
newtype Ipv6 = Ipv6 { unIpv6 :: Word128 }
|
||||
|
||||
@ -18,7 +18,7 @@ import Urbit.Arvo.Common (KingId(..), ServId(..))
|
||||
import Urbit.Arvo.Common (Header, HttpEvent, HttpServerConf, Method, Mime)
|
||||
import Urbit.Arvo.Common (AmesDest, Turf)
|
||||
import Urbit.Arvo.Common (ReOrg(..), reorgThroughNoun)
|
||||
import Urbit.Arvo.Common (Desk)
|
||||
import Urbit.Arvo.Common (Desk, Wynn)
|
||||
|
||||
|
||||
-- Newt Effects ----------------------------------------------------------------
|
||||
@ -259,20 +259,32 @@ data Ef
|
||||
= EfVane VaneEf
|
||||
| EfVega Cord EvilPath -- second path component, rest of path
|
||||
| EfExit Cord EvilPath -- second path component, rest of path
|
||||
| EfWend Wynn
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
-- XX HACK
|
||||
clip :: Noun -> Noun
|
||||
clip (C (C _ x) y) = C x y
|
||||
clip _ = error "misclip"
|
||||
|
||||
tack :: Noun -> Noun
|
||||
tack (C x y) = C (C (A 0) x) y
|
||||
tack _ = error "mistack"
|
||||
|
||||
instance ToNoun Ef where
|
||||
toNoun = \case
|
||||
toNoun = clip . \case
|
||||
EfVane v -> toNoun $ reorgThroughNoun ("", v)
|
||||
EfExit s p -> toNoun $ ReOrg "" s "exit" p (A 0)
|
||||
EfVega s p -> toNoun $ ReOrg "" s "vega" p (A 0)
|
||||
EfWend w -> toNoun $ reorgThroughNoun ("", w)
|
||||
|
||||
instance FromNoun Ef where
|
||||
parseNoun = parseNoun >=> \case
|
||||
parseNoun = tack >>> parseNoun >=> \case
|
||||
ReOrg "" s "exit" p (A 0) -> pure (EfExit s p)
|
||||
ReOrg "" s "exit" p _ -> fail "%exit effect expects nil value"
|
||||
ReOrg "" s "vega" p (A 0) -> pure (EfVega s p)
|
||||
ReOrg "" s "vega" p _ -> fail "%vega effect expects nil value"
|
||||
ReOrg "" s "wend" p val -> EfWend <$> parseNoun val
|
||||
ReOrg "" s tag p val -> EfVane <$> parseNoun (toNoun (s, tag, p, val))
|
||||
ReOrg _ _ _ _ _ -> fail "Non-empty first path-element"
|
||||
|
||||
|
||||
@ -9,10 +9,10 @@
|
||||
-}
|
||||
module Urbit.Arvo.Event where
|
||||
|
||||
import Urbit.Prelude hiding (Term)
|
||||
import Urbit.Prelude
|
||||
|
||||
import Control.Monad.Fail (fail)
|
||||
import Urbit.Arvo.Common (KingId(..), ServId(..))
|
||||
import Urbit.Arvo.Common (KingId(..), ServId(..), Vere(..))
|
||||
import Urbit.Arvo.Common (Desk, Mime)
|
||||
import Urbit.Arvo.Common (Header(..), HttpEvent)
|
||||
import Urbit.Arvo.Common (AmesDest, Ipv4, Ipv6, Port, Turf)
|
||||
@ -218,9 +218,12 @@ instance Show Entropy where
|
||||
data ArvoEv
|
||||
= ArvoEvWhom () Ship
|
||||
| ArvoEvWack () Entropy
|
||||
| ArvoEvWarn Path Noun
|
||||
| ArvoEvWyrd () Vere
|
||||
| ArvoEvCrud Path Noun
|
||||
| ArvoEvVeer Atom Noun
|
||||
| ArvoEvTrim UD
|
||||
| ArvoEvWhat [Noun]
|
||||
| ArvoEvWhey ()
|
||||
| ArvoEvVerb (Maybe Bool)
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
deriveNoun ''ArvoEv
|
||||
@ -318,50 +321,29 @@ data BlipEv
|
||||
deriveNoun ''BlipEv
|
||||
|
||||
|
||||
-- Boot Events -----------------------------------------------------------------
|
||||
|
||||
data Vane
|
||||
= VaneVane VaneEv
|
||||
| VaneZuse ZuseEv
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
data VaneName
|
||||
= Ames | Behn | Clay | Dill | Eyre | Ford | Gall | Iris | Jael
|
||||
deriving (Eq, Ord, Show, Enum, Bounded)
|
||||
|
||||
data ZuseEv
|
||||
= ZEVeer () Cord Path BigCord
|
||||
| ZEVoid Void
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
data VaneEv
|
||||
= VEVeer (VaneName, ()) Cord Path BigCord
|
||||
| VEVoid Void
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
deriveNoun ''Vane
|
||||
deriveNoun ''VaneName
|
||||
deriveNoun ''VaneEv
|
||||
deriveNoun ''ZuseEv
|
||||
|
||||
|
||||
-- The Main Event Type ---------------------------------------------------------
|
||||
|
||||
data Ev
|
||||
= EvBlip BlipEv
|
||||
| EvVane Vane
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance ToNoun Ev where
|
||||
toNoun = \case
|
||||
EvBlip v -> toNoun $ reorgThroughNoun (Cord "", v)
|
||||
EvVane v -> toNoun $ reorgThroughNoun (Cord "vane", v)
|
||||
toNoun = toNoun . \case
|
||||
EvBlip v@BlipEvAmes{} -> reorgThroughNoun ("ames", v)
|
||||
EvBlip v@BlipEvArvo{} -> reorgThroughNoun ("", v)
|
||||
EvBlip v@BlipEvBehn{} -> reorgThroughNoun ("behn", v)
|
||||
EvBlip v@BlipEvBoat{} -> reorgThroughNoun ("clay", v)
|
||||
EvBlip v@BlipEvHttpClient{} -> reorgThroughNoun ("iris", v)
|
||||
EvBlip v@BlipEvHttpServer{} -> reorgThroughNoun ("eyre", v)
|
||||
EvBlip v@BlipEvNewt{} -> reorgThroughNoun ("ames", v)
|
||||
EvBlip v@BlipEvSync{} -> reorgThroughNoun ("clay", v)
|
||||
EvBlip v@BlipEvTerm{} -> reorgThroughNoun ("dill", v)
|
||||
|
||||
-- XX We really should check the first path element, but since this is used only
|
||||
-- in the event browser, which otherwise is broken, I don't care right now.
|
||||
instance FromNoun Ev where
|
||||
parseNoun = parseNoun >=> \case
|
||||
ReOrg "" s t p v -> fmap EvBlip $ parseNoun $ toNoun (s,t,p,v)
|
||||
ReOrg "vane" s t p v -> fmap EvVane $ parseNoun $ toNoun (s,t,p,v)
|
||||
ReOrg _ _ _ _ _ -> fail "First path-elem must be ?($ %vane)"
|
||||
ReOrg _ s t p v -> fmap EvBlip $ parseNoun $ toNoun (s,t,p,v)
|
||||
|
||||
|
||||
-- Short Event Names -----------------------------------------------------------
|
||||
@ -373,7 +355,6 @@ instance FromNoun Ev where
|
||||
-}
|
||||
getSpinnerNameForEvent :: Ev -> Maybe Text
|
||||
getSpinnerNameForEvent = \case
|
||||
EvVane _ -> Nothing
|
||||
EvBlip b -> case b of
|
||||
BlipEvAmes _ -> Just "ames"
|
||||
BlipEvArvo _ -> Just "arvo"
|
||||
|
||||
@ -4,6 +4,7 @@
|
||||
module Urbit.King.App
|
||||
( KingEnv
|
||||
, runKingEnvStderr
|
||||
, runKingEnvStderrRaw
|
||||
, runKingEnvLogFile
|
||||
, runKingEnvNoLog
|
||||
, kingEnvKillSignal
|
||||
@ -29,6 +30,7 @@ where
|
||||
import Urbit.King.Config
|
||||
import Urbit.Prelude
|
||||
|
||||
import RIO (logGeneric)
|
||||
import System.Directory ( createDirectoryIfMissing
|
||||
, getXdgDirectory
|
||||
, XdgDirectory(XdgCache)
|
||||
@ -90,6 +92,22 @@ runKingEnvStderr verb lvl inner = do
|
||||
<&> setLogMinLevel lvl
|
||||
withLogFunc logOptions $ \logFunc -> runKingEnv logFunc logFunc inner
|
||||
|
||||
runKingEnvStderrRaw :: Bool -> LogLevel -> RIO KingEnv a -> IO a
|
||||
runKingEnvStderrRaw verb lvl inner = do
|
||||
logOptions <-
|
||||
logOptionsHandle stderr verb
|
||||
<&> setLogUseTime True
|
||||
<&> setLogUseLoc False
|
||||
<&> setLogMinLevel lvl
|
||||
withLogFunc logOptions $ \logFunc ->
|
||||
let lf = wrapCarriage logFunc
|
||||
in runKingEnv lf lf inner
|
||||
|
||||
-- XX loses callstack
|
||||
wrapCarriage :: LogFunc -> LogFunc
|
||||
wrapCarriage lf = mkLogFunc $ \_ ls ll bldr ->
|
||||
runRIO lf $ logGeneric ls ll (bldr <> "\r")
|
||||
|
||||
runKingEnvLogFile :: Bool -> LogLevel -> Maybe FilePath -> RIO KingEnv a -> IO a
|
||||
runKingEnvLogFile verb lvl fileM inner = do
|
||||
logFile <- case fileM of
|
||||
|
||||
@ -382,7 +382,7 @@ replayPartEvs top last = do
|
||||
{-|
|
||||
Interesting
|
||||
-}
|
||||
testPill :: HasLogFunc e => FilePath -> Bool -> Bool -> RIO e ()
|
||||
testPill :: HasKingEnv e => FilePath -> Bool -> Bool -> RIO e ()
|
||||
testPill pax showPil showSeq = do
|
||||
logInfo "Reading pill file."
|
||||
pillBytes <- readFile pax
|
||||
@ -678,10 +678,13 @@ main = do
|
||||
runKingEnv args log =
|
||||
let
|
||||
verb = verboseLogging args
|
||||
runStderr = case args of
|
||||
CLI.CmdRun {} -> runKingEnvStderrRaw
|
||||
_ -> runKingEnvStderr
|
||||
CLI.Log {..} = log
|
||||
in case logTarget lTarget args of
|
||||
CLI.LogFile f -> runKingEnvLogFile verb lLevel f
|
||||
CLI.LogStderr -> runKingEnvStderr verb lLevel
|
||||
CLI.LogStderr -> runStderr verb lLevel
|
||||
CLI.LogOff -> runKingEnvNoLog
|
||||
|
||||
setupSignalHandlers = do
|
||||
|
||||
@ -2,30 +2,32 @@
|
||||
Scry helpers
|
||||
-}
|
||||
|
||||
module Urbit.King.Scry (scryNow) where
|
||||
module Urbit.King.Scry
|
||||
( scryNow
|
||||
, module Urbit.Vere.Pier.Types
|
||||
)
|
||||
where
|
||||
|
||||
import Urbit.Prelude
|
||||
import Urbit.Vere.Serf.Types
|
||||
|
||||
import qualified Urbit.Noun.Time as Time
|
||||
import Urbit.Arvo.Common (Desk)
|
||||
import Urbit.Vere.Pier.Types (ScryFunc)
|
||||
|
||||
scryNow :: forall e n
|
||||
. (HasLogFunc e, FromNoun n)
|
||||
=> (Time.Wen -> Gang -> Path -> IO (Maybe (Term, Noun)))
|
||||
-> Text -- ^ vane + care as two-letter string
|
||||
-> Ship -- ^ ship in scry path, usually the local ship
|
||||
-> Text -- ^ desk in scry path
|
||||
=> ScryFunc
|
||||
-> Term -- ^ vane + care as two-letter string
|
||||
-> Desk -- ^ desk in scry path
|
||||
-> [Text] -- ^ resource path to scry for
|
||||
-> RIO e (Maybe n)
|
||||
scryNow scry vare ship desk path = do
|
||||
env <- ask
|
||||
wen <- io Time.now
|
||||
let wan = tshow $ Time.MkDate wen
|
||||
let pax = Path $ fmap MkKnot $ vare : (tshow ship) : desk : wan : path
|
||||
io (scry wen Nothing pax) >>= \case
|
||||
Just (_, fromNoun @n -> Just v) -> pure $ Just v
|
||||
Just (_, n) -> do
|
||||
logError $ displayShow ("uncanny scry result", vare, pax, n)
|
||||
pure Nothing
|
||||
Nothing -> pure Nothing
|
||||
scryNow scry vare desk path =
|
||||
io (scry Nothing (EachNo $ DemiOnce vare desk (Path $ MkKnot <$> path)))
|
||||
>>= \case
|
||||
Just ("omen", fromNoun @(Path, Term, n) -> Just (_,_,v)) -> pure $ Just v
|
||||
Just (_, fromNoun @n -> Just v) -> pure $ Just v
|
||||
Just (_, n) -> do
|
||||
logError $ displayShow ("uncanny scry result", vare, path, n)
|
||||
pure Nothing
|
||||
Nothing -> pure Nothing
|
||||
|
||||
|
||||
@ -26,8 +26,6 @@ import Urbit.Vere.Ames.DNS (galaxyPort, resolvServ)
|
||||
import Urbit.Vere.Ames.UDP (UdpServ(..), fakeUdpServ, realUdpServ)
|
||||
import Urbit.Vere.Stat (AmesStat(..), bump, bump')
|
||||
|
||||
import qualified Urbit.Noun.Time as Time
|
||||
|
||||
|
||||
-- Constants -------------------------------------------------------------------
|
||||
|
||||
@ -143,7 +141,7 @@ ames'
|
||||
=> Ship
|
||||
-> Bool
|
||||
-> AmesStat
|
||||
-> (Time.Wen -> Gang -> Path -> IO (Maybe (Term, Noun)))
|
||||
-> ScryFunc
|
||||
-> (Text -> RIO e ())
|
||||
-> RIO e ([Ev], RAcquire e (DriverApi NewtEf))
|
||||
ames' who isFake stat scry stderr = do
|
||||
@ -198,7 +196,7 @@ ames
|
||||
-> Ship
|
||||
-> Bool
|
||||
-> AmesStat
|
||||
-> (Time.Wen -> Gang -> Path -> IO (Maybe (Term, Noun)))
|
||||
-> ScryFunc
|
||||
-> (EvErr -> STM PacketOutcome)
|
||||
-> (Text -> RIO e ())
|
||||
-> ([Ev], RAcquire e (NewtEf -> IO ()))
|
||||
@ -269,7 +267,6 @@ ames env who isFake stat scry enqueueEv stderr = (initialEvents, runAmes)
|
||||
-- port number, host address, bytestring
|
||||
(p, a, b) <- atomically (bump' asRcv >> usRecv)
|
||||
ver <- readTVarIO vers
|
||||
|
||||
case decode b of
|
||||
Right (pkt@Packet {..}) | ver == Nothing || ver == Just pktVersion -> do
|
||||
logDebug $ displayShow ("ames: bon packet", pkt, showUD $ bytesAtom b)
|
||||
@ -284,7 +281,8 @@ ames env who isFake stat scry enqueueEv stderr = (initialEvents, runAmes)
|
||||
-> do
|
||||
bump asFwd
|
||||
forward dest $ encode pkt
|
||||
{ pktOrigin = pktOrigin <|> Just (ipDest p a) }
|
||||
{ pktOrigin = pktOrigin
|
||||
<|> Just (AAIpv4 (Ipv4 a) (fromIntegral p)) }
|
||||
where
|
||||
notSelf (EachYes g) = who /= Ship (fromIntegral g)
|
||||
notSelf (EachNo _) = True
|
||||
@ -362,12 +360,12 @@ ames env who isFake stat scry enqueueEv stderr = (initialEvents, runAmes)
|
||||
EachNo addr -> to (ipv4Addr addr)
|
||||
|
||||
scryVersion :: HasLogFunc e => RIO e (Maybe Version)
|
||||
scryVersion = scryNow scry "ax" who "" ["protocol", "version"]
|
||||
scryVersion = scryNow scry "ax" "" ["protocol", "version"]
|
||||
|
||||
scryLane :: HasLogFunc e
|
||||
=> Ship
|
||||
-> RIO e (Maybe [AmesDest])
|
||||
scryLane ship = scryNow scry "ax" who "" ["peers", tshow ship, "forward-lane"]
|
||||
scryLane ship = scryNow scry "ax" "" ["peers", tshow ship, "forward-lane"]
|
||||
|
||||
ipv4Addr (Jammed (AAVoid v )) = absurd v
|
||||
ipv4Addr (Jammed (AAIpv4 a p)) = SockAddrInet (fromIntegral p) (unIpv4 a)
|
||||
|
||||
@ -9,18 +9,19 @@ import Urbit.Prelude
|
||||
import Control.Monad.Fail
|
||||
import Data.Bits
|
||||
import Data.LargeWord
|
||||
import Data.List (genericIndex)
|
||||
import Data.Serialize
|
||||
|
||||
import Urbit.Arvo (AmesDest)
|
||||
import Urbit.Arvo (AmesAddress(..), Ipv4(..), Port(..))
|
||||
|
||||
data Packet = Packet
|
||||
{ pktVersion :: Word8
|
||||
, pktEncrypted :: Bool
|
||||
--
|
||||
, pktSndr :: Ship
|
||||
, pktRcvr :: Ship
|
||||
, pktOrigin :: Maybe AmesDest
|
||||
, pktContent :: Bytes
|
||||
{ pktVersion :: Word3
|
||||
, pktSndr :: Ship
|
||||
, pktRcvr :: Ship
|
||||
, pktSndrTick :: Word4
|
||||
, pktRcvrTick :: Word4
|
||||
, pktOrigin :: Maybe AmesAddress
|
||||
, pktContent :: ByteString
|
||||
}
|
||||
deriving Eq
|
||||
|
||||
@ -28,73 +29,140 @@ instance Show Packet where
|
||||
show Packet {..}
|
||||
= "Packet {pktVersion = "
|
||||
<> show pktVersion
|
||||
<> ", pktEncrypted = "
|
||||
<> show pktEncrypted
|
||||
<> ", pktSndr = "
|
||||
<> show pktSndr
|
||||
<> ", pktRcvr = "
|
||||
<> show pktRcvr
|
||||
<> ", pktSndrTick = "
|
||||
<> show pktSndrTick
|
||||
<> ", pktRcvrTick = "
|
||||
<> show pktRcvrTick
|
||||
<> ", pktOrigin = "
|
||||
<> show pktOrigin
|
||||
<> ", pktContent = "
|
||||
<> showUD (bytesAtom $ unBytes pktContent)
|
||||
<> showUD (bytesAtom pktContent)
|
||||
<> "}"
|
||||
|
||||
{-
|
||||
-- Wire format
|
||||
data PacketHeader = PacketHeader
|
||||
{ pktIsAmes :: Bool -- sim_o
|
||||
, pktVersion :: Word3 -- ver_y
|
||||
, pktSndrClass :: ShipClass -- sac_y
|
||||
, pktRcvrClass :: ShipClass -- rac_y
|
||||
, pktChecksum :: Word20 -- mug_l
|
||||
, pktIsRelayed :: Bool -- rel_o
|
||||
}
|
||||
deriving Eq
|
||||
|
||||
data PacketBody = PacketBody
|
||||
{ pktSndr :: Ship -- sen_d
|
||||
, pktRcvr :: Ship -- rec_d
|
||||
, pktSndrTick :: Word4 -- sic_y
|
||||
, pktRcvrTick :: Word4 -- ric_y
|
||||
, pktContent :: ByteString -- (con_s, con_y)
|
||||
, pktOrigin :: Maybe AmesAddress -- rog_d
|
||||
}
|
||||
deriving Eq
|
||||
-}
|
||||
|
||||
type Word3 = Word8
|
||||
type Word4 = Word8
|
||||
type Word20 = Word32
|
||||
|
||||
data ShipClass
|
||||
= Lord
|
||||
| Planet
|
||||
| Moon
|
||||
| Comet
|
||||
deriving (Eq, Show)
|
||||
|
||||
muk :: ByteString -> Word20
|
||||
muk bs = mugBS bs .&. (2 ^ 20 - 1)
|
||||
|
||||
-- XX check this
|
||||
getAmesAddress :: Get AmesAddress
|
||||
getAmesAddress = AAIpv4 <$> (Ipv4 <$> getWord32le) <*> (Port <$> getWord16le)
|
||||
|
||||
putAmesAddress :: Putter AmesAddress
|
||||
putAmesAddress = \case
|
||||
AAIpv4 (Ipv4 ip) (Port port) -> putWord32le ip >> putWord16le port
|
||||
|
||||
instance Serialize Packet where
|
||||
get = do
|
||||
-- header
|
||||
head <- getWord32le
|
||||
let pktVersion = head .&. 0b111 & fromIntegral
|
||||
let checksum = shiftR head 3 .&. (2 ^ 20 - 1)
|
||||
let sndrRank = shiftR head 23 .&. 0b11
|
||||
let rcvrRank = shiftR head 25 .&. 0b11
|
||||
let pktEncrypted = testBit head 27 & not -- loobean
|
||||
-- verify checksum
|
||||
-- skip first three bits
|
||||
let isAmes = testBit head 3 & not
|
||||
let pktVersion = shiftR head 4 .&. 0b111 & fromIntegral
|
||||
let sndrRank = shiftR head 7 .&. 0b11
|
||||
let rcvrRank = shiftR head 9 .&. 0b11
|
||||
let checksum = shiftR head 11 .&. (2 ^ 20 - 1)
|
||||
let isRelayed = testBit head 31 & not -- loobean
|
||||
let sndrClass = genericIndex [Lord, Planet, Moon, Comet] sndrRank
|
||||
let rcvrClass = genericIndex [Lord, Planet, Moon, Comet] rcvrRank
|
||||
guard isAmes
|
||||
|
||||
pktOrigin <- if isRelayed
|
||||
then Just <$> getAmesAddress
|
||||
else pure Nothing
|
||||
|
||||
-- body
|
||||
lookAhead $ do
|
||||
len <- remaining
|
||||
len <- remaining
|
||||
body <- getBytes len
|
||||
let chk = fromIntegral (mugBS body) .&. (2 ^ 20 - 1)
|
||||
let chk = muk body
|
||||
when (checksum /= chk) $
|
||||
fail ("checksum mismatch: expected " <> show checksum
|
||||
<> "; got " <> show chk)
|
||||
-- body
|
||||
pktSndr <- getShip sndrRank
|
||||
pktRcvr <- getShip rcvrRank
|
||||
len <- remaining
|
||||
payload <- getBytes len
|
||||
-- data ("payload")
|
||||
(pktOrigin, pktContent) <- case cueBS payload of
|
||||
Left e -> fail (show e)
|
||||
Right n -> case fromNounErr n of
|
||||
Left e -> fail (show e)
|
||||
Right c -> pure c
|
||||
pure Packet {..}
|
||||
|
||||
tick <- getWord8
|
||||
let pktSndrTick = tick .&. 0b1111
|
||||
let pktRcvrTick = shiftR tick 4
|
||||
|
||||
pktSndr <- getShip sndrClass
|
||||
pktRcvr <- getShip rcvrClass
|
||||
|
||||
len <- remaining
|
||||
pktContent <- getBytes len
|
||||
|
||||
pure Packet{..}
|
||||
where
|
||||
getShip = fmap Ship . \case
|
||||
0 -> fromIntegral <$> getWord16le -- galaxy / star
|
||||
1 -> fromIntegral <$> getWord32le -- planet
|
||||
2 -> fromIntegral <$> getWord64le -- moon
|
||||
3 -> LargeKey <$> getWord64le <*> getWord64le -- comet
|
||||
_ -> fail "impossibiru"
|
||||
Lord -> fromIntegral <$> getWord16le
|
||||
Planet -> fromIntegral <$> getWord32le
|
||||
Moon -> fromIntegral <$> getWord64le
|
||||
Comet -> LargeKey <$> getWord64le <*> getWord64le
|
||||
|
||||
put Packet {..} = do
|
||||
let load = jamBS $ toNoun (pktOrigin, pktContent)
|
||||
put Packet{..} = do
|
||||
let (sndR, putSndr) = putShipGetRank pktSndr
|
||||
let (rcvR, putRcvr) = putShipGetRank pktRcvr
|
||||
let body = runPut (putSndr <> putRcvr <> putByteString load)
|
||||
let chek = fromIntegral (mugBS body) .&. (2 ^ 20 - 1)
|
||||
let encr = pktEncrypted
|
||||
|
||||
let body = runPut $ do
|
||||
putWord8 $ (pktSndrTick .&. 0b1111)
|
||||
.|. shiftL (pktRcvrTick .&. 0b1111) 4
|
||||
putSndr
|
||||
putRcvr
|
||||
putByteString pktContent
|
||||
|
||||
let vers = fromIntegral pktVersion .&. 0b111
|
||||
let head = vers
|
||||
.|. shiftL chek 3
|
||||
.|. shiftL sndR 23
|
||||
.|. shiftL rcvR 25
|
||||
.|. if encr then 0 else bit 27
|
||||
let chek = muk body
|
||||
|
||||
-- skip first 3 bytes, set 4th to yes (0) for "is ames"
|
||||
let head = shiftL vers 4
|
||||
.|. shiftL sndR 7
|
||||
.|. shiftL rcvR 9
|
||||
.|. shiftL chek 11
|
||||
.|. if isJust pktOrigin then 0 else bit 31
|
||||
|
||||
putWord32le head
|
||||
putByteString body -- XX can we avoid copy?
|
||||
case pktOrigin of
|
||||
Just o -> putAmesAddress o
|
||||
Nothing -> pure ()
|
||||
putByteString body
|
||||
where
|
||||
putShipGetRank s@(Ship (LargeKey p q)) = case () of
|
||||
_ | s < 2 ^ 16 -> (0, putWord16le $ fromIntegral s) -- gar
|
||||
| s < 2 ^ 32 -> (1, putWord32le $ fromIntegral s) -- pan
|
||||
| s < 2 ^ 64 -> (2, putWord64le $ fromIntegral s) -- mon
|
||||
| otherwise -> (3, putWord64le p >> putWord64le q) -- com
|
||||
_ | s < 2 ^ 16 -> (0, putWord16le $ fromIntegral s) -- lord
|
||||
| s < 2 ^ 32 -> (1, putWord32le $ fromIntegral s) -- planet
|
||||
| s < 2 ^ 64 -> (2, putWord64le $ fromIntegral s) -- moon
|
||||
| otherwise -> (3, putWord64le p >> putWord64le q) -- comet
|
||||
|
||||
@ -10,7 +10,7 @@ module Urbit.Vere.Behn (behn, DriverApi(..), behn') where
|
||||
|
||||
import Data.Time.Clock.System (SystemTime)
|
||||
|
||||
import Urbit.Arvo hiding (Behn)
|
||||
import Urbit.Arvo
|
||||
import Urbit.Prelude
|
||||
import Urbit.Vere.Pier.Types
|
||||
|
||||
|
||||
@ -13,7 +13,6 @@ import Urbit.Prelude hiding (Builder)
|
||||
|
||||
import Data.ByteString.Builder
|
||||
import Urbit.King.Scry
|
||||
import Urbit.Vere.Serf.Types
|
||||
|
||||
import Data.Conduit (ConduitT, Flush(..), yield)
|
||||
import Data.Text.Encoding (encodeUtf8Builder)
|
||||
@ -23,7 +22,6 @@ import qualified Data.Text.Encoding as E
|
||||
import qualified Network.HTTP.Types as H
|
||||
import qualified Network.Wai as W
|
||||
import qualified Network.Wai.Conduit as W
|
||||
import qualified Urbit.Noun.Time as Time
|
||||
|
||||
newtype KingSubsite = KS { runKingSubsite :: W.Application }
|
||||
|
||||
@ -44,7 +42,7 @@ streamSlog a = do
|
||||
|
||||
kingSubsite :: HasLogFunc e
|
||||
=> Ship
|
||||
-> (Time.Wen -> Gang -> Path -> IO (Maybe (Term, Noun)))
|
||||
-> ScryFunc
|
||||
-> IO RenderedStat
|
||||
-> TVar ((Atom, Tank) -> IO ())
|
||||
-> RAcquire e KingSubsite
|
||||
@ -118,7 +116,7 @@ kingSubsite who scry stat func = do
|
||||
=> Text
|
||||
-> RIO e (Maybe Bool)
|
||||
scryAuth cookie =
|
||||
scryNow scry "ex" who "" ["authenticated", "cookie", textAsTa cookie]
|
||||
scryNow scry "ex" "" ["authenticated", "cookie", textAsTa cookie]
|
||||
|
||||
fourOhFourSubsite :: Ship -> KingSubsite
|
||||
fourOhFourSubsite who = KS $ \req respond ->
|
||||
|
||||
@ -32,11 +32,11 @@ import System.Posix.Files (ownerModes, setFileMode)
|
||||
import Urbit.EventLog.LMDB (EventLog)
|
||||
import Urbit.EventLog.Event (buildLogEvent)
|
||||
import Urbit.King.API (TermConn)
|
||||
import Urbit.Noun.Time (Wen)
|
||||
import Urbit.TermSize (TermSize(..), termSize)
|
||||
import Urbit.Vere.Serf (Serf)
|
||||
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.List as L
|
||||
import qualified System.Entropy as Ent
|
||||
import qualified Urbit.EventLog.LMDB as Log
|
||||
import qualified Urbit.King.API as King
|
||||
@ -72,16 +72,22 @@ setupPierDirectory shipPath = do
|
||||
|
||||
-- Load pill into boot sequence. -----------------------------------------------
|
||||
|
||||
data CannotBootFromIvoryPill = CannotBootFromIvoryPill
|
||||
deriving (Show, Exception)
|
||||
|
||||
genEntropy :: MonadIO m => m Entropy
|
||||
genEntropy = Entropy . fromIntegral . bytesAtom <$> io (Ent.getEntropy 64)
|
||||
|
||||
genBootSeq :: MonadIO m => Ship -> Pill -> Bool -> LegacyBootEvent -> m BootSeq
|
||||
genBootSeq ship Pill {..} lite boot = io $ do
|
||||
ent <- genEntropy
|
||||
let ovums = preKern ent <> pKernelOvums <> postKern <> pUserspaceOvums
|
||||
pure $ BootSeq ident pBootFormulas ovums
|
||||
genBootSeq :: HasKingEnv e
|
||||
=> Ship -> Pill -> Bool -> LegacyBootEvent -> RIO e BootSeq
|
||||
genBootSeq _ PillIvory {} _ _ = throwIO CannotBootFromIvoryPill
|
||||
genBootSeq ship PillPill {..} lite boot = do
|
||||
ent <- io genEntropy
|
||||
wyr <- wyrd
|
||||
let ova = preKern ent <> [wyr] <> pKernelOva <> postKern <> pUserspaceOva
|
||||
pure $ BootSeq ident pBootFormulae ova
|
||||
where
|
||||
ident = LogIdentity ship isFake (fromIntegral $ length pBootFormulas)
|
||||
ident = LogIdentity ship isFake (fromIntegral $ length pBootFormulae)
|
||||
preKern ent =
|
||||
[ EvBlip $ BlipEvArvo $ ArvoEvWhom () ship
|
||||
, EvBlip $ BlipEvArvo $ ArvoEvWack () ent
|
||||
@ -296,9 +302,9 @@ pier (serf, log) vSlog startedSig injected = do
|
||||
let execute = writeTQueue executeQ
|
||||
let persist = writeTQueue persistQ
|
||||
let sigint = Serf.sendSIGINT serf
|
||||
let scry = \w b g -> do
|
||||
let scry = \g r -> do
|
||||
res <- newEmptyMVar
|
||||
atomically $ writeTQueue scryQ (w, b, g, putMVar res)
|
||||
atomically $ writeTQueue scryQ (g, r, putMVar res)
|
||||
takeMVar res
|
||||
|
||||
-- Set up the runtime stat counters.
|
||||
@ -316,9 +322,9 @@ pier (serf, log) vSlog startedSig injected = do
|
||||
io $ readTVarIO siteSlog >>= ($ s)
|
||||
logOther "serf" (display $ T.strip $ tankToText tank)
|
||||
|
||||
let err = atomically . Term.trace muxed . (<> "\r\n")
|
||||
(bootEvents, startDrivers) <- do
|
||||
env <- ask
|
||||
let err = atomically . Term.trace muxed . (<> "\r\n")
|
||||
siz <- atomically $ Term.curDemuxSize demux
|
||||
let fak = isFake logId
|
||||
drivers env ship fak compute scry (siz, muxed) err sigint stat runtimeSubsite
|
||||
@ -335,6 +341,8 @@ pier (serf, log) vSlog startedSig injected = do
|
||||
|
||||
tSerf <- acquireWorker "Serf" (runCompute serf computeConfig)
|
||||
|
||||
doVersionNegotiation compute err
|
||||
|
||||
-- Run all born events and retry them until they succeed.
|
||||
wackEv <- EvBlip . BlipEvArvo . ArvoEvWack () <$> genEntropy
|
||||
rio $ for_ (wackEv : bootEvents) $ \ev -> do
|
||||
@ -346,7 +354,7 @@ pier (serf, log) vSlog startedSig injected = do
|
||||
cb :: Int -> WorkError -> IO ()
|
||||
cb n | n >= 3 = error ("boot event failed: " <> show ev)
|
||||
cb n = \case
|
||||
RunOkay _ -> putMVar okaySig ()
|
||||
RunOkay _ _ -> putMVar okaySig ()
|
||||
RunSwap _ _ _ _ _ -> putMVar okaySig ()
|
||||
RunBail _ -> inject (n + 1)
|
||||
|
||||
@ -373,7 +381,7 @@ pier (serf, log) vSlog startedSig injected = do
|
||||
let inject = atomically $ compute $ RRWork $ EvErr ev $ cb
|
||||
cb :: WorkError -> IO ()
|
||||
cb = \case
|
||||
RunOkay _ -> putMVar okaySig (Right ())
|
||||
RunOkay _ _ -> putMVar okaySig (Right ())
|
||||
RunSwap _ _ _ _ _ -> putMVar okaySig (Right ())
|
||||
RunBail goofs -> putMVar okaySig (Left goofs)
|
||||
|
||||
@ -414,6 +422,68 @@ death tag tid = do
|
||||
Left exn -> Left (tag, exn)
|
||||
Right () -> Right tag
|
||||
|
||||
-- %wyrd version negotiation ---------------------------------------------------
|
||||
|
||||
data PierVersionNegotiationFailed = PierVersionNegotiationFailed
|
||||
deriving (Show, Exception)
|
||||
|
||||
zuseVersion :: Word
|
||||
zuseVersion = 420
|
||||
|
||||
wyrd :: HasKingEnv e => RIO e Ev
|
||||
wyrd = do
|
||||
king <- tshow <$> view kingIdL
|
||||
|
||||
let k = Wynn [("zuse", zuseVersion),
|
||||
("lull", 330),
|
||||
("arvo", 240),
|
||||
("hoon", 140),
|
||||
("nock", 4)]
|
||||
sen = MkTerm king
|
||||
v = Vere sen [Cord "king-haskell", Cord "1.0"] k
|
||||
|
||||
pure $ EvBlip $ BlipEvArvo $ ArvoEvWyrd () v
|
||||
|
||||
doVersionNegotiation
|
||||
:: HasPierEnv e
|
||||
=> (RunReq -> STM ())
|
||||
-> (Text -> RIO e ())
|
||||
-> RAcquire e ()
|
||||
doVersionNegotiation compute stderr = do
|
||||
ev <- rio wyrd
|
||||
|
||||
okaySig :: MVar (Either [Goof] FX) <- newEmptyMVar
|
||||
let inject = atomically $ compute $ RRWork $ EvErr ev $ cb
|
||||
cb :: WorkError -> IO ()
|
||||
cb = \case
|
||||
RunOkay _ fx -> putMVar okaySig (Right fx)
|
||||
RunSwap _ _ _ _ fx -> putMVar okaySig (Right fx)
|
||||
RunBail goofs -> putMVar okaySig (Left goofs)
|
||||
|
||||
rio $ stderr "vere: checking version compatibility"
|
||||
io inject
|
||||
|
||||
takeMVar okaySig >>= \case
|
||||
Left goof -> do
|
||||
rio $ stderr "pier: version negotation failed"
|
||||
logError $ display @Text ("Goof in wyrd event: " <> tshow goof)
|
||||
throwIO PierVersionNegotiationFailed
|
||||
|
||||
Right fx -> do
|
||||
-- Walk through the returned fx looking for a wend effect. If we find
|
||||
-- one, check the zuse versions.
|
||||
rio $ for_ fx $ \case
|
||||
GoodParse (EfWend (Wynn xs)) -> case L.lookup "zuse" xs of
|
||||
Nothing -> pure ()
|
||||
Just zuseVerInWynn ->
|
||||
if zuseVerInWynn /= zuseVersion
|
||||
then do
|
||||
rio $ stderr "pier: pier: version negotiation failed; downgrade"
|
||||
throwIO PierVersionNegotiationFailed
|
||||
else
|
||||
pure ()
|
||||
_ -> pure ()
|
||||
|
||||
|
||||
-- Start All Drivers -----------------------------------------------------------
|
||||
|
||||
@ -432,7 +502,7 @@ drivers
|
||||
-> Ship
|
||||
-> Bool
|
||||
-> (RunReq -> STM ())
|
||||
-> (Wen -> Gang -> Path -> IO (Maybe (Term, Noun)))
|
||||
-> ScryFunc
|
||||
-> (TermSize, Term.Client)
|
||||
-> (Text -> RIO e ())
|
||||
-> IO ()
|
||||
@ -502,6 +572,7 @@ router slog waitFx Drivers {..} = do
|
||||
case ef of
|
||||
GoodParse (EfVega _ _ ) -> vega
|
||||
GoodParse (EfExit _ _ ) -> exit
|
||||
GoodParse (EfWend _ ) -> pure ()
|
||||
GoodParse (EfVane (VEBehn ef)) -> io (dBehn ef)
|
||||
GoodParse (EfVane (VEBoat ef)) -> io (dSync ef)
|
||||
GoodParse (EfVane (VEClay ef)) -> io (dSync ef)
|
||||
@ -537,7 +608,7 @@ data ComputeConfig = ComputeConfig
|
||||
{ ccOnWork :: STM RunReq
|
||||
, ccOnKill :: STM ()
|
||||
, ccOnSave :: STM ()
|
||||
, ccOnScry :: STM (Wen, Gang, Path, Maybe (Term, Noun) -> IO ())
|
||||
, ccOnScry :: STM (Gang, ScryReq, Maybe (Term, Noun) -> IO ())
|
||||
, ccPutResult :: (Fact, FX) -> STM ()
|
||||
, ccShowSpinner :: Maybe Text -> STM ()
|
||||
, ccHideSpinner :: STM ()
|
||||
@ -551,7 +622,7 @@ runCompute serf ComputeConfig {..} = do
|
||||
let onRR = asum [ ccOnKill <&> Serf.RRKill
|
||||
, ccOnSave <&> Serf.RRSave
|
||||
, ccOnWork
|
||||
, ccOnScry <&> \(w,g,p,k) -> Serf.RRScry w g p k
|
||||
, ccOnScry <&> \(g,r,k) -> Serf.RRScry g r k
|
||||
]
|
||||
|
||||
vEvProcessing :: TMVar Ev <- newEmptyTMVarIO
|
||||
|
||||
@ -14,10 +14,11 @@ module Urbit.Vere.Pier.Types
|
||||
, jobId
|
||||
, jobMug
|
||||
, DriverApi(..)
|
||||
, ScryFunc
|
||||
)
|
||||
where
|
||||
|
||||
import Urbit.Prelude hiding (Term)
|
||||
import Urbit.Prelude
|
||||
|
||||
import Urbit.Arvo
|
||||
import Urbit.Noun.Time
|
||||
@ -44,11 +45,14 @@ instance Show Nock where
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data Pill = Pill
|
||||
{ pBootFormulas :: ![Nock]
|
||||
, pKernelOvums :: ![Ev]
|
||||
, pUserspaceOvums :: ![Ev]
|
||||
}
|
||||
data Pill
|
||||
= PillIvory [Noun]
|
||||
| PillPill
|
||||
{ pName :: Noun
|
||||
, pBootFormulae :: ![Nock] -- XX not actually nock, semantically
|
||||
, pKernelOva :: ![Ev]
|
||||
, pUserspaceOva :: ![Ev]
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data BootSeq = BootSeq !LogIdentity ![Nock] ![Ev]
|
||||
@ -87,6 +91,10 @@ data DriverApi ef = DriverApi
|
||||
}
|
||||
|
||||
|
||||
-- Scrying --------------------------------------------------------------------
|
||||
|
||||
type ScryFunc = Gang -> ScryReq -> IO (Maybe (Term, Noun))
|
||||
|
||||
-- Instances -------------------------------------------------------------------
|
||||
|
||||
instance ToNoun Work where
|
||||
|
||||
@ -16,15 +16,16 @@
|
||||
|%
|
||||
:: +writ: from king to serf
|
||||
::
|
||||
+$ gang (unit (set ship))
|
||||
+$ writ
|
||||
$% $: %live
|
||||
$% [%cram eve=@]
|
||||
[%exit cod=@]
|
||||
[%save eve=@]
|
||||
[%meld ~]
|
||||
[%pack ~]
|
||||
== ==
|
||||
[%peek mil=@ now=@da lyc=gang pat=path]
|
||||
:: sam=[gang (each path $%([%once @tas @tas path] [beam @tas beam]))]
|
||||
[%peek mil=@ sam=*]
|
||||
[%play eve=@ lit=(list ?((pair @da ovum) *))]
|
||||
[%work mil=@ job=(pair @da ovum)]
|
||||
==
|
||||
@ -33,7 +34,8 @@
|
||||
+$ plea
|
||||
$% [%live ~]
|
||||
[%ripe [pro=%1 hon=@ nok=@] eve=@ mug=@]
|
||||
[%slog pri=@ ?(cord tank)]
|
||||
[%slog pri=@ tank]
|
||||
[%flog cord]
|
||||
$: %peek
|
||||
$% [%done dat=(unit (cask))]
|
||||
[%bail dud=goof]
|
||||
@ -48,6 +50,7 @@
|
||||
[%bail lud=(list goof)]
|
||||
== ==
|
||||
==
|
||||
--
|
||||
```
|
||||
-}
|
||||
|
||||
@ -84,7 +87,8 @@ import Foreign.Ptr (castPtr)
|
||||
import Foreign.Storable (peek, poke)
|
||||
import RIO.Prelude (decodeUtf8Lenient)
|
||||
import System.Posix.Signals (sigINT, sigKILL, signalProcess)
|
||||
import Urbit.Arvo (Ev, FX)
|
||||
import Urbit.Arvo (FX)
|
||||
import Urbit.Arvo.Event
|
||||
import Urbit.Noun.Time (Wen)
|
||||
|
||||
import qualified Data.ByteString as BS
|
||||
@ -171,9 +175,9 @@ recvPleaHandlingSlog :: Serf -> IO Plea
|
||||
recvPleaHandlingSlog serf = loop
|
||||
where
|
||||
loop = recvPlea serf >>= \case
|
||||
PSlog info -> serfSlog serf info >> loop
|
||||
other -> pure other
|
||||
|
||||
PSlog info -> serfSlog serf info >> loop
|
||||
PFlog (Cord ofni) -> serfSlog serf (0, Tank $ Leaf $ Tape $ ofni) >> loop
|
||||
other -> pure other
|
||||
|
||||
-- Higher-Level IPC Functions --------------------------------------------------
|
||||
|
||||
@ -219,9 +223,9 @@ sendCompactionRequest serf = do
|
||||
sendWrit serf (WLive $ LPack ())
|
||||
recvLive serf
|
||||
|
||||
sendScryRequest :: Serf -> Wen -> Gang -> Path -> IO (Maybe (Term, Noun))
|
||||
sendScryRequest serf w g p = do
|
||||
sendWrit serf (WPeek 0 w g p)
|
||||
sendScryRequest :: Serf -> Gang -> ScryReq -> IO (Maybe (Term, Noun))
|
||||
sendScryRequest serf g r = do
|
||||
sendWrit serf (WPeek 0 g r)
|
||||
recvPeek serf
|
||||
|
||||
sendShutdownRequest :: Serf -> Atom -> IO ()
|
||||
@ -370,10 +374,9 @@ compact serf = withSerfLockIO serf $ \ss -> do
|
||||
{-|
|
||||
Peek into the serf state.
|
||||
-}
|
||||
scry :: Serf -> Wen -> Gang -> Path -> IO (Maybe (Term, Noun))
|
||||
scry serf w g p = withSerfLockIO serf $ \ss -> do
|
||||
(ss,) <$> sendScryRequest serf w g p
|
||||
|
||||
scry :: Serf -> Gang -> ScryReq -> IO (Maybe (Term, Noun))
|
||||
scry serf g r = withSerfLockIO serf $ \ss -> do
|
||||
(ss,) <$> sendScryRequest serf g r
|
||||
|
||||
{-|
|
||||
Given a list of boot events, send them to to the serf in a single
|
||||
@ -493,7 +496,7 @@ run serf maxBatchSize getLastEvInLog onInput sendOn spin = topLoop
|
||||
RRSave () -> doSave
|
||||
RRKill () -> doKill
|
||||
RRPack () -> doPack
|
||||
RRScry w g p k -> doScry w g p k
|
||||
RRScry g r k -> doScry g r k
|
||||
|
||||
doPack :: IO ()
|
||||
doPack = compact serf >> topLoop
|
||||
@ -511,8 +514,8 @@ run serf maxBatchSize getLastEvInLog onInput sendOn spin = topLoop
|
||||
doKill :: IO ()
|
||||
doKill = waitForLog >> snapshot serf >> pure ()
|
||||
|
||||
doScry :: Wen -> Gang -> Path -> (Maybe (Term, Noun) -> IO ()) -> IO ()
|
||||
doScry w g p k = (scry serf w g p >>= k) >> topLoop
|
||||
doScry :: Gang -> ScryReq -> (Maybe (Term, Noun) -> IO ()) -> IO ()
|
||||
doScry g r k = (scry serf g r >>= k) >> topLoop
|
||||
|
||||
doWork :: EvErr -> IO ()
|
||||
doWork firstWorkErr = do
|
||||
@ -529,13 +532,13 @@ run serf maxBatchSize getLastEvInLog onInput sendOn spin = topLoop
|
||||
RRKill () -> atomically (closeTBMQueue que) >> pure doKill
|
||||
RRSave () -> atomically (closeTBMQueue que) >> pure doSave
|
||||
RRPack () -> atomically (closeTBMQueue que) >> pure doPack
|
||||
RRScry w g p k -> atomically (closeTBMQueue que) >> pure (doScry w g p k)
|
||||
RRScry g r k -> atomically (closeTBMQueue que) >> pure (doScry g r k)
|
||||
RRWork workErr -> atomically (writeTBMQueue que workErr) >> workLoop que
|
||||
|
||||
onWorkResp :: Wen -> EvErr -> Work -> IO ()
|
||||
onWorkResp wen (EvErr evn err) = \case
|
||||
WDone eid hash fx -> do
|
||||
io $ err (RunOkay eid)
|
||||
io $ err (RunOkay eid fx)
|
||||
atomically $ sendOn ((Fact eid hash wen (toNoun evn)), fx)
|
||||
WSwap eid hash (wen, noun) fx -> do
|
||||
io $ err (RunSwap eid hash wen noun fx)
|
||||
@ -543,6 +546,7 @@ run serf maxBatchSize getLastEvInLog onInput sendOn spin = topLoop
|
||||
WBail goofs -> do
|
||||
io $ err (RunBail goofs)
|
||||
|
||||
|
||||
{-|
|
||||
Given:
|
||||
|
||||
|
||||
@ -35,7 +35,7 @@ data Work
|
||||
|
||||
data Writ
|
||||
= WLive Live
|
||||
| WPeek Atom Wen Gang Path
|
||||
| WPeek Atom Gang ScryReq
|
||||
| WPlay EventId [Noun]
|
||||
| WWork Atom Wen Ev
|
||||
deriving (Show)
|
||||
@ -44,6 +44,7 @@ data Plea
|
||||
= PLive ()
|
||||
| PRipe SerfInfo
|
||||
| PSlog Slog
|
||||
| PFlog Cord
|
||||
| PPeek Scry
|
||||
| PPlay Play
|
||||
| PWork Work
|
||||
|
||||
@ -2,7 +2,7 @@ module Urbit.Vere.Serf.Types where
|
||||
|
||||
import Urbit.Prelude
|
||||
|
||||
import Urbit.Arvo (Ev, FX)
|
||||
import Urbit.Arvo (Desk, Ev, FX)
|
||||
import Urbit.Noun.Time (Wen)
|
||||
|
||||
|
||||
@ -82,7 +82,7 @@ data EvErr = EvErr Ev (WorkError -> IO ())
|
||||
data WorkError -- TODO Rename type and constructors
|
||||
= RunSwap EventId Mug Wen Noun FX -- TODO Maybe provide less info here?
|
||||
| RunBail [Goof]
|
||||
| RunOkay EventId
|
||||
| RunOkay EventId FX
|
||||
|
||||
{-
|
||||
- RRWork: Ask the serf to do work, will output (Fact, FX) if work
|
||||
@ -94,7 +94,19 @@ data RunReq
|
||||
| RRSave ()
|
||||
| RRKill ()
|
||||
| RRPack ()
|
||||
| RRScry Wen Gang Path (Maybe (Term, Noun) -> IO ())
|
||||
| RRScry Gang ScryReq (Maybe (Term, Noun) -> IO ())
|
||||
|
||||
type ScryReq = (Each Path Demi)
|
||||
|
||||
data Demi
|
||||
= DemiOnce Term Desk Path
|
||||
| DemiBeam Term Beam
|
||||
deriving (Show)
|
||||
|
||||
-- TODO
|
||||
type Beam = Void
|
||||
|
||||
deriveNoun ''Demi
|
||||
|
||||
|
||||
-- Exceptions ------------------------------------------------------------------
|
||||
@ -111,6 +123,8 @@ data SerfExn
|
||||
| SerfNotRunning
|
||||
| MissingBootEventsInEventLog Word Word
|
||||
| SnapshotAheadOfLog EventId EventId
|
||||
| BailDuringWyrd [Goof]
|
||||
| SwapDuringWyrd Mug (Wen, Noun) FX
|
||||
deriving (Show, Exception)
|
||||
|
||||
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: urbit-king
|
||||
version: 0.10.8
|
||||
version: 1.1
|
||||
license: MIT
|
||||
license-file: LICENSE
|
||||
data-files:
|
||||
|
||||
@ -108,9 +108,10 @@ instance Arbitrary LogIdentity where
|
||||
instance Arbitrary Packet where
|
||||
arbitrary = do
|
||||
pktVersion <- suchThat arb (< 8)
|
||||
pktEncrypted <- arb
|
||||
pktSndr <- arb
|
||||
pktRcvr <- arb
|
||||
pktSndrTick <- suchThat arb (< 16)
|
||||
pktRcvrTick <- suchThat arb (< 16)
|
||||
pktOrigin <- arb
|
||||
pktContent <- arb
|
||||
pure Packet {..}
|
||||
|
||||
@ -31,18 +31,6 @@ roundTrip x = Just x == fromNoun (toNoun x)
|
||||
nounEq :: (ToNoun a, ToNoun b) => a -> b -> Bool
|
||||
nounEq x y = toNoun x == toNoun y
|
||||
|
||||
data EvExample = EvEx Ev Noun
|
||||
deriving (Eq, Show)
|
||||
|
||||
eventSanity :: [EvExample] -> Bool
|
||||
eventSanity = all $ \(EvEx e n) -> toNoun e == n
|
||||
|
||||
instance Arbitrary EvExample where
|
||||
arbitrary = oneof $ fmap pure $
|
||||
[ EvEx (EvVane $ VaneVane $ VEVeer (Jael, ()) "" (Path []) "")
|
||||
(toNoun (Path ["vane", "vane", "jael"], Cord "veer", (), (), ()))
|
||||
]
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
tests :: TestTree
|
||||
@ -51,7 +39,6 @@ tests =
|
||||
[ testProperty "Round Trip Effect" (roundTrip @Ef)
|
||||
, testProperty "Round Trip Event" (roundTrip @Ev)
|
||||
, testProperty "Round Trip AmesDest" (roundTrip @AmesDest)
|
||||
, testProperty "Basic Event Sanity" eventSanity
|
||||
]
|
||||
|
||||
|
||||
@ -131,24 +118,9 @@ instance Arbitrary BlipEv where
|
||||
]
|
||||
|
||||
instance Arbitrary Ev where
|
||||
arbitrary = oneof [ EvVane <$> arb
|
||||
, EvBlip <$> arb
|
||||
arbitrary = oneof [ EvBlip <$> arb
|
||||
]
|
||||
|
||||
instance Arbitrary Vane where
|
||||
arbitrary = oneof [ VaneVane <$> arb
|
||||
, VaneZuse <$> arb
|
||||
]
|
||||
|
||||
instance Arbitrary VaneName where
|
||||
arbitrary = oneof $ pure <$> [minBound .. maxBound]
|
||||
|
||||
instance Arbitrary VaneEv where
|
||||
arbitrary = VEVeer <$> arb <*> arb <*> arb <*> arb
|
||||
|
||||
instance Arbitrary ZuseEv where
|
||||
arbitrary = ZEVeer () <$> arb <*> arb <*> arb
|
||||
|
||||
instance Arbitrary StdMethod where
|
||||
arbitrary = oneof $ pure <$> [ minBound .. maxBound ]
|
||||
|
||||
|
||||
@ -35,7 +35,7 @@ instance KnownSymbol name => Options.IsOption (Pill name) where
|
||||
)
|
||||
|
||||
defaultValue =
|
||||
Pill ( "../../../bin"
|
||||
Pill ( "../../../bin/"
|
||||
++ TypeLits.symbolVal (Proxy @name)
|
||||
++ ".pill"
|
||||
)
|
||||
|
||||
@ -1 +1 @@
|
||||
2082167031
|
||||
233234490
|
||||
@ -5,6 +5,7 @@ module Urbit.Noun.Mug where
|
||||
import ClassyPrelude
|
||||
|
||||
import Data.Bits
|
||||
import Data.ByteString.Builder
|
||||
import Urbit.Atom
|
||||
|
||||
import Data.Hash.Murmur (murmur3)
|
||||
@ -13,14 +14,7 @@ type Mug = Word32
|
||||
|
||||
{-# INLINE mugBS #-}
|
||||
mugBS :: ByteString -> Word32
|
||||
mugBS = go 0xcafebabe
|
||||
where
|
||||
go seed buf =
|
||||
let haz = murmur3 seed buf
|
||||
ham = shiftR haz 31 `xor` (haz .&. 0x7fff_ffff)
|
||||
in if ham == 0
|
||||
then go (seed + 1) buf
|
||||
else ham
|
||||
mugBS = mum 0xcafe_babe 0x7fff
|
||||
|
||||
-- XX is there a way to do this without copy?
|
||||
{-# INLINE mugAtom #-}
|
||||
@ -29,4 +23,16 @@ mugAtom = mugBS . atomBytes
|
||||
|
||||
{-# INLINE mugBoth #-}
|
||||
mugBoth :: Word32 -> Word32 -> Word32
|
||||
mugBoth m n = mugAtom $ fromIntegral $ m `xor` 0x7fff_ffff `xor` n
|
||||
mugBoth m n = mum 0xdead_beef 0xfffe
|
||||
$ toStrict $ toLazyByteString (word32LE m <> word32LE n)
|
||||
|
||||
mum :: Word32 -> Word32 -> ByteString -> Word32
|
||||
mum syd fal key = go syd 0
|
||||
where
|
||||
go syd 8 = fal
|
||||
go syd i =
|
||||
let haz = murmur3 syd key
|
||||
ham = shiftR haz 31 `xor` (haz .&. 0x7fff_ffff)
|
||||
in if ham /= 0
|
||||
then ham
|
||||
else go (syd + 1) (i + 1)
|
||||
|
||||
@ -147,7 +147,9 @@ enumFromAtom :: [(String, Name)] -> Exp
|
||||
enumFromAtom cons = LamE [VarP x] body
|
||||
where
|
||||
(x, c) = (mkName "x", mkName "c")
|
||||
getTag = BindS (VarP c) $ AppE (VarE 'parseNounUtf8Atom) (VarE x)
|
||||
getTag = BindS (VarP c)
|
||||
$ AppE (AppE (VarE 'named) matchFail)
|
||||
$ AppE (VarE 'parseNounUtf8Atom) (VarE x)
|
||||
examine = NoBindS $ CaseE (VarE c) (matches ++ [fallback])
|
||||
matches = mkMatch <$> cons
|
||||
fallback = Match WildP (NormalB $ AppE (VarE 'fail) matchFail) []
|
||||
@ -194,6 +196,7 @@ taggedFromNoun cons = LamE [VarP n] (DoE [getHead, getTag, examine])
|
||||
$ AppE (VarE 'parseNoun) (VarE n)
|
||||
|
||||
getTag = BindS (SigP (VarP c) (ConT ''Text))
|
||||
$ AppE (AppE (VarE 'named) tagFail)
|
||||
$ AppE (VarE 'parseNounUtf8Atom) (VarE h)
|
||||
|
||||
examine = NoBindS
|
||||
@ -208,6 +211,8 @@ taggedFromNoun cons = LamE [VarP n] (DoE [getHead, getTag, examine])
|
||||
fallback = Match WildP (NormalB $ AppE (VarE 'fail) matchFail) []
|
||||
matchFail = unexpectedTag (fst <$> cons) (VarE c)
|
||||
|
||||
tagFail = LitE $ StringL (intercalate " " (('%':) <$> (fst <$> cons)))
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
tagString :: Int -> Name -> String
|
||||
|
||||
@ -1 +1 @@
|
||||
1.0
|
||||
1.1
|
||||
Loading…
Reference in New Issue
Block a user