From 537b88722a0197b438eb06532dfa146d6791bf73 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Fri, 19 Jul 2019 16:18:58 -0700 Subject: [PATCH] Figure out what all the events types are in the testnet zod, and parse them. --- pkg/hs-urbit/lib/Noun.hs | 6 +- pkg/hs-urbit/lib/Noun/Conversions.hs | 6 +- pkg/hs-urbit/lib/Noun/Convert.hs | 4 +- pkg/hs-urbit/lib/UrbitPrelude.hs | 2 + pkg/hs-urbit/lib/Vere/Pier/Types.hs | 138 +++++++++++++++++++++++++-- pkg/hs-urbit/lib/Vere/Serf.hs | 7 +- pkg/hs-vere/app/test/Main.hs | 46 ++++++++- 7 files changed, 186 insertions(+), 23 deletions(-) diff --git a/pkg/hs-urbit/lib/Noun.hs b/pkg/hs-urbit/lib/Noun.hs index 4a559a361e..ba5a8ca971 100644 --- a/pkg/hs-urbit/lib/Noun.hs +++ b/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 diff --git a/pkg/hs-urbit/lib/Noun/Conversions.hs b/pkg/hs-urbit/lib/Noun/Conversions.hs index 2ece096c88..ae5ea63076 100644 --- a/pkg/hs-urbit/lib/Noun/Conversions.hs +++ b/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 --------------------------------------------------------------- diff --git a/pkg/hs-urbit/lib/Noun/Convert.hs b/pkg/hs-urbit/lib/Noun/Convert.hs index 0bb4d92849..5cd6eb449a 100644 --- a/pkg/hs-urbit/lib/Noun/Convert.hs +++ b/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 diff --git a/pkg/hs-urbit/lib/UrbitPrelude.hs b/pkg/hs-urbit/lib/UrbitPrelude.hs index 59344b52e6..0e246b2115 100644 --- a/pkg/hs-urbit/lib/UrbitPrelude.hs +++ b/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 diff --git a/pkg/hs-urbit/lib/Vere/Pier/Types.hs b/pkg/hs-urbit/lib/Vere/Pier/Types.hs index 9cfeacc0e4..5ff23cb6a3 100644 --- a/pkg/hs-urbit/lib/Vere/Pier/Types.hs +++ b/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 diff --git a/pkg/hs-urbit/lib/Vere/Serf.hs b/pkg/hs-urbit/lib/Vere/Serf.hs index fc66c964e2..8feee5614f 100644 --- a/pkg/hs-urbit/lib/Vere/Serf.hs +++ b/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 diff --git a/pkg/hs-vere/app/test/Main.hs b/pkg/hs-vere/app/test/Main.hs index 611d8fe67b..83024733b9 100644 --- a/pkg/hs-vere/app/test/Main.hs +++ b/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 ()