king: various fixes and improvements

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

@@ -132,7 +132,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)

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

@@ -9,7 +9,7 @@
 -}
 module Urbit.Arvo.Event where
 
-import Urbit.Prelude hiding (Term)
+import Urbit.Prelude
 
 import Control.Monad.Fail (fail)
 import Urbit.Arvo.Common (KingId(..), ServId(..), Vere(..))
@@ -218,8 +218,12 @@ instance Show Entropy where
 data ArvoEv
     = ArvoEvWhom ()   Ship
     | ArvoEvWack ()   Entropy
-    | ArvoEvCrud Path Noun
     | ArvoEvWyrd ()   Vere
+    | ArvoEvCrud Path Noun
+    | ArvoEvTrim UD
+    | ArvoEvWhat [Noun]
+    | ArvoEvWhey ()
+    | ArvoEvVerb (Maybe Bool)
   deriving (Eq, Ord, Show)
 
 deriveNoun ''ArvoEv

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

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

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

@@ -15,19 +15,17 @@ import Urbit.Arvo                  hiding (Fake)
 import Urbit.King.Config
 import Urbit.King.Scry
 import Urbit.Vere.Ames.LaneCache
-import Urbit.Vere.Ames.Packet
+--import Urbit.Vere.Ames.Packet
 import Urbit.Vere.Pier.Types
 import Urbit.Vere.Ports
 
-import Data.Serialize      (decode, encode)
+-- import Data.Serialize      (decode, encode)
 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 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,9 @@ 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
-
+    -- TODO
+    serfsUp p a b
+    {-
     case decode b of
       Right (pkt@Packet {..}) | ver == Nothing || ver == Just pktVersion -> do
         logDebug $ displayShow ("ames: bon packet", pkt, showUD $ bytesAtom b)
@@ -315,6 +315,7 @@ ames env who isFake stat scry enqueueEv stderr = (initialEvents, runAmes)
       Left e -> do
         bump asDml
         logInfo $ displayShow ("ames: dropping malformed", e)
+    -}
 
     where
       serfsUp p a b =
@@ -362,12 +363,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/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,7 +32,6 @@ 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)
 
@@ -79,11 +78,13 @@ data CannotBootFromIvoryPill = CannotBootFromIvoryPill
 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
+           => Ship -> Pill -> Bool -> LegacyBootEvent -> RIO e BootSeq
 genBootSeq _    PillIvory {}   _    _    = throwIO CannotBootFromIvoryPill
-genBootSeq ship PillPill  {..} lite boot = io $ do
-  ent <- genEntropy
-  let ova = preKern ent <> pKernelOva <> postKern <> pUserspaceOva
+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 pBootFormulae)
@@ -301,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.
@@ -429,12 +430,8 @@ data PierVersionNegotiationFailed = PierVersionNegotiationFailed
 zuseVersion :: Word
 zuseVersion = 420
 
-doVersionNegotiation
-  :: HasPierEnv e
-  => (RunReq -> STM ())
-  -> (Text -> RIO e ())
-  -> RAcquire e ()
-doVersionNegotiation compute stderr = do
+wyrd :: HasKingEnv e => RIO e Ev
+wyrd = do
   king <- tshow <$> view kingIdL
 
   let k   = Wynn [("zuse", zuseVersion),
@@ -443,8 +440,17 @@ doVersionNegotiation compute stderr = do
                   ("hoon", 140),
                   ("nock", 4)]
       sen = MkTerm king
-      v   = Vere sen [Cord "kh", Cord "1.0"] k
-      ev  = EvBlip $ BlipEvArvo $ ArvoEvWyrd () v
+      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
@@ -496,7 +502,7 @@ drivers
   -> Ship
   -> Bool
   -> (RunReq -> STM ())
-  -> (Wen -> Gang -> Path -> IO (Maybe (Term, Noun)))
+  -> ScryFunc
   -> (TermSize, Term.Client)
   -> (Text -> RIO e ())
   -> IO ()
@@ -602,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 ()
@@ -616,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,6 +14,7 @@ module Urbit.Vere.Pier.Types
   , jobId
   , jobMug
   , DriverApi(..)
+  , ScryFunc
   )
 where
 
@@ -56,8 +57,8 @@ instance Show Nock where
 data Pill
   = PillIvory [Noun]
   | PillPill
-    { pName         :: Term
-    , pBootFormulae :: ![Nock]
+    { pName         :: Noun
+    , pBootFormulae :: ![Nock]  -- XX not actually nock, semantically
     , pKernelOva    :: ![Ev]
     , pUserspaceOva :: ![Ev]
     }
@@ -99,6 +100,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)]
         ==  ==
     ==
+  --
   ```
 -}
 
@@ -172,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 --------------------------------------------------
 
@@ -220,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 ()
@@ -371,9 +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,7 +532,7 @@ 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 ()

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

pkg/hs/urbit-king/package.yaml

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

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