Some more events and requests.

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

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

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)

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

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)
 

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