Figure out what all the events types are in the testnet zod, and parse them.

pkg/hs-urbit/lib/Noun.hs

@@ -30,7 +30,7 @@ _Cue = prism' jamBS (eitherToMaybe . cueBS)
     eitherToMaybe (Right x) = Just x
 
 data LoadErr = CueErr DecodeErr
-             | ParseErr Text
+             | ParseErr [Text] Text
   deriving (Eq, Ord, Show)
 
 loadFile :: ∀a. FromNoun a => FilePath -> IO (Either LoadErr a)
@@ -39,5 +39,5 @@ loadFile pax = do
     case cueBS bs of
       Left e  -> pure $ Left (CueErr e)
       Right n -> case fromNounErr n of
-                   Left e  -> pure $ Left (ParseErr e)
-                   Right x -> pure $ Right x
+                   Left (p,e) -> pure $ Left (ParseErr p e)
+                   Right x    -> pure $ Right x

pkg/hs-urbit/lib/Noun/Conversions.hs

@@ -1,7 +1,7 @@
 module Noun.Conversions
   ( Nullable(..), Jammed(..), AtomCell(..)
   , Word128, Word256, Word512
-  , Cord(..), Knot(..), Term(..), Tape(..)
+  , Cord(..), Knot(..), Term(..), Tape(..), Tour(..)
   , Tank(..), Tang, Plum(..)
   , Mug(..), Path(..), Ship(..)
   ) where
@@ -68,13 +68,13 @@ instance ToNoun Void where
   toNoun = absurd
 
 instance FromNoun Void where
-  parseNoun = named "Void" . fail "Can't produce void"
+  parseNoun _ = named "Void" $ fail "Can't produce void"
 
 
 -- Tour ------------------------------------------------------------------------
 
 newtype Tour = Tour [Char]
-  deriving (Eq, Ord, Show)
+  deriving newtype (Eq, Ord, Show, ToNoun, FromNoun)
 
 
 -- Double Jammed ---------------------------------------------------------------

pkg/hs-urbit/lib/Noun/Convert.hs

@@ -160,10 +160,10 @@ fromNoun n = runParser (parseNoun n) [] onFail onSuccess
     onFail p m  = Nothing
     onSuccess x = Just x
 
-fromNounErr :: FromNoun a => Noun -> Either Text a
+fromNounErr :: FromNoun a => Noun -> Either ([Text], Text) a
 fromNounErr n = runParser (parseNoun n) [] onFail onSuccess
   where
-    onFail p m  = Left (pack m)
+    onFail p m  = Left (p, pack m)
     onSuccess x = Right x
 
 data BadNoun = BadNoun [Text] String

pkg/hs-urbit/lib/UrbitPrelude.hs

@@ -2,9 +2,11 @@ module UrbitPrelude
     ( module ClassyPrelude
     , module Control.Lens
     , module Noun
+    , module Data.Void
     ) where
 
 import ClassyPrelude
 import Control.Lens  hiding (Index, cons, index, snoc, uncons, unsnoc, (<.>),
                       (<|))
 import Noun
+import Data.Void

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

@@ -5,8 +5,6 @@ module Vere.Pier.Types where
 import UrbitPrelude
 import Urbit.Time
 
-import Data.Void (Void)
-
 import qualified Vere.Ames        as Ames
 import qualified Vere.Http.Client as Client
 import qualified Vere.Http.Server as Server
@@ -22,9 +20,34 @@ newtype FileOcts = FileOcts ByteString
 newtype BigTape = BigTape Text
   deriving newtype (Eq, Ord, ToNoun, FromNoun)
 
+type Life = Noun
+type Pass = Noun
+type Turf = Noun
+type PUrl = Todo Noun
+type Seed = Todo Noun
+type Czar = Todo Noun -- Map Ship (Life, Pass)
+type Bloq = Todo Atom -- @ud
+
+newtype Todo a = Todo a
+  deriving newtype (Eq, Ord, ToNoun, FromNoun)
+
+instance Show (Todo a) where
+  show (Todo _) = "TODO"
+
+data Dawn = MkDawn
+    { dSeed :: Seed
+    , dShip :: Ship
+    , dCzar :: Czar
+    , dTurf :: [Turf]
+    , dBloq :: Bloq
+    , dNode :: PUrl
+    }
+  deriving (Eq, Ord, Show)
+
+
 data LegacyBootEvent
     = Fake Ship
-    | Dawn Void
+    | Dawn Dawn
   deriving (Eq, Ord, Show)
 
 newtype Nock = Nock Noun
@@ -69,17 +92,111 @@ data Order
     | OWork Job
   deriving (Eq, Ord, Show)
 
+newtype Octs = Octs ByteString
+  deriving newtype (Eq, Ord, Show, FromNoun, ToNoun)
+
+data ResponseHeader = ResponseHeader
+    { rhStatus  :: Word
+    , rhHeaders :: [(Text, Text)]
+    }
+  deriving (Eq, Ord, Show)
+
+data HttpEvent
+    = Start ResponseHeader (Maybe Octs) Bool
+    | Continue (Maybe Octs) Bool
+    | Cancel
+  deriving (Eq, Ord, Show)
+
+data Lane
+    = If Wen Atom Atom           --  {$if p/@da q/@ud r/@if}
+    | Is Atom (Maybe Lane) Atom  --  {$is p/@ud q/(unit lane) r/@is}
+    | Ix Wen Atom Atom           --  {$ix p/@da q/@ud r/@if}
+  deriving (Eq, Ord, Show)
+
+data ArrowKey = D | L | R | U
+  deriving (Eq, Ord, Show)
+
+data Address
+    = AIpv4 Atom -- @if
+    | AIpv6 Atom -- @is
+    | AAmes Atom -- @p
+  deriving (Eq, Ord, Show)
+
+instance ToNoun Address where
+  toNoun = \case
+    AIpv4 x -> toNoun (Cord "ipv4", x)
+    AIpv6 x -> toNoun (Cord "ipv6", x)
+    AAmes x -> toNoun (Cord "ames", x)
+
+instance FromNoun Address where
+  parseNoun n = do
+    parseNoun n >>= \case
+      (Cord "ipv4", at) -> pure (AIpv4 at)
+      (Cord "ipv6", at) -> pure (AIpv6 at)
+      (Cord "ames", at) -> pure (AAmes at)
+      _                 -> fail "Address must be either %ipv4, %ipv6, or %ames"
+
+data Belt
+    = Aro ArrowKey
+    | Bac
+    | Ctl Char
+    | Del
+    | Met Char
+    | Ret
+    | Txt Tour
+  deriving (Eq, Ord, Show)
+
+type ServerId = Atom
+
+type JSON = Todo Noun
+
+data RequestParams
+    = List [JSON]
+    | Object [(Text, JSON)]
+  deriving (Eq, Ord, Show)
+
+data HttpRequest = HttpRequest
+    { reqId       :: Text
+    , reqUrl      :: Text
+    , reqHeaders  :: [(Text, Text)]
+    , reqFinished :: Maybe Octs
+    }
+  deriving (Eq, Ord, Show)
+
 data Event
     = Veer Cord Path BigTape
     | Into Desk Bool [(Path, Maybe Mime)]
     | Whom Ship
     | Boot LegacyBootEvent
     | Wack Word512
+    | Boat
+    | Barn
+    | Born
+    | Blew Word Word
+    | Hail
+    | Wake
+    | Receive ServerId HttpEvent
+    | Request ServerId Address HttpRequest
+    | Live Text Bool Word
+    | Hear Lane Atom
+    | Belt Belt
+    | Crud Text [Tank]
   deriving (Eq, Ord, Show)
 
-data PutDel = Put | Del
+data PutDel = PDPut | PDDel
   deriving (Eq, Ord, Show)
 
+instance ToNoun PutDel where
+  toNoun = \case PDPut -> toNoun (Cord "put")
+                 PDDel -> toNoun (Cord "del")
+
+instance FromNoun PutDel where
+  parseNoun n = do
+    parseNoun n >>= \case
+      Cord "put" -> pure PDPut
+      Cord "del" -> pure PDDel
+      _          -> fail "PutDel must be either %put or %del"
+
 data RecEx = RE Word Word
   deriving (Eq, Ord, Show)
 
@@ -93,9 +210,9 @@ data Eff
     | Bbye Noun
     | Behn Noun
     | Blit [Blit]
-    | Boat Noun
+    | EBoat Noun
     | Clay Noun
-    | Crud Noun
+    --Crud Noun
     | Dirk Noun
     | Doze (Maybe Wen)
     | Ergo Noun
@@ -195,14 +312,21 @@ instance Show Nock where
 instance Show Pill where
   show (Pill x y z) = show (length x, length y, length z)
 
+deriveNoun ''ArrowKey
+deriveNoun ''Belt
 deriveNoun ''Blit
+deriveNoun ''Dawn
 deriveNoun ''Eff
 deriveNoun ''Event
+deriveNoun ''HttpEvent
+deriveNoun ''Lane
 deriveNoun ''LegacyBootEvent
 deriveNoun ''LogIdentity
 deriveNoun ''Mime
 deriveNoun ''NewtEx
 deriveNoun ''Ovum
 deriveNoun ''Pill
-deriveNoun ''PutDel
 deriveNoun ''RecEx
+deriveNoun ''ResponseHeader
+deriveNoun ''RequestParams
+deriveNoun ''HttpRequest

pkg/hs-urbit/lib/Vere/Serf.hs

@@ -15,8 +15,9 @@
 
 module Vere.Serf where
 
-import UrbitPrelude
+import UrbitPrelude hiding (fail)
 import Data.Conduit
+import Control.Monad.Fail (fail)
 
 import Data.Void
 import Noun
@@ -74,7 +75,7 @@ data SerfExn
     | BadReplacementId EventId ReplacementEv
     | UnexpectedPlay EventId Play
     | BadPleaAtom Atom
-    | BadPleaNoun Noun Text
+    | BadPleaNoun Noun [Text] Text
     | ReplacedEventDuringReplay EventId ReplacementEv
     | ReplacedEventDuringBoot   EventId ReplacementEv
     | EffectsDuringBoot         EventId [(Path, Eff)]
@@ -217,7 +218,7 @@ recvPlea :: Serf -> IO Plea
 recvPlea w = do
   a <- recvAtom w
   n <- fromRightExn (cue a) (const $ BadPleaAtom a)
-  p <- fromRightExn (fromNounErr n) (BadPleaNoun $ traceShowId n)
+  p <- fromRightExn (fromNounErr n) (\(p,m) -> BadPleaNoun (traceShowId n) p m)
 
   case p of Stdr e msg   -> do -- traceM ("[SERF]\t" <> (cordString msg))
                                recvPlea w

pkg/hs-vere/app/test/Main.hs

@@ -9,6 +9,7 @@ import Vere.Serf
 import Data.Acquire
 import Data.Conduit
 import Data.Conduit.List
+import Control.Exception hiding (evaluate)
 
 import Control.Concurrent (threadDelay)
 import System.Directory   (removeFile, doesFileExist)
@@ -57,17 +58,52 @@ tryFullReplay shipPath = do
 zod :: Ship
 zod = 0
 
+catchAny :: IO a -> (SomeException -> IO a) -> IO a
+catchAny = Control.Exception.catch
+
+tryParseEvents :: FilePath -> EventId -> IO ()
+tryParseEvents dir first = do
+    vPax <- newIORef []
+    with (Log.existing dir) $ \log -> do
+        let ident = Log.identity log
+        print ident
+        runConduit $ Log.streamEvents log first
+                  .| showEvents vPax first (fromIntegral $ lifecycleLen ident)
+    paths <- sort . ordNub <$> readIORef vPax
+    for_ paths print
+  where
+    showEvents :: IORef [Path] -> EventId -> EventId -> ConduitT Atom Void IO ()
+    showEvents vPax eId cycle = await >>= \case
+      Nothing -> print "Done!"
+      Just at -> do
+          -- print ("got event", eId)
+          n <- liftIO $ cueExn at
+          -- print ("done cue", eId)
+          when (eId > cycle) $ do
+              case fromNounErr n of
+                Left err -> print err
+                Right (mug, date, ovum) -> do
+                  evaluate $ Job eId mug $ DateOvum date ovum
+                  pure ()
+                  paths <- readIORef vPax
+                  let pax = case ovum of Ovum pax _ -> pax
+                  writeIORef vPax (pax:paths)
+                  -- print ("done from noun", eId)
+                  -- print (Job eId mug $ DateOvum date ovum)
+          unless (eId - first > 100000000) $
+              showEvents vPax (succ eId) cycle
+
 main :: IO ()
 main = do
-    let pillPath = "/home/benjamin/r/urbit/bin/ivory.pill"
+    let pillPath = "/home/benjamin/r/urbit/bin/brass.pill"
         shipPath = "/home/benjamin/r/urbit/zod/"
         ship     = zod
 
-    tryBootFromPill pillPath shipPath ship
+    tryParseEvents "/home/benjamin/r/urbit/testnet-zod/.urb/log" 1
 
-    tryResume shipPath
-
-    tryFullReplay shipPath
+    -- tryBootFromPill pillPath shipPath ship
+    -- tryResume shipPath
+    -- tryFullReplay shipPath
 
     pure ()