From 3451e02cd1c2d273890b08554313a35854eb99c3 Mon Sep 17 00:00:00 2001 From: Elliot Glaysher Date: Wed, 16 Dec 2020 16:53:25 -0500 Subject: [PATCH] OK, and now we are walking through the effects --- pkg/hs/urbit-king/lib/Urbit/Arvo/Effect.hs | 5 +- pkg/hs/urbit-king/lib/Urbit/Vere/Pier.hs | 51 ++++++++++++++------ pkg/hs/urbit-king/lib/Urbit/Vere/Serf/IPC.hs | 1 - 3 files changed, 39 insertions(+), 18 deletions(-) diff --git a/pkg/hs/urbit-king/lib/Urbit/Arvo/Effect.hs b/pkg/hs/urbit-king/lib/Urbit/Arvo/Effect.hs index 50bf0d7f1..5a5782912 100644 --- a/pkg/hs/urbit-king/lib/Urbit/Arvo/Effect.hs +++ b/pkg/hs/urbit-king/lib/Urbit/Arvo/Effect.hs @@ -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,6 +259,7 @@ 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 @@ -275,6 +276,7 @@ instance ToNoun Ef where 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 = tack >>> parseNoun >=> \case @@ -282,6 +284,7 @@ instance FromNoun Ef where 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" diff --git a/pkg/hs/urbit-king/lib/Urbit/Vere/Pier.hs b/pkg/hs/urbit-king/lib/Urbit/Vere/Pier.hs index 8eb1fe265..57685687b 100644 --- a/pkg/hs/urbit-king/lib/Urbit/Vere/Pier.hs +++ b/pkg/hs/urbit-king/lib/Urbit/Vere/Pier.hs @@ -37,6 +37,7 @@ 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 @@ -316,9 +317,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,9 +336,7 @@ pier (serf, log) vSlog startedSig injected = do tSerf <- acquireWorker "Serf" (runCompute serf computeConfig) - -- TODO: Go through the version negotionation with the serf. Before we start - -- the drivers, we send a %wyrd event and wait for a %wynn - doVersionNegotiation compute + doVersionNegotiation compute err -- Run all born events and retry them until they succeed. wackEv <- EvBlip . BlipEvArvo . ArvoEvWack () <$> genEntropy @@ -420,18 +419,26 @@ death tag tid = do -- %wyrd version negotiation --------------------------------------------------- +data PierVersionNegotiationFailed = PierVersionNegotiationFailed + deriving (Show, Exception) + +zuseVersion :: Word +zuseVersion = 420 + doVersionNegotiation :: HasPierEnv e => (RunReq -> STM ()) + -> (Text -> RIO e ()) -> RAcquire e () -doVersionNegotiation compute = do - -- What we want to do is actually inspect the effects here. - let k = Wynn [("zuse", 420), +doVersionNegotiation compute stderr = do + king <- tshow <$> view kingIdL + + let k = Wynn [("zuse", zuseVersion), ("lull", 330), ("arvo", 240), ("hoon", 140), ("nock", 4)] - sen = MkTerm "121331" -- TODO: I can just generate a nonce here. + sen = MkTerm king v = Vere sen [Cord "kh", Cord "1.0"] k ev = EvBlip $ BlipEvArvo $ ArvoEvWyrd () v @@ -443,18 +450,29 @@ doVersionNegotiation compute = do RunSwap _ _ _ _ fx -> putMVar okaySig (Right fx) RunBail goofs -> putMVar okaySig (Left goofs) - -- OK, we are actually getting an exception from the remote side here. - logDebug "About to inject wyrd" + rio $ stderr "vere: checking version compatibility" io inject - logDebug "Injected wyrd" takeMVar okaySig >>= \case - Left goof -> logError $ display @Text ("Goof in wyrd event: " <> - tshow goof) + Left goof -> do + rio $ stderr "pier: version negotation failed" + logError $ display @Text ("Goof in wyrd event: " <> tshow goof) + throwIO PierVersionNegotiationFailed + Right fx -> do - -- TODO: We need to actually iterate over the fx list to search for - -- version negotiation events. - logDebug $ display @Text ("FX list: " <> tshow fx) + -- 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 ----------------------------------------------------------- @@ -544,6 +562,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) diff --git a/pkg/hs/urbit-king/lib/Urbit/Vere/Serf/IPC.hs b/pkg/hs/urbit-king/lib/Urbit/Vere/Serf/IPC.hs index fab6070d0..a6aa8c7a5 100644 --- a/pkg/hs/urbit-king/lib/Urbit/Vere/Serf/IPC.hs +++ b/pkg/hs/urbit-king/lib/Urbit/Vere/Serf/IPC.hs @@ -164,7 +164,6 @@ sendWrit s = sendBytes s . jamBS . toNoun recvPlea :: Serf -> IO Plea recvPlea w = do b <- recvResp w - putStrLn "recvPleas recvResp" n <- fromRightExn (cueBS b) (const $ BadPleaAtom $ bytesAtom b) p <- fromRightExn (fromNounErr @Plea n) (\(p, m) -> BadPleaNoun n p m) pure p