From 1ec1dc7ff0f705316770f787a6e6140f116c895b Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Mon, 22 Jul 2019 17:46:06 -0700 Subject: [PATCH] Some more events and requests. --- pkg/hs-urbit/lib/Noun/Conversions.hs | 15 +++++-- pkg/hs-urbit/lib/Vere/FX.hs | 66 ++++++++++++++++------------ pkg/hs-urbit/lib/Vere/Http.hs | 10 ++++- pkg/hs-urbit/lib/Vere/Http/Client.hs | 2 +- pkg/hs-urbit/lib/Vere/Ovum.hs | 38 ++++++++++------ pkg/hs-vere/app/test/Main.hs | 31 ++++++++----- 6 files changed, 100 insertions(+), 62 deletions(-) diff --git a/pkg/hs-urbit/lib/Noun/Conversions.hs b/pkg/hs-urbit/lib/Noun/Conversions.hs index 1edb6e4fdd..c810675ba6 100644 --- a/pkg/hs-urbit/lib/Noun/Conversions.hs +++ b/pkg/hs-urbit/lib/Noun/Conversions.hs @@ -6,7 +6,7 @@ module Noun.Conversions , Bytes(..), Octs(..) , Cord(..), Knot(..), Term(..), Tape(..), Tour(..) , Tank(..), Tang, Plum(..) - , Mug(..), Path(..), Ship(..) + , Mug(..), Path(..), EvilPath, Ship(..) , Lenient(..) ) where @@ -341,11 +341,17 @@ newtype Ship = Ship Word128 -- @p -- Path ------------------------------------------------------------------------ -newtype Path = Path [Knot] +newtype Path = Path { unPath :: [Knot] } deriving newtype (Eq, Ord, Semigroup, Monoid) instance Show Path where - show (Path ks) = show $ intercalate "/" ("" : ks) + show = show . intercalate "/" . ("":) . unPath + +newtype EvilPath = EvilPath { unEvilPath :: [Atom] } + deriving newtype (Eq, Ord, Semigroup, Monoid) + +instance Show EvilPath where + show = show . unEvilPath -- Mug ------------------------------------------------------------------------- @@ -602,6 +608,7 @@ instance ( FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e pure (p, q, r, s, t, u, v, w, x, y) --- Derived Instances ----------------------------------------------------------- +-- Ugg ------------------------------------------------------------------------- deriveNoun ''Path +deriveNoun ''EvilPath diff --git a/pkg/hs-urbit/lib/Vere/FX.hs b/pkg/hs-urbit/lib/Vere/FX.hs index ca74e5ac07..6aad65f907 100644 --- a/pkg/hs-urbit/lib/Vere/FX.hs +++ b/pkg/hs-urbit/lib/Vere/FX.hs @@ -5,8 +5,8 @@ import Urbit.Time import Vere.Ovum import qualified Vere.Ames as Ames -import qualified Vere.Http.Client as Client import qualified Vere.Http.Server as Server +import qualified Vere.Http as Http -------------------------------------------------------------------------------- @@ -14,44 +14,50 @@ import qualified Vere.Http.Server as Server data PutDel = PDPut | PDDel deriving (Eq, Ord, Show) -type FX = [(Path, Todo Eff)] +type FX = [(EvilPath, Todo Eff)] type Eff = AtomCell EffAtom EffCell data EffAtom = EAInit | EAVoid deriving (Eq, Ord, Show) +data Meth = MConn | MDelt | MGet | MHead | MOpts | MPost | MPut | MTrac + deriving (Eq, Ord, Show) + +data HttpOp = HttpOp Meth (NounMap Cord [Cord]) (Maybe Octs) + deriving (Eq, Ord, Show) + data EffCell - = ECHttpServer Server.Eff - | ECHttpClient Client.Eff - | ECAmes Ames.Eff - | ECBbye Noun - | ECBehn Noun + = ECAmes Ames.Eff + | ECBbye () + | ECBehn Void | ECBlit [Blit] - | ECBoat Noun - | ECClay Noun - | ECCrud Noun - | ECDirk Noun + | ECBoat + | ECClay Void + | ECCrud Void + | ECDirk Void | ECDoze (Maybe Wen) - | ECErgo Noun - | ECExit Noun - | ECFlog Noun - | ECForm Noun + | ECErgo Term [(Path, Maybe Mime)] + | ECThus Atom (Maybe (PUrl, HttpOp)) + | ECExit Void + | ECFlog Void + | ECForm Void | ECHill [Term] - | ECInit - | ECLogo Noun - | ECMass Noun - | ECNewt Noun - | ECOgre Noun - | ECSend [Blit] - | ECSync Noun - | ECTerm Noun - | ECThou Noun - | ECTurf (Nullable (PutDel, [Cord])) -- TODO Unsure - | ECVega Noun - | ECWest Noun - | ECWoot Noun - | ECSetConfig Noun + | ECLogo () + | ECMass Void + | ECNewt Void + | ECOgre Void + | ECSend Lane Bytes + | ECSync Void + | ECTerm Void + | ECThou Void + | ECTurf (Nullable (Path, Maybe Void)) + | ECVega Void + | ECWest Void + | ECWoot Void + | ECSetConfig Server.Config + | ECRequest Word Http.Request + | ECResponse Http.RawEvent deriving (Eq, Ord, Show) type Blit = AtomCell BlitAtom BlitCell @@ -75,3 +81,5 @@ deriveNoun ''EffAtom deriveNoun ''EffCell deriveNoun ''PutDel deriveNoun ''Varience +deriveNoun ''Meth +deriveNoun ''HttpOp diff --git a/pkg/hs-urbit/lib/Vere/Http.hs b/pkg/hs-urbit/lib/Vere/Http.hs index c737134fac..e2640b93ab 100644 --- a/pkg/hs-urbit/lib/Vere/Http.hs +++ b/pkg/hs-urbit/lib/Vere/Http.hs @@ -11,7 +11,7 @@ import qualified Network.HTTP.Types.Method as H -------------------------------------------------------------------------------- -data Header = Header Cord Cord +data Header = Header Cord Bytes deriving (Eq, Ord, Show) type Method = H.StdMethod @@ -30,6 +30,11 @@ data ResponseHeader = ResponseHeader } deriving (Eq, Ord, Show) +data RawEvent + = Start ResponseHeader (Maybe Octs) Bool + | Continue (Maybe Octs) Bool + | Cancel + deriving (Eq, Ord, Show) data Event = Started ResponseHeader -- [%start hdr (unit octs) ?] @@ -54,6 +59,7 @@ instance FromNoun H.StdMethod where deriveNoun ''Header deriveNoun ''ResponseHeader deriveNoun ''Event +deriveNoun ''RawEvent deriveNoun ''Request -------------------------------------------------------------------------------- @@ -62,4 +68,4 @@ convertHeaders :: [HT.Header] -> [Header] convertHeaders = fmap f where f (k, v) = Header (Cord $ decodeUtf8 $ CI.original k) - (Cord $ decodeUtf8 v) + (MkBytes v) diff --git a/pkg/hs-urbit/lib/Vere/Http/Client.hs b/pkg/hs-urbit/lib/Vere/Http/Client.hs index 5b7112205b..43e8da3374 100644 --- a/pkg/hs-urbit/lib/Vere/Http/Client.hs +++ b/pkg/hs-urbit/lib/Vere/Http/Client.hs @@ -46,7 +46,7 @@ cvtReq r = { H.method = encodeUtf8 $ tshow (method r), H.requestHeaders = headerList r <&> \(Header k v) -> (CI.mk (encodeUtf8 $ unCord k), - encodeUtf8 $ unCord v), + unBytes v), H.requestBody = H.RequestBodyBS $ case body r of Nothing -> "" diff --git a/pkg/hs-urbit/lib/Vere/Ovum.hs b/pkg/hs-urbit/lib/Vere/Ovum.hs index 76bdfa8b95..c925a2a7e5 100644 --- a/pkg/hs-urbit/lib/Vere/Ovum.hs +++ b/pkg/hs-urbit/lib/Vere/Ovum.hs @@ -81,6 +81,7 @@ deriveNoun ''JsonNode -- Dawn Records ---------------------------------------------------------------- type AtomIf = Atom +type AtomIs = Atom type Ring = Atom -- Private Key type Oath = Atom -- Signature @@ -88,7 +89,6 @@ type Pass = Atom -- Public Key type Life = Word type Turf = Path -type Czar = NounMap Ship (Life, Pass) type Bloq = Atom type Host = Either Turf AtomIf @@ -137,7 +137,7 @@ data Snap = Snap (NounMap Ship Public) data Dawn = MkDawn { dSeed :: Seed , dShip :: Ship - , dCzar :: Czar + , dCzar :: NounMap Ship (Life, Pass) , dTurf :: [Turf] , dBloq :: Bloq , dNode :: (Maybe PUrl) @@ -204,33 +204,43 @@ data HttpClient | HttpClientCrud Path Cord Tang deriving (Eq, Ord, Show) -data HttpServer - = HttpServerRequest (Atom, Word, Word, ()) ServerId Address HttpRequest - | HttpServerLive (Atom, ()) Cord (Maybe Word) - | HttpServerBorn (Atom, ()) () - | HttpServerSetConfig (Atom, ()) ServerConfig +data HttpServerReq = HttpServerReq + { hsrSecure :: Bool + , hsrAddress :: Address + , hsrRequest :: HttpRequest + } + deriving (Eq, Ord, Show) + +data HttpServer + = HttpServerRequest (Atom, Word, Word, ()) HttpServerReq + | HttpServerRequestLocal Path HttpServerReq + | HttpServerLive (Atom, ()) Atom (Maybe Word) + | HttpServerBorn (Atom, ()) () + | HttpServerSetConfig (Atom, ()) ServerConfig deriving (Eq, Ord, Show) -deriveNoun ''ServerConfig -deriveNoun ''HttpRequest deriveNoun ''Address -deriveNoun ''ResponseHeader -deriveNoun ''HttpEvent deriveNoun ''HttpClient +deriveNoun ''HttpEvent +deriveNoun ''HttpRequest deriveNoun ''HttpServer +deriveNoun ''HttpServerReq +deriveNoun ''ResponseHeader +deriveNoun ''ServerConfig -- Ames ------------------------------------------------------------------------ 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} + = If Wen Atom AtomIf + | Is Atom (Maybe Lane) AtomIs + | Ix Wen Atom AtomIf deriving (Eq, Ord, Show) data Ames = AmesHear () Lane Atom | AmesWake () () + | AmesWant Path Ship Path Noun | AmesCrud Path Cord Tang deriving (Eq, Ord, Show) diff --git a/pkg/hs-vere/app/test/Main.hs b/pkg/hs-vere/app/test/Main.hs index 74e5e41d2d..3cb0767c04 100644 --- a/pkg/hs-vere/app/test/Main.hs +++ b/pkg/hs-vere/app/test/Main.hs @@ -158,8 +158,11 @@ main = runInBoundThread $ do -- tryParseEvents "/home/benjamin/r/urbit/zod/.urb/log" 1 -- tryParseEvents "/home/benjamin/r/urbit/testnet-zod/.urb/log" 1 - tryParseFX "/home/benjamin/testnet-zod-fx" 1 10 - tryParseFX "/home/benjamin/zod-fx" 1 10 + tryParseFX "/home/benjamin/zod-fx" 1 1000 + + let good = 1400000 + + tryParseFX "/home/benjamin/testnet-zod-fx" good (good + 1000000) -- tryBootFromPill pillPath shipPath ship -- tryResume shipPath @@ -178,6 +181,8 @@ streamFX :: FilePath -> Word -> Word -> ConduitT () ByteString IO () streamFX dir first last = loop first where loop n = do + when (n `mod` 1000 == 0) $ do + print n let fil = dir <> "/" <> show n exists <- liftIO (doesFileExist fil) when (exists && n <= last) $ do @@ -185,16 +190,18 @@ streamFX dir first last = loop first loop (n+1) tryParseFXStream :: ConduitT ByteString Void IO () -tryParseFXStream = - await >>= \case - Nothing -> pure () - Just bs -> do - n <- liftIO (cueBSExn bs) - fromNounErr n & \case - Left err -> print err - Right [] -> pure () - Right (fx :: FX.FX) -> print fx - tryParseFXStream +tryParseFXStream = loop 0 + where + loop 5 = pure () + loop errors = + await >>= \case + Nothing -> pure () + Just bs -> do + n <- liftIO (cueBSExn bs) + fromNounErr n & \case + Left err -> print err >> loop (errors + 1) + Right [] -> loop errors + Right (fx :: FX.FX) -> loop errors tryCopyLog :: IO () tryCopyLog = do