Merge remote-tracking branch 'origin/master' into release/next-vere

default.nix

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

pkg/hs/urbit-king/lib/Urbit/Arvo/Common.hs

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

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

pkg/hs/urbit-king/lib/Urbit/Arvo/Event.hs

@@ -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
+  toNoun = toNoun . \case
-    EvBlip v -> toNoun $ reorgThroughNoun (Cord "",     v)
+    EvBlip v@BlipEvAmes{}       -> reorgThroughNoun ("ames", v)
-    EvVane v -> toNoun $ reorgThroughNoun (Cord "vane", 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 _ 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)"
 
 
 -- 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"

pkg/hs/urbit-king/lib/Urbit/King/App.hs

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

pkg/hs/urbit-king/lib/Urbit/King/Main.hs

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

pkg/hs/urbit-king/lib/Urbit/King/Scry.hs

@@ -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)))
+       => ScryFunc
-       -> Text    -- ^ vane + care as two-letter string
+       -> Term    -- ^ vane + care as two-letter string
-       -> Ship    -- ^ ship in scry path, usually the local ship
+       -> Desk    -- ^ desk in scry path
-       -> Text    -- ^ desk in scry path
        -> [Text]  -- ^ resource path to scry for
        -> RIO e (Maybe n)
-scryNow scry vare ship desk path = do
+scryNow scry vare desk path =
-  env <- ask
+  io (scry Nothing (EachNo $ DemiOnce vare desk (Path $ MkKnot <$> path)))
-  wen <- io Time.now
+    >>= \case
-  let wan = tshow $ Time.MkDate wen
+      Just ("omen", fromNoun @(Path, Term, n) -> Just (_,_,v)) -> pure $ Just v
-  let pax = Path $ fmap MkKnot $ vare : (tshow ship) : desk : wan : path
+      Just (_, fromNoun @n -> Just v) -> pure $ Just v
-  io (scry wen Nothing pax) >>= \case
+      Just (_, n) -> do
-    Just (_, fromNoun @n -> Just v) -> pure $ Just v
+        logError $ displayShow ("uncanny scry result", vare, path, n)
-    Just (_, n) -> do
+        pure Nothing
-      logError $ displayShow ("uncanny scry result", vare, pax, n)
+      Nothing -> pure Nothing
-      pure Nothing
-    Nothing -> pure Nothing
 

pkg/hs/urbit-king/lib/Urbit/Vere/Ames.hs

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

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

@@ -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
+  { pktVersion  :: Word3
-  , pktEncrypted  :: Bool
+  , pktSndr     :: Ship
-  --
+  , pktRcvr     :: Ship
-  , pktSndr       :: Ship
+  , pktSndrTick :: Word4
-  , pktRcvr       :: Ship
+  , pktRcvrTick :: Word4
-  , pktOrigin     :: Maybe AmesDest
+  , pktOrigin   :: Maybe AmesAddress
-  , pktContent    :: Bytes
+  , 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
+    -- skip first three bits
-    let checksum     = shiftR  head  3 .&. (2 ^ 20 - 1)
+    let isAmes     = testBit head  3  &  not
-    let sndrRank     = shiftR  head 23 .&. 0b11
+    let pktVersion = shiftR  head  4 .&. 0b111 & fromIntegral
-    let rcvrRank     = shiftR  head 25 .&. 0b11
+    let sndrRank   = shiftR  head  7 .&. 0b11
-    let pktEncrypted = testBit head 27  &  not  -- loobean
+    let rcvrRank   = shiftR  head  9 .&. 0b11
-    -- verify checksum
+    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
+    tick <- getWord8
-    pktRcvr <- getShip rcvrRank
+    let pktSndrTick = tick .&. 0b1111
-    len     <- remaining
+    let pktRcvrTick = shiftR tick 4
-    payload <- getBytes len
+
-    -- data ("payload")
+    pktSndr <- getShip sndrClass
-    (pktOrigin, pktContent) <- case cueBS payload of
+    pktRcvr <- getShip rcvrClass
-          Left  e -> fail (show e)
+
-          Right n -> case fromNounErr n of
+    len <- remaining
-            Left  e -> fail (show e)
+    pktContent <- getBytes len
-            Right c -> pure c
+
-    pure Packet {..}
+    pure Packet{..}
     where
       getShip = fmap Ship . \case
-        0 -> fromIntegral <$> getWord16le              -- galaxy / star
+        Lord   -> fromIntegral <$> getWord16le
-        1 -> fromIntegral <$> getWord32le              -- planet
+        Planet -> fromIntegral <$> getWord32le
-        2 -> fromIntegral <$> getWord64le              -- moon
+        Moon   -> fromIntegral <$> getWord64le
-        3 -> LargeKey <$> getWord64le <*> getWord64le  -- comet
+        Comet  -> LargeKey <$> getWord64le <*> getWord64le
-        _ -> fail "impossibiru"
 
-  put Packet {..} = do
+  put Packet{..} = do
-    let load = jamBS $ toNoun (pktOrigin, pktContent)
     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 body = runPut $ do
-    let encr = pktEncrypted
+          putWord8 $ (pktSndrTick .&. 0b1111)
+                 .|. shiftL (pktRcvrTick .&. 0b1111) 4
+          putSndr
+          putRcvr
+          putByteString pktContent
+
     let vers = fromIntegral pktVersion .&. 0b111
-    let head =        vers
+    let chek = muk body
-           .|. shiftL chek                  3
+
-           .|. shiftL sndR                 23
+    -- skip first 3 bytes, set 4th to yes (0) for "is ames"
-           .|. shiftL rcvR                 25
+    let head = shiftL vers 4
-           .|. if     encr then 0 else bit 27
+           .|. 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 ^ 16 -> (0, putWord16le $ fromIntegral s)    -- lord
-          | s < 2 ^ 32 -> (1, putWord32le $ fromIntegral s)    -- pan
+          | s < 2 ^ 32 -> (1, putWord32le $ fromIntegral s)    -- planet
-          | s < 2 ^ 64 -> (2, putWord64le $ fromIntegral s)    -- mon
+          | s < 2 ^ 64 -> (2, putWord64le $ fromIntegral s)    -- moon
-          | otherwise  -> (3, putWord64le p >> putWord64le q)  -- com
+          | otherwise  -> (3, putWord64le p >> putWord64le q)  -- comet

pkg/hs/urbit-king/lib/Urbit/Vere/Behn.hs

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

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

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

pkg/hs/urbit-king/lib/Urbit/Vere/Pier.hs

@@ -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 :: HasKingEnv e
-genBootSeq ship Pill {..} lite boot = io $ do
+           => Ship -> Pill -> Bool -> LegacyBootEvent -> RIO e BootSeq
-  ent <- genEntropy
+genBootSeq _    PillIvory {}   _    _    = throwIO CannotBootFromIvoryPill
-  let ovums = preKern ent <> pKernelOvums <> postKern <> pUserspaceOvums
+genBootSeq ship PillPill  {..} lite boot = do
-  pure $ BootSeq ident pBootFormulas ovums
+  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

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

@@ -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
+data Pill
-  { pBootFormulas   :: ![Nock]
+  = PillIvory [Noun]
-  , pKernelOvums    :: ![Ev]
+  | PillPill
-  , pUserspaceOvums :: ![Ev]
+    { 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

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

@@ -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
+    PSlog info        -> serfSlog serf info >> loop
-    other      -> pure other
+    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 -> Gang -> ScryReq -> IO (Maybe (Term, Noun))
-sendScryRequest serf w g p = do
+sendScryRequest serf g r = do
-  sendWrit serf (WPeek 0 w g p)
+  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 -> Gang -> ScryReq -> IO (Maybe (Term, Noun))
-scry serf w g p = withSerfLockIO serf $ \ss -> do
+scry serf g r = withSerfLockIO serf $ \ss -> do
-  (ss,) <$> sendScryRequest serf w g p
+  (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 :: Gang -> ScryReq -> (Maybe (Term, Noun) -> IO ()) -> IO ()
-  doScry w g p k = (scry serf w g p >>= k) >> topLoop
+  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:
 

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

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

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

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

pkg/hs/urbit-king/package.yaml

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

pkg/hs/urbit-king/test/AmesTests.hs

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

pkg/hs/urbit-king/test/ArvoTests.hs

@@ -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
+  arbitrary = oneof [ EvBlip <$> arb
-                    , 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 ]
 

pkg/hs/urbit-king/test/Options.hs

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

pkg/hs/urbit-king/test/gold/hoontree.gold

@@ -1 +1 @@
-2082167031
+233234490

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

@@ -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
+mugBS = mum 0xcafe_babe 0x7fff
-  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
 
 -- 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)

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

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

pkg/urbit/version

@@ -1 +1 @@
-1.0
+1.1