ilyakooo0/urbit
1
0
Fork 0
mirror of https://github.com/ilyakooo0/urbit.git synced 2024-12-12 05:04:56 +03:00
Code Issues Packages Projects Releases Wiki Activity

Merge branch 'release/next-userspace' into la/contact-store

Browse Source
This commit is contained in:
Matilde Park 2021-01-29 18:33:53 -05:00
commit b726ee2066
44 changed files with 1066 additions and 528 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
bin/solid.pill
View File

@ -1,3 +1,3 @@
version https://git-lfs.github.com/spec/v1
oid sha256:fd78b54d1c825f14b51c4dff001e17368953ecf9fc5a7b6792c059477761076a
size 9001760
oid sha256:6b4b198b552066fdee2a694a3134bf641b20591bebda21aa90920f4107f04f20
size 9065500

3
default.nix
View File

@ -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";
};
};

2
pkg/arvo/app/glob.hoon
View File

@ -5,7 +5,7 @@
/- glob
/+ default-agent, verb, dbug
|%
++ hash 0v7.9mc9i.jbk7p.smfcl.3aose.b6dat
++ hash 0v1.39us5.oj5a9.9as9u.od9db.0dipj
+$ state-0 [%0 hash=@uv glob=(unit (each glob:glob tid=@ta))]
+$ all-states
$% state-0

11
pkg/arvo/app/graph-store.hoon
View File

@ -726,7 +726,8 @@
$: %0
p=time
$= q
$% [%add-nodes =resource:store nodes=(tree [index:store tree-node])]
$% [%add-graph =resource:store =tree-graph mark=(unit ^mark) ow=?]
[%add-nodes =resource:store nodes=(tree [index:store tree-node])]
[%remove-nodes =resource:store indices=(tree index:store)]
[%add-signatures =uid:store signatures=tree-signatures]
[%remove-signatures =uid:store signatures=tree-signatures]
@ -806,6 +807,14 @@
^- logged-update:store
:+ %0 p.t
?- -.q.t
%add-graph
:* %add-graph
resource.q.t
(remake-graph tree-graph.q.t)
mark.q.t
ow.q.t
==
::
%add-nodes
:- %add-nodes
:- resource.q.t

2
pkg/arvo/app/landscape/index.html
View File

@ -24,6 +24,6 @@
<div id="portal-root"></div>
<script src="/~landscape/js/channel.js"></script>
<script src="/~landscape/js/session.js"></script>
<script src="/~landscape/js/bundle/index.226dd4e7ed526397a662.js"></script>
<script src="/~landscape/js/bundle/index.5fdbe84c6b57646a6a6b.js"></script>
</body>
</html>

2
pkg/arvo/app/lens.hoon
View File

@ -28,8 +28,6 @@
%contact-store
%contact-hook
%invite-store
%chat-store
%chat-hook
%graph-store
==
|= app=@tas

34
pkg/hs/urbit-king/lib/Urbit/Arvo/Common.hs
View File

@ -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
pkg/hs/urbit-king/lib/Urbit/Arvo/Effect.hs
View File

@ -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"

59
pkg/hs/urbit-king/lib/Urbit/Arvo/Event.hs
View File

@ -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"

21
pkg/hs/urbit-king/lib/Urbit/King/App.hs
View File

@ -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
@ -119,7 +137,8 @@ defaultLogFile :: IO FilePath
defaultLogFile = do
logDir <- getXdgDirectory XdgCache "urbit"
createDirectoryIfMissing True logDir
pure (logDir </> "king.log")
logId :: Word32 <- randomIO
pure (logDir </> "king-" <> show logId <> ".log")
runKingEnvNoLog :: RIO KingEnv a -> IO a
runKingEnvNoLog act = runKingEnv mempty mempty act

7
pkg/hs/urbit-king/lib/Urbit/King/Main.hs
View File

@ -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

36
pkg/hs/urbit-king/lib/Urbit/King/Scry.hs
View File

@ -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

6
pkg/hs/urbit-king/lib/Urbit/Prelude.hs
View File

@ -16,6 +16,7 @@ module Urbit.Prelude
, io, rio
, logTrace
, acquireWorker, acquireWorkerBound
, hark
) where
import ClassyPrelude
@ -38,6 +39,8 @@ import RIO (HasLogFunc, LogFunc, LogLevel(..), logDebug, logError, logFuncL,
logInfo, logOptionsHandle, logOther, logWarn, mkLogFunc,
setLogMinLevel, setLogUseLoc, setLogUseTime, withLogFunc)
import qualified RIO
io :: MonadIO m => IO a -> m a
io = liftIO
@ -47,6 +50,9 @@ rio = liftRIO
logTrace :: HasLogFunc e => Utf8Builder -> RIO e ()
logTrace = logOther "trace"
-- | Composes a log message out of textual components.
hark :: [Text] -> Utf8Builder
hark = RIO.displayBytesUtf8 . foldMap encodeUtf8
-- Utils for Spawning Worker Threads -------------------------------------------

86
pkg/hs/urbit-king/lib/Urbit/Vere/Ames.hs
View File

@ -24,8 +24,7 @@ import Urbit.King.App (HasKingId(..), HasPierEnv(..))
import Urbit.Vere.Ames.DNS (NetworkMode(..), ResolvServ(..))
import Urbit.Vere.Ames.DNS (galaxyPort, resolvServ)
import Urbit.Vere.Ames.UDP (UdpServ(..), fakeUdpServ, realUdpServ)
import qualified Urbit.Noun.Time as Time
import Urbit.Vere.Stat (AmesStat(..), bump, bump')
-- Constants -------------------------------------------------------------------
@ -47,7 +46,6 @@ type Version = Word8
data AmesDrv = AmesDrv
{ aTurfs :: TVar (Maybe [Turf])
, aDropped :: TVar Word
, aVersion :: TVar (Maybe Version)
, aUdpServ :: UdpServ
, aResolvr :: ResolvServ
@ -125,13 +123,14 @@ udpPort isFake who = do
udpServ :: (HasLogFunc e, HasNetworkConfig e, HasPortControlApi e)
=> Bool
-> Ship
-> AmesStat
-> RIO e UdpServ
udpServ isFake who = do
udpServ isFake who stat = do
mode <- netMode isFake
port <- udpPort isFake who
case modeAddress mode of
Nothing -> fakeUdpServ
Just host -> realUdpServ port host
Just host -> realUdpServ port host stat
_bornFailed :: e -> WorkError -> IO ()
_bornFailed env _ = runRIO env $ do
@ -141,10 +140,11 @@ ames'
:: HasPierEnv e
=> Ship
-> Bool
-> (Time.Wen -> Gang -> Path -> IO (Maybe (Term, Noun)))
-> AmesStat
-> ScryFunc
-> (Text -> RIO e ())
-> RIO e ([Ev], RAcquire e (DriverApi NewtEf))
ames' who isFake scry stderr = do
ames' who isFake stat scry stderr = do
-- Unfortunately, we cannot use TBQueue because the only behavior
-- provided for when full is to block the writer. The implementation
-- below uses materially the same data structures as TBQueue, however.
@ -164,11 +164,11 @@ ames' who isFake scry stderr = do
pure Ouster
dequeuePacket = do
pM <- tryReadTQueue ventQ
when (isJust pM) $ modifyTVar avail (+ 1)
when (isJust pM) $ modifyTVar' avail (+ 1)
pure pM
env <- ask
let (bornEvs, startDriver) = ames env who isFake scry enqueuePacket stderr
let (bornEvs, startDriver) = ames env who isFake stat scry enqueuePacket stderr
let runDriver = do
diOnEffect <- startDriver
@ -195,11 +195,12 @@ ames
=> e
-> Ship
-> Bool
-> (Time.Wen -> Gang -> Path -> IO (Maybe (Term, Noun)))
-> AmesStat
-> ScryFunc
-> (EvErr -> STM PacketOutcome)
-> (Text -> RIO e ())
-> ([Ev], RAcquire e (NewtEf -> IO ()))
ames env who isFake scry enqueueEv stderr = (initialEvents, runAmes)
ames env who isFake stat scry enqueueEv stderr = (initialEvents, runAmes)
where
king = fromIntegral (env ^. kingIdL)
@ -218,21 +219,28 @@ ames env who isFake scry enqueueEv stderr = (initialEvents, runAmes)
cachedScryLane <- cache scryLane
aTurfs <- newTVarIO Nothing
aDropped <- newTVarIO 0
aVersion <- newTVarIO Nothing
aVersTid <- trackVersionThread aVersion
aUdpServ <- udpServ isFake who
aUdpServ <- udpServ isFake who stat
aResolvr <- resolvServ aTurfs (usSend aUdpServ) stderr
aRecvTid <- queuePacketsThread
aDropped
aVersion
cachedScryLane
(send aUdpServ aResolvr mode)
aUdpServ
stat
pure (AmesDrv { .. })
hearFailed _ = pure ()
hearFailed AmesStat {..} = runRIO env . \case
RunSwap{} -> bump asSwp
RunBail gs -> do
for gs \(t, es) ->
for es \e ->
logWarn $ hark
["ames: goof: ", unTerm t, ": ", tankToText e]
bump asBal
RunOkay{} -> bump asOky
trackVersionThread :: HasLogFunc e => TVar (Maybe Version) -> RIO e (Async ())
trackVersionThread versSlot = async $ forever do
@ -249,34 +257,43 @@ ames env who isFake scry enqueueEv stderr = (initialEvents, runAmes)
threadDelay (10 * 60 * 1_000_000) -- 10m
queuePacketsThread :: HasLogFunc e
=> TVar Word
-> TVar (Maybe Version)
=> TVar (Maybe Version)
-> (Ship -> RIO e (Maybe [AmesDest]))
-> (AmesDest -> ByteString -> RIO e ())
-> UdpServ
-> AmesStat
-> RIO e (Async ())
queuePacketsThread dropCtr vers lan forward UdpServ{..} = async $ forever $ do
queuePacketsThread vers lan forward UdpServ{..} s@(AmesStat{..}) = async $ forever $ do
-- port number, host address, bytestring
(p, a, b) <- atomically usRecv
(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)
if pktRcvr == who
then serfsUp p a b
then do
bump asSup
serfsUp p a b
else lan pktRcvr >>= \case
Just ls
| dest:_ <- filter notSelf ls
-> forward dest $ encode pkt
{ pktOrigin = pktOrigin <|> Just (ipDest p a) }
-> do
bump asFwd
forward dest $ encode pkt
{ pktOrigin = pktOrigin
<|> Just (AAIpv4 (Ipv4 a) (fromIntegral p)) }
where
notSelf (EachYes g) = who /= Ship (fromIntegral g)
notSelf (EachNo _) = True
_ -> logInfo $ displayShow ("ames: dropping unroutable", pkt)
Right pkt -> logInfo $ displayShow ("ames: dropping ill-versed", pkt, ver)
_ -> do
bump asDrt
logInfo $ displayShow ("ames: dropping unroutable", pkt)
Right pkt -> do
bump asDvr
logInfo $ displayShow ("ames: dropping ill-versed", pkt, ver)
-- XX better handle misversioned or illegible packets.
-- Remarks from 67f06ce5, pkg/urbit/vere/io/ames.c, L1010:
@ -293,18 +310,19 @@ ames env who isFake scry enqueueEv stderr = (initialEvents, runAmes)
-- trigger printfs suggesting upgrade.
-- they cannot be filtered, as we do not know their semantics
--
Left e -> logInfo $ displayShow ("ames: dropping malformed", e)
Left e -> do
bump asDml
logInfo $ displayShow ("ames: dropping malformed", e)
where
serfsUp p a b =
atomically (enqueueEv (EvErr (hearEv p a b) hearFailed)) >>= \case
Intake -> pure ()
atomically (enqueueEv (EvErr (hearEv p a b) (hearFailed s))) >>= \case
Intake -> bump asSrf
Ouster -> do
d <- atomically $ do
d <- readTVar dropCtr
writeTVar dropCtr (d + 1)
pure d
when (d `rem` packetsDroppedPerComplaint == 0) $
bump' asQuf
readTVar asQuf
when (d `rem` packetsDroppedPerComplaint == 1) $
logWarn "ames: queue full; dropping inbound packets"
stop :: forall e. AmesDrv -> RIO e ()
@ -342,12 +360,12 @@ ames env who isFake 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)

170
pkg/hs/urbit-king/lib/Urbit/Vere/Ames/Packet.hs
View File

@ -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

9
pkg/hs/urbit-king/lib/Urbit/Vere/Ames/UDP.hs
View File

@ -39,7 +39,7 @@ import Network.Socket
import Control.Monad.STM (retry)
import Network.Socket.ByteString (recvFrom, sendTo)
import Urbit.Vere.Stat (AmesStat(..), bump)
-- Types -----------------------------------------------------------------------
@ -156,8 +156,9 @@ realUdpServ
. (HasLogFunc e, HasPortControlApi e)
=> PortNumber
-> HostAddress
-> AmesStat
-> RIO e UdpServ
realUdpServ por hos = do
realUdpServ por hos sat = do
logInfo $ displayShow ("AMES", "UDP", "Starting real UDP server.")
env <- ask
@ -192,6 +193,7 @@ realUdpServ por hos = do
enqueueRecvPacket p a b = do
did <- atomically (tryWriteTBQueue qRecv (p, a, b))
when (did == False) $ do
bump (asUqf sat)
logWarn $ displayShow $ ("AMES", "UDP",)
"Dropping inbound packet because queue is full."
@ -232,13 +234,16 @@ realUdpServ por hos = do
Just sk -> do
recvPacket sk >>= \case
Left exn -> do
bump (asUdf sat)
logError "AMES: UDP: Failed to receive packet"
signalBrokenSocket sk
Right Nothing -> do
bump (asUi6 sat)
logError "AMES: UDP: Dropping non-ipv4 packet"
pure ()
Right (Just (b, p, a)) -> do
logDebug "AMES: UDP: Received packet."
bump (asUdp sat)
enqueueRecvPacket p a b
let shutdown = do

2
pkg/hs/urbit-king/lib/Urbit/Vere/Behn.hs
View File

@ -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

34
pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/KingSubsite.hs
View File

@ -13,16 +13,15 @@ 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)
import Urbit.Vere.Stat (RenderedStat)
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 }
@ -43,10 +42,11 @@ 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
kingSubsite who scry func = do
kingSubsite who scry stat func = do
clients <- newTVarIO (mempty :: Map Word (SlogAction -> IO ()))
nextId <- newTVarIO (0 :: Word)
baton <- newTMVarIO ()
@ -77,15 +77,29 @@ kingSubsite who scry func = do
else
let loop = yield Flush
>> forever (atomically (readTQueue q) >>= streamSlog)
in respond $ W.responseSource (H.mkStatus 200 "OK") heads loop)
in respond $ W.responseSource (H.mkStatus 200 "OK") slogHeads loop)
["~_~", "stat"] -> do
authed <- authenticated env req
if not authed
then respond $ emptyResponse 403 "Permission Denied"
else do
lines <- stat
let msg = mconcat ((<> "\n") . encodeUtf8Builder <$> lines)
<> "\nRefresh for more current data."
respond $ W.responseBuilder (H.mkStatus 200 "OK") statHeads msg
_ -> respond $ emptyResponse 404 "Not Found"
where
heads = [ ("Content-Type" , "text/event-stream")
, ("Cache-Control", "no-cache")
, ("Connection" , "keep-alive")
]
slogHeads = [ ("Content-Type", "text/event-stream")
, ("Cache-Control", "no-cache")
, ("Connection", "keep-alive")
]
statHeads = [ ("Content-Type", "text/plain")
, ("Cache-Control", "no-cache")
]
emptyResponse cod mes = W.responseLBS (H.mkStatus cod mes) [] ""
@ -102,7 +116,7 @@ kingSubsite who scry 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 ->

119
pkg/hs/urbit-king/lib/Urbit/Vere/Pier.hs
View File

@ -23,6 +23,7 @@ import RIO.Directory
import Urbit.Arvo
import Urbit.King.App
import Urbit.Vere.Pier.Types
import Urbit.Vere.Stat
import Control.Monad.STM (retry)
import System.Environment (getExecutablePath)
@ -31,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
@ -71,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
@ -295,14 +302,18 @@ 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.
stat <- newStat
-- Set up the runtime subsite server and its capability to slog
-- and display stats.
siteSlog <- newTVarIO (const $ pure ())
runtimeSubsite <- Site.kingSubsite ship scry siteSlog
runtimeSubsite <- Site.kingSubsite ship scry (renderStat stat) siteSlog
-- Slogs go to stderr, to the runtime subsite, and to the terminal.
env <- ask
@ -311,12 +322,12 @@ 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 runtimeSubsite
drivers env ship fak compute scry (siz, muxed) err sigint stat runtimeSubsite
let computeConfig = ComputeConfig { ccOnWork = takeTMVar computeQ
, ccOnKill = onKill
@ -330,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
@ -341,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)
@ -368,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)
@ -409,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 -----------------------------------------------------------
@ -427,16 +502,19 @@ drivers
-> Ship
-> Bool
-> (RunReq -> STM ())
-> (Wen -> Gang -> Path -> IO (Maybe (Term, Noun)))
-> ScryFunc
-> (TermSize, Term.Client)
-> (Text -> RIO e ())
-> IO ()
-> Stat
-> Site.KingSubsite
-> RAcquire e ([Ev], RAcquire e Drivers)
drivers env who isFake plan scry termSys stderr serfSIGINT sub = do
drivers env who isFake plan scry termSys stderr serfSIGINT stat sub = do
let Stat{..} = stat
(behnBorn, runBehn) <- rio Behn.behn'
(termBorn, runTerm) <- rio (Term.term' termSys serfSIGINT)
(amesBorn, runAmes) <- rio (Ames.ames' who isFake scry stderr)
(termBorn, runTerm) <- rio (Term.term' termSys (renderStat stat) serfSIGINT)
(amesBorn, runAmes) <- rio (Ames.ames' who isFake statAmes scry stderr)
(httpBorn, runEyre) <- rio (Eyre.eyre' who isFake stderr sub)
(clayBorn, runClay) <- rio Clay.clay'
(irisBorn, runIris) <- rio Iris.client'
@ -494,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)
@ -529,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 ()
@ -543,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

20
pkg/hs/urbit-king/lib/Urbit/Vere/Pier/Types.hs
View File

@ -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

42
pkg/hs/urbit-king/lib/Urbit/Vere/Serf/IPC.hs
View File

@ -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:

3
pkg/hs/urbit-king/lib/Urbit/Vere/Serf/IPC/Types.hs
View File

@ -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

20
pkg/hs/urbit-king/lib/Urbit/Vere/Serf/Types.hs
View File

@ -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)

75
pkg/hs/urbit-king/lib/Urbit/Vere/Stat.hs Normal file
View File

@ -0,0 +1,75 @@
module Urbit.Vere.Stat where
import Urbit.Prelude
data Stat = Stat
{ statAmes :: AmesStat
}
data AmesStat = AmesStat
{ asUdp :: TVar Word
, asUqf :: TVar Word
, asUdf :: TVar Word
, asUi6 :: TVar Word
, asRcv :: TVar Word
, asSup :: TVar Word
, asSrf :: TVar Word
, asQuf :: TVar Word
, asFwd :: TVar Word
, asDrt :: TVar Word
, asDvr :: TVar Word
, asDml :: TVar Word
, asSwp :: TVar Word
, asBal :: TVar Word
, asOky :: TVar Word
}
newStat :: MonadIO m => m Stat
newStat = do
asUdp <- newTVarIO 0
asUqf <- newTVarIO 0
asUdf <- newTVarIO 0
asUi6 <- newTVarIO 0
asRcv <- newTVarIO 0
asSup <- newTVarIO 0
asSrf <- newTVarIO 0
asQuf <- newTVarIO 0
asFwd <- newTVarIO 0
asDrt <- newTVarIO 0
asDvr <- newTVarIO 0
asDml <- newTVarIO 0
asSwp <- newTVarIO 0
asBal <- newTVarIO 0
asOky <- newTVarIO 0
pure Stat{statAmes = AmesStat{..}}
bump :: MonadIO m => TVar Word -> m ()
bump s = atomically $ bump' s
bump' :: TVar Word -> STM ()
bump' s = modifyTVar' s (+ 1)
type RenderedStat = [Text]
renderStat :: MonadIO m => Stat -> m RenderedStat
renderStat Stat{statAmes = AmesStat{..}} =
sequence
[ pure "stat:"
, pure " ames:"
, (" udp ingress: " <>) <$> tshow <$> readTVarIO asUdp
, (" udp queue evict: " <>) <$> tshow <$> readTVarIO asUqf
, (" udp recv fail: " <>) <$> tshow <$> readTVarIO asUdf
, (" udp dropped non-ipv4: " <>) <$> tshow <$> readTVarIO asUi6
, (" driver ingress: " <>) <$> tshow <$> readTVarIO asRcv
, (" enqueued for serf: " <>) <$> tshow <$> readTVarIO asSup
, (" sent to serf: " <>) <$> tshow <$> readTVarIO asSrf
, (" serf queue evict: " <>) <$> tshow <$> readTVarIO asQuf
, (" forwarded: " <>) <$> tshow <$> readTVarIO asFwd
, (" dropped (unroutable): " <>) <$> tshow <$> readTVarIO asDrt
, (" dropped (wrong version): " <>) <$> tshow <$> readTVarIO asDvr
, (" dropped (malformed): " <>) <$> tshow <$> readTVarIO asDml
, (" serf swapped: " <>) <$> tshow <$> readTVarIO asSwp
, (" serf bailed: " <>) <$> tshow <$> readTVarIO asBal
, (" serf okay: " <>) <$> tshow <$> readTVarIO asOky
]

11
pkg/hs/urbit-king/lib/Urbit/Vere/Term.hs
View File

@ -27,6 +27,7 @@ import Urbit.Vere.Pier.Types
import Data.List ((!!))
import RIO.Directory (createDirectoryIfMissing)
import Urbit.King.API (readPortsFile)
import Urbit.Vere.Stat (RenderedStat)
import Urbit.TermSize (TermSize(TermSize))
import Urbit.Vere.Term.API (Client(Client), ClientTake(..))
@ -558,7 +559,7 @@ localClient doneSignal = fst <$> mkRAcquire start stop
loop rd
else if w == 3 then do
-- ETX (^C)
logInfo $ displayShow "Ctrl-c interrupt"
logInfo $ "Ctrl-c interrupt"
atomically $ do
writeTQueue wq [Term.Trace "interrupt\r\n"]
writeTQueue rq $ Ctl $ Cord "c"
@ -599,9 +600,10 @@ localClient doneSignal = fst <$> mkRAcquire start stop
term'
:: HasPierEnv e
=> (TermSize, Client)
-> IO RenderedStat
-> IO ()
-> RIO e ([Ev], RAcquire e (DriverApi TermEf))
term' (tsize, client) serfSIGINT = do
term' (tsize, client) stat serfSIGINT = do
let TermSize wi hi = tsize
initEv = [blewEvent wi hi, initialHail]
@ -610,7 +612,7 @@ term' (tsize, client) serfSIGINT = do
runDriver = do
env <- ask
ventQ :: TQueue EvErr <- newTQueueIO
diOnEffect <- term env (tsize, client) (writeTQueue ventQ) serfSIGINT
diOnEffect <- term env (tsize, client) (writeTQueue ventQ) stat serfSIGINT
let diEventSource = fmap RRWork <$> tryReadTQueue ventQ
@ -623,9 +625,10 @@ term :: forall e. (HasPierEnv e)
=> e
-> (TermSize, Client)
-> (EvErr -> STM ())
-> IO RenderedStat
-> IO ()
-> RAcquire e (TermEf -> IO ())
term env (tsize, Client{..}) plan serfSIGINT = runTerm
term env (tsize, Client{..}) plan stat serfSIGINT = runTerm
where
runTerm :: RAcquire e (TermEf -> IO ())
runTerm = do

2
pkg/hs/urbit-king/package.yaml
View File

@ -1,5 +1,5 @@
name: urbit-king
version: 0.10.8
version: 1.1
license: MIT
license-file: LICENSE
data-files:

3
pkg/hs/urbit-king/test/AmesTests.hs
View File

@ -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 {..}

30
pkg/hs/urbit-king/test/ArvoTests.hs
View File

@ -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 ]

2
pkg/hs/urbit-king/test/Options.hs
View File

@ -35,7 +35,7 @@ instance KnownSymbol name => Options.IsOption (Pill name) where
)
defaultValue =
Pill ( "../../../bin"
Pill ( "../../../bin/"
++ TypeLits.symbolVal (Proxy @name)
++ ".pill"
)

2
pkg/hs/urbit-king/test/gold/hoontree.gold
View File

@ -1 +1 @@
2082167031
233234490

24
pkg/hs/urbit-noun-core/lib/Urbit/Noun/Mug.hs
View File

@ -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)

7
pkg/hs/urbit-noun-core/lib/Urbit/Noun/TH.hs
View File

@ -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

51
pkg/interface/package-lock.json generated
View File

@ -10150,57 +10150,6 @@
"version": "2.1.1",
"resolved": "https://registry.npmjs.org/normalize-path/-/normalize-path-2.1.1.tgz",
"integrity": "sha1-GrKLVW4Zg2Oowab35vogE3/mrtk=",
"dev": true,
"requires": {
"remove-trailing-separator": "^1.0.1"
}
}
}
},
"binary-extensions": {
"version": "1.13.1",
"resolved": "https://registry.npmjs.org/binary-extensions/-/binary-extensions-1.13.1.tgz",
"integrity": "sha512-Un7MIEDdUC5gNpcGDV97op1Ywk748MpHcFTHoYs6qnj1Z3j7I53VG3nwZhKzoBZmbdRNnb6WRdFlwl7tSDuZGw==",
"dev": true
},
"braces": {
"version": "2.3.2",
"resolved": "https://registry.npmjs.org/braces/-/braces-2.3.2.tgz",
"integrity": "sha512-aNdbnj9P8PjdXU4ybaWLK2IF3jc/EoDYbC7AazW6to3TRsfXxscC9UXOB5iDiEQrkyIbWp2SLQda4+QAa7nc3w==",
"dev": true,
"requires": {
"arr-flatten": "^1.1.0",
"array-unique": "^0.3.2",
"extend-shallow": "^2.0.1",
"fill-range": "^4.0.0",
"isobject": "^3.0.1",
"repeat-element": "^1.1.2",
"snapdragon": "^0.8.1",
"snapdragon-node": "^2.0.1",
"split-string": "^3.0.2",
"to-regex": "^3.0.1"
}
},
"chokidar": {
"version": "2.1.8",
"resolved": "https://registry.npmjs.org/chokidar/-/chokidar-2.1.8.tgz",
"integrity": "sha512-ZmZUazfOzf0Nve7duiCKD23PFSCs4JPoYyccjUFF3aQkQadqBhfzhjkwBH2mNOG9cTBwhamM37EIsIkZw3nRgg==",
"dev": true,
"requires": {
"anymatch": "^2.0.0",
"async-each": "^1.0.1",
"braces": "^2.3.2",
"fsevents": "^1.2.7",
"glob-parent": "^3.1.0",
"inherits": "^2.0.3",
"is-binary-path": "^1.0.0",
"is-glob": "^4.0.0",
"normalize-path": "^3.0.0",
"path-is-absolute": "^1.0.0",
"readdirp": "^2.2.1",
"upath": "^1.1.1"
}
},
"extend-shallow": {
"version": "2.0.1",
"resolved": "https://registry.npmjs.org/extend-shallow/-/extend-shallow-2.0.1.tgz",

14
pkg/interface/src/logic/lib/util.ts
View File

@ -370,11 +370,19 @@ export function useShowNickname(contact: Contact | null, hide?: boolean): boolea
return !!(contact && contact.nickname && !hideNicknames);
}
export function useHovering() {
interface useHoveringInterface {
hovering: boolean;
bind: {
onMouseOver: () => void,
onMouseLeave: () => void
}
}
export const useHovering = (): useHoveringInterface => {
const [hovering, setHovering] = useState(false);
const bind = {
onMouseEnter: () => setHovering(true),
onMouseOver: () => setHovering(true),
onMouseLeave: () => setHovering(false)
};
return { hovering, bind };
}
};

19
pkg/interface/src/logic/store/store.ts
View File

@ -1,3 +1,5 @@
import _ from 'lodash';
import BaseStore from './base';
import InviteReducer from '../reducers/invite-update';
import MetadataReducer from '../reducers/metadata-update';
@ -28,6 +30,18 @@ export default class GlobalStore extends BaseStore<StoreState> {
connReducer = new ConnectionReducer();
settingsReducer = new SettingsReducer();
pastActions: Record<string, any> = {}
constructor() {
super();
(window as any).debugStore = this.debugStore.bind(this);
}
debugStore(tag: string, ...stateKeys: string[]) {
console.log(this.pastActions[tag]);
console.log(_.pick(this.state, stateKeys));
}
rehydrate() {
this.localReducer.rehydrate(this.state);
}
@ -84,6 +98,11 @@ export default class GlobalStore extends BaseStore<StoreState> {
}
reduce(data: Cage, state: StoreState) {
// debug shim
const tag = Object.keys(data)[0];
const oldActions = this.pastActions[tag] || [];
this.pastActions[tag] = [data[tag], ...oldActions.slice(0,14)];
this.inviteReducer.reduce(data, this.state);
this.metadataReducer.reduce(data, this.state);
this.localReducer.reduce(data, this.state);

4
pkg/interface/src/views/apps/launch/components/ModalButton.tsx
View File

@ -17,7 +17,7 @@ const ModalButton = (props) => {
return (
<>
{modal}
<Box
<Button
onClick={showModal}
display="flex"
alignItems="center"
@ -30,7 +30,7 @@ const ModalButton = (props) => {
{...rest}
>
<Icon icon={props.icon} mr={2} color={color}></Icon><Text color={color}>{props.text}</Text>
</Box>
</Button>
</>
);
}

1
pkg/interface/src/views/apps/notifications/graph.tsx
View File

@ -180,6 +180,7 @@ const GraphNode = ({
icon
color={`#000000`}
classes="mix-blend-diff"
padded
/>
) : <Box style={{ width: '16px' }}></Box>;

78
pkg/interface/src/views/apps/notifications/inbox.tsx
View File

@ -1,4 +1,4 @@
import React, { useEffect, useCallback, useState, useMemo, useRef } from "react";
import React, { useEffect, useCallback, useRef, useState } from "react";
import f from "lodash/fp";
import _ from "lodash";
import { Icon, Col, Row, Box, Text, Anchor, Rule, Center } from "@tlon/indigo-react";
@ -9,16 +9,13 @@ import { BigInteger } from "big-integer";
import GlobalApi from "~/logic/api/global";
import { Notification } from "./notification";
import { Associations } from "~/types";
import {Invites} from "./invites";
import {useLazyScroll} from "~/logic/lib/useLazyScroll";
import { cite } from '~/logic/lib/util';
import { InviteItem } from '~/views/components/Invite';
import { useWaitForProps } from "~/logic/lib/useWaitForProps";
import { useHistory } from "react-router-dom";
import {useModal} from "~/logic/lib/useModal";
import {JoinGroup} from "~/views/landscape/components/JoinGroup";
import {Invites} from "./invites";
import {useLazyScroll} from "~/logic/lib/useLazyScroll";
type DatedTimebox = [BigInteger, Timebox];
@ -33,7 +30,7 @@ function filterNotification(associations: Associations, groups: string[]) {
} else if ("group" in n.index) {
const { group } = n.index.group;
return groups.findIndex((g) => group === g) !== -1;
}
}
return true;
};
}
@ -66,7 +63,7 @@ export default function Inbox(props: {
const notifications =
Array.from(props.showArchive ? props.archive : props.notifications) || [];
const calendar = {
...MOMENT_CALENDAR_DATE, sameDay: function (now) {
if (this.subtract(6, 'hours').isBefore(now)) {
@ -99,6 +96,68 @@ export default function Inbox(props: {
);
const scrollRef = useRef(null);
const [joining, setJoining] = useState<[string, string] | null>(null);
const { modal, showModal } = useModal(
{ modal: useCallback(
(dismiss) => (
<JoinGroup
groups={props.groups}
contacts={props.contacts}
api={props.api}
autojoin={joining?.[0]?.slice(6)}
inviteUid={joining?.[1]}
/>
),
[props.contacts, props.groups, props.api, joining]
)})
const joinGroup = useCallback((group: string, uid: string) => {
setJoining([group, uid]);
showModal();
}, [setJoining, showModal]);
const acceptInvite = (app: string, uid: string) => async (invite) => {
const resource = {
ship: `~${invite.resource.ship}`,
name: invite.resource.name
};
const resourcePath = resourceAsPath(invite.resource);
if(app === 'contacts') {
joinGroup(resourcePath, uid);
} else if ( app === 'chat') {
await api.invite.accept(app, uid);
history.push(`/~landscape/home/resource/chat${resourcePath.slice(5)}`);
} else if ( app === 'graph') {
await api.invite.accept(app, uid);
history.push(`/~graph/join${resourcePath}`);
}
};
const inviteItems = (invites, api) => {
const returned = [];
Object.keys(invites).map((appKey) => {
const app = invites[appKey];
Object.keys(app).map((uid) => {
const invite = app[uid];
const inviteItem =
<InviteItem
key={uid}
invite={invite}
onAccept={acceptInvite(appKey, uid)}
onDecline={() => api.invite.decline(appKey, uid)}
/>;
returned.push(inviteItem);
});
});
return returned;
};
const loadMore = useCallback(async () => {
return api.hark.getMore();
}, [api]);
@ -108,6 +167,7 @@ export default function Inbox(props: {
return (
<Col ref={scrollRef} position="relative" height="100%" overflowY="auto">
{modal}
<Invites invites={invites} api={api} associations={associations} />
{[...notificationsByDayMap.keys()].sort().reverse().map((day, index) => {
const timeboxes = notificationsByDayMap.get(day)!;
@ -157,7 +217,7 @@ function DaySection({
groupConfig,
graphConfig,
}) {
const lent = timeboxes.map(([,nots]) => nots.length).reduce(f.add, 0);
if (lent === 0 || timeboxes.length === 0) {
return null;

433
pkg/urbit/jets/tree.c
View File

File diff suppressed because it is too large Load Diff

6
pkg/urbit/noun/jets.c
View File

@ -1796,13 +1796,13 @@ _cj_minx(u3_noun cey, u3_noun cor)
}
static void
_cj_print_tas(FILE* fh, u3_noun tas)
_cj_print_tas(u3_noun tas)
{
c3_w met_w = u3r_met(3, tas);
c3_c* str_c = alloca(met_w + 1);
u3r_bytes(0, met_w, (c3_y*)str_c, tas);
str_c[met_w] = 0;
fprintf(fh, "/%s", str_c);
u3l_log("/%s", str_c);
}
/* _cj_mine(): declare a core and produce location. RETAIN.
@ -1851,7 +1851,7 @@ _cj_mine(u3_noun cey, u3_noun cor, u3_noun bas)
u3_noun i = bal;
u3l_log("hot jet: ");
while ( i != u3_nul ) {
_cj_print_tas(stderr, u3h(i));
_cj_print_tas(u3h(i));
i = u3t(i);
}
u3l_log("\r\n axe %d, jax %d,\r\n bash ", axe, jax_l);

12
pkg/urbit/vere/io/fore.c
View File

@ -121,14 +121,10 @@ _fore_io_talk(u3_auto* car_u)
// set verbose as per -v
//
// XX should be explicit, not a toggle
//
if ( c3y == u3_Host.ops_u.veb ) {
// XX this path shouldn't be necessary
//
wir = u3nt(c3__term, '1', u3_nul);
cad = u3nc(c3__verb, u3_nul);
{
c3_o lac_o = ( c3y == u3_Host.ops_u.veb ) ? c3n : c3y;
wir = u3nc(c3__arvo, u3_nul);
cad = u3nt(c3__verb, u3_nul, lac_o);
u3_auto_plan(car_u, u3_ovum_init(0, u3_blip, wir, cad));
}

19
pkg/urbit/vere/io/unix.c
View File

@ -79,7 +79,7 @@ struct _u3_ufil;
} u3_unix;
void
u3_unix_ef_look(u3_unix* unx_u, u3_noun all);
u3_unix_ef_look(u3_unix* unx_u, u3_noun mon, u3_noun all);
/* u3_readdir_r():
*/
@ -609,8 +609,7 @@ static void
_unix_commit_mount_point(u3_unix* unx_u, u3_noun mon)
{
unx_u->dyr = c3y;
u3z(mon);
u3_unix_ef_look(unx_u, c3n);
u3_unix_ef_look(unx_u, mon, c3n);
return;
}
@ -1355,19 +1354,25 @@ u3_unix_release(c3_c* pax_c)
c3_free(paf_c);
}
/* u3_unix_ef_look(): update the root.
/* u3_unix_ef_look(): update the root of a specific mount point.
*/
void
u3_unix_ef_look(u3_unix* unx_u, u3_noun all)
u3_unix_ef_look(u3_unix* unx_u, u3_noun mon, u3_noun all)
{
if ( c3y == unx_u->dyr ) {
unx_u->dyr = c3n;
u3_umon* mon_u;
u3_umon* mon_u = unx_u->mon_u;
for ( mon_u = unx_u->mon_u; mon_u; mon_u = mon_u->nex_u ) {
while ( mon_u && ( c3n == u3r_sing_c(mon_u->nam_c, mon) ) ) {
mon_u = mon_u->nex_u;
}
if ( mon_u ) {
_unix_update_mount(unx_u, mon_u, all);
}
}
u3z(mon);
}
/* _unix_io_talk(): start listening for fs events.

89
pkg/urbit/vere/pier.c
View File

@ -470,6 +470,14 @@ u3_pier_peek_last(u3_pier* pir_u,
_pier_peek_plan(pir_u, pic_u);
}
/* _pier_stab(): parse path
*/
static u3_noun
_pier_stab(u3_noun pac)
{
return u3do("stab", pac);
}
/* _pier_on_scry_done(): scry callback.
*/
static void
@ -482,48 +490,64 @@ _pier_on_scry_done(void* ptr_v, u3_noun nun)
u3l_log("pier: scry failed\n");
}
else {
u3_weak out, pad;
c3_c *ext_c, *pac_c;
u3l_log("pier: scry succeeded\n");
// serialize as desired
if ( u3_Host.ops_u.puk_c ) {
pac_c = u3_Host.ops_u.puk_c;
}
else {
pac_c = u3_Host.ops_u.pek_c;
}
// try to serialize as requested
//
u3_atom out;
c3_c* ext_c;
{
u3_atom puf = u3i_string(u3_Host.ops_u.puf_c);
if ( c3y == u3r_sing(c3__jam, puf) ) {
out = u3qe_jam(res);
ext_c = "jam";
}
else {
else if ( c3y == u3a_is_atom(res) ) {
out = u3dc("scot", u3k(puf), u3k(res));
ext_c = "txt";
}
else {
u3l_log("pier: cannot export cell as %s\n", u3_Host.ops_u.puf_c);
out = u3_none;
}
u3z(puf);
}
c3_c* pac_c = u3_Host.ops_u.puk_c;
if (!pac_c) {
pac_c = u3_Host.ops_u.pek_c;
}
u3_noun pad;
// try to build export target path
//
{
// XX crashes if [pac_c] is not a valid path
// XX virtualize or fix
//
u3_noun pax = u3do("stab", u3i_string(pac_c));
c3_w len_w = u3kb_lent(u3k(pax));
pad = u3nt(c3_s4('.','u','r','b'),
c3_s3('p','u','t'),
u3qb_scag(len_w - 1, pax));
u3z(pax);
u3_noun pro = u3m_soft(0, _pier_stab, u3i_string(pac_c));
if ( 0 == u3h(pro) ) {
c3_w len_w = u3kb_lent(u3k(u3t(pro)));
pad = u3nt(c3_s4('.', 'u', 'r', 'b'),
c3_s3('p', 'u', 't'),
u3qb_scag(len_w - 1, u3t(pro)));
}
else {
u3l_log("pier: invalid export path %s\n", pac_c);
pad = u3_none;
}
u3z(pro);
}
c3_c fil_c[2048];
snprintf(fil_c, 2048, "%s/.urb/put/%s.%s", pir_u->pax_c, pac_c+1, ext_c);
// if serialization and export path succeeded, write to disk
//
if ( (u3_none != out) && (u3_none != pad) ) {
c3_c fil_c[2048];
snprintf(fil_c, 2048, "%s/.urb/put/%s.%s",
pir_u->pax_c, pac_c+1, ext_c);
u3_walk_save(fil_c, 0, out, pir_u->pax_c, pad);
u3l_log("pier: scry in %s\n", fil_c);
u3_walk_save(fil_c, 0, out, pir_u->pax_c, pad);
u3l_log("pier: scry result in %s\n", fil_c);
}
}
u3l_log("pier: exit\n");
@ -1707,20 +1731,21 @@ _pier_boot_make(u3_noun who, u3_noun wyr, u3_noun ven, u3_noun pil)
// prepend entropy and identity to the module sequence
//
{
u3_noun wir, cad;
u3_noun cad, wir = u3nt(u3_blip, c3__arvo, u3_nul);
c3_w eny_w[16];
c3_rand(eny_w);
wir = u3nt(u3_blip, c3__arvo, u3_nul);
cad = u3nt(c3__verb, u3_nul, ( c3y == u3_Host.ops_u.veb ) ? c3n : c3y);
bot_u.mod = u3nc(u3nc(u3k(wir), cad), bot_u.mod);
cad = u3nc(c3__wack, u3i_words(16, eny_w));
bot_u.mod = u3nc(u3nc(wir, cad), bot_u.mod);
bot_u.mod = u3nc(u3nc(u3k(wir), cad), bot_u.mod);
cad = u3nc(c3__whom, who); // transfer [who]
bot_u.mod = u3nc(u3nc(u3k(wir), cad), bot_u.mod);
wir = u3nt(u3_blip, c3__arvo, u3_nul);
cad = u3nc(c3__whom, who); // transfer
bot_u.mod = u3nc(u3nc(wir, cad), bot_u.mod);
wir = u3nt(u3_blip, c3__arvo, u3_nul);
bot_u.mod = u3nc(u3nc(wir, wyr), bot_u.mod);
bot_u.mod = u3nc(u3nc(wir, wyr), bot_u.mod); // transfer [wir] and [wyr]
}
// prepend legacy boot event to the userspace sequence

2
pkg/urbit/version
View File

@ -1 +1 @@
1.0
1.1