Fix segfault and handle more effects.

pkg/hs-urbit/lib/Data/Noun/Pill.hs

@@ -158,9 +158,12 @@ bytesBS = iso to from
   where
     to :: VP.Vector Word8 -> ByteString
     to (VP.Vector off sz buf) =
-        BS.copy $ BS.drop off $ unsafePerformIO $ BU.unsafePackAddressLen sz ptr
-      where
-        Prim.Addr ptr = Prim.byteArrayContents buf
+        -- TODO This still has a (small) risk of segfaulting. is still Manually copy the data onto the C heap, setup the
+        -- finalizers, and make a bytestring from that.
+        unsafePerformIO $ do
+          Prim.Addr ptr <- evaluate $ Prim.byteArrayContents buf
+          bs <- BU.unsafePackAddressLen sz ptr
+          evaluate $ force $ BS.copy $ BS.drop off bs
 
     from :: ByteString -> VP.Vector Word8
     from bs = VP.generate (length bs) (BS.index bs)

pkg/hs-urbit/lib/Data/Noun/Poet.hs

@@ -43,8 +43,17 @@ newtype Tape = Tape ByteString
   deriving newtype (Eq, Ord, Show, IsString)
 
 newtype Cord = Cord { unCord :: ByteString }
-  deriving newtype (Eq, Ord, Show, IsString)
+  deriving newtype (Eq, Ord, Show, IsString, NFData)
 
+-- Chars -----------------------------------------------------------------------
+
+instance ToNoun Char where
+  toNoun = toNoun . (fromIntegral :: Int -> Word32) . C.ord
+
+instance FromNoun Char where
+  parseNoun n = do
+    w :: Word32 <- parseNoun n
+    pure $ C.chr $ fromIntegral w
 
 -- Pretty Printing -------------------------------------------------------------
 
@@ -282,6 +291,9 @@ consName = gConsName . GHC.from
 int2Word :: Int -> Word
 int2Word = fromIntegral
 
+word2Int :: Word -> Int
+word2Int = fromIntegral
+
 instance ToNoun ByteString where
   toNoun bs = toNoun (int2Word (length bs), bs ^. from (pill . pillBS))
 
@@ -293,6 +305,14 @@ instance FromNoun Text where -- XX TODO
     Cord c <- parseNoun n
     pure (decodeUtf8Lenient c)
 
+instance FromNoun ByteString where
+  parseNoun x = do
+    (word2Int -> len, atom) <- parseNoun x
+    let bs = atom ^. pill . pillBS
+    pure $ case compare (length bs) len of
+      EQ -> bs
+      LT -> bs <> replicate (len - length bs) 0
+      GT -> take len bs
 
 --------------------------------------------------------------------------------
 
@@ -460,7 +480,10 @@ instance ToNoun Cord where
 instance FromNoun Cord where
   parseNoun n = do
     atom <- parseNoun n
-    pure $ Cord (atom ^. pill . pillBS)
+    traceM "Parsing cord"
+    let res@(Cord _) = force $ Cord (atom ^. pill . pillBS)
+    traceM "Done parsing cord"
+    pure res
 
 
 -- Tank and Plum Conversion ----------------------------------------------------
@@ -492,6 +515,13 @@ instance FromNoun Tank where
 
 -- Pair Conversion -------------------------------------------------------------
 
+instance ToNoun () where
+  toNoun () = Atom 0
+
+instance FromNoun () where
+  parseNoun (Atom 0) = pure ()
+  parseNoun x        = fail ("expecting `~`, but got " <> showNoun x)
+
 instance (ToNoun a, ToNoun b) => ToNoun (a, b) where
   toNoun (x, y) = Cell (toNoun x) (toNoun y)
 

pkg/hs-urbit/lib/Data/Noun/Poet/TH.hs

@@ -7,10 +7,11 @@ module Data.Noun.Poet.TH where
 import ClassyPrelude hiding (fromList)
 import Control.Lens
 import Data.Noun.Poet hiding (hsToHoon)
-
 import Language.Haskell.TH
 import Language.Haskell.TH.Syntax
 
+import RIO (decodeUtf8Lenient)
+
 import qualified Data.Char as C
 
 
@@ -116,13 +117,12 @@ tupFromNoun (n, tys) = LamE [VarP x] body
     convert = NoBindS $ AppE (VarE 'pure) $ applyE (ConE n) (VarE <$> vars)
     getTup  = BindS (TupP $ VarP <$> vars) $ AppE (VarE 'parseNoun) (VarE x)
 
-{-
-unexpectedTag :: [Name] -> String -> String
+unexpectedTag :: [Name] -> Exp -> Exp
 unexpectedTag expected got =
-    mconcat ["Expected one of: ", possible, " but got " <> showAtom
+    applyE (VarE 'mappend) [LitE (StringL prefix), got]
   where
     possible  = intercalate " " (('%':) . tagString <$> expected)
--}
+    prefix    = "Expected one of: " <> possible <> " but got %"
 
 sumFromNoun :: [ConInfo] -> Exp
 sumFromNoun cons = LamE [VarP x] (DoE [getHead, getTag, examine])
@@ -143,8 +143,10 @@ sumFromNoun cons = LamE [VarP x] (DoE [getHead, getTag, examine])
                            in Match (LitP $ tagLit n) (NormalB body) []
 
     fallback  = Match WildP (NormalB $ AppE (VarE 'fail) matchFail) []
-    matchFail = LitE $ StringL ("Expected one of: " <> possible)
-    possible  = intercalate " " (('%':) . tagString . fst <$> cons)
+    matchFail = unexpectedTag (fst <$> cons)
+              $ AppE (VarE 'unpack)
+              $ AppE (VarE 'decodeUtf8Lenient)
+              $ VarE c
 
 --------------------------------------------------------------------------------
 

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

@@ -6,32 +6,32 @@ import ClassyPrelude
 import Data.Noun
 import Data.Noun.Atom
 import Data.Noun.Poet
+import Data.Noun.Poet.TH
 
 import qualified Data.CaseInsensitive as CI
 import qualified Network.HTTP.Types as HT
 import qualified Network.HTTP.Types.Method as H
 
+--------------------------------------------------------------------------------
+
 data Header = Header Text Text
-  deriving (Eq, Ord, Show, Generic, ToNoun)
+  deriving (Eq, Ord, Show)
 
 type Method = H.StdMethod
 
-instance ToNoun H.StdMethod where
-  toNoun = toNoun . Cord . encodeUtf8 . tshow
-
 data Request = Request
     { method     :: Method
     , url        :: Text
     , headerList :: [Header]
     , body       :: Maybe ByteString
     }
-  deriving (Eq, Ord, Show, Generic, ToNoun)
+  deriving (Eq, Ord, Show)
 
 data ResponseHeader = ResponseHeader
      { statusCode :: Word
      , headers :: [Header]
      }
-  deriving (Eq, Ord, Show, Generic, ToNoun)
+  deriving (Eq, Ord, Show)
 
 
 data Event
@@ -40,8 +40,26 @@ data Event
     | Done                   -- [%continue ~ %.y]
     | Canceled               -- %cancel
     | Failed Text            -- %cancel
-  deriving (Eq, Ord, Show, Generic, ToNoun)
+  deriving (Eq, Ord, Show)
 
+--------------------------------------------------------------------------------
+
+instance ToNoun H.StdMethod where
+  toNoun = toNoun . Cord . H.renderStdMethod
+
+instance FromNoun H.StdMethod where
+  parseNoun n = do
+    Cord m <- parseNoun n
+    case H.parseMethod m of
+      Left bs -> fail ("Unexpected method: " <> unpack (decodeUtf8 bs))
+      Right m -> pure m
+
+deriveNoun ''Header
+deriveNoun ''ResponseHeader
+deriveNoun ''Event
+deriveNoun ''Request
+
+--------------------------------------------------------------------------------
 
 convertHeaders :: [HT.Header] -> [Header]
 convertHeaders = fmap f

pkg/hs-urbit/lib/Vere/Http/Client.hs

@@ -8,13 +8,14 @@ module Vere.Http.Client where
 import ClassyPrelude
 import Vere.Http
 import Data.Noun.Poet
+import Data.Noun.Poet.TH
 
 import qualified Data.CaseInsensitive as CI
 import qualified Network.HTTP.Types as HT
 import qualified Network.HTTP.Client as H
 
 
---------------------------------------------------------------------------------
+-- Types -----------------------------------------------------------------------
 
 type ReqId = Word
 
@@ -23,7 +24,7 @@ data Ev = Receive ReqId Event -- [%receive @ todo]
 data Eff
     = NewReq ReqId Request -- [%request @ todo]
     | CancelReq ReqId      -- [%cancel-request @]
-  deriving (Eq, Ord, Show, Generic, ToNoun)
+  deriving (Eq, Ord, Show)
 
 data State = State
   { sManager :: H.Manager
@@ -31,6 +32,12 @@ data State = State
   , sChan    :: MVar Ev
   }
 
+
+-- Instances -------------------------------------------------------------------
+
+deriveNoun ''Eff
+
+
 --------------------------------------------------------------------------------
 
 cvtReq :: Request -> Maybe H.Request

pkg/hs-urbit/lib/Vere/Http/Server.hs

@@ -6,6 +6,7 @@ import ClassyPrelude
 import Vere.Http
 import Data.Noun.Atom
 import Data.Noun.Poet
+import Data.Noun.Poet.TH
 import Control.Lens
 
 import Control.Concurrent (ThreadId, killThread, forkIO)
@@ -24,13 +25,13 @@ type RequestId = Word
 data Foo = A | B | C
 
 data Eff = Eff ServerId ConnectionId RequestId ServerRequest
-  deriving (Eq, Ord, Show, Generic, ToNoun)
+  deriving (Eq, Ord, Show)
 
 -- | An http server effect is configuration, or it sends an outbound response
 data ServerRequest
   = SetConfig Config
   | Response Event
-  deriving (Eq, Ord, Show, Generic, ToNoun)
+  deriving (Eq, Ord, Show)
 
 data Config = Config
     { secure   :: Maybe (Key, Cert)
@@ -38,17 +39,21 @@ data Config = Config
     , log      :: Bool
     , redirect :: Bool
     }
-  deriving (Eq, Ord, Show, Generic, ToNoun)
-
+  deriving (Eq, Ord, Show)
 
 -- Note: We need to parse PEM-encoded RSA private keys and cert or cert chain
 -- from Wain
 type Key = PEM
 type Cert = PEM
-data Wain = Wain [Text]
+newtype Wain = Wain [Text]
+  deriving newtype (Eq, Ord, Show, ToNoun, FromNoun)
 
 newtype PEM = PEM Cord
-  deriving newtype (Eq, Ord, Show, ToNoun)
+  deriving newtype (Eq, Ord, Show, ToNoun, FromNoun)
+
+deriveNoun ''ServerRequest
+deriveNoun ''Config
+deriveNoun ''Eff
 
 data ClientResponse
   = Progress ResponseHeader Int (Maybe Int) (Maybe ByteString)

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

@@ -11,8 +11,8 @@ import Urbit.Time
 
 import RIO (decodeUtf8Lenient)
 
-import qualified Vere.Http.Server as Server
 import qualified Vere.Http.Client as Client
+import qualified Vere.Http.Server as Server
 
 --------------------------------------------------------------------------------
 
@@ -36,13 +36,6 @@ data RecEx = RE Word Word
 data NewtEx = NE Word
   deriving (Eq, Ord, Show)
 
-
-deriveNoun ''Event
-deriveNoun ''PutDel
-deriveNoun ''EffBs
-deriveNoun ''RecEx
-deriveNoun ''NewtEx
-
 data Eff
     = HttpServer Server.Eff
     | HttpClient Client.Eff
@@ -54,32 +47,37 @@ data Eff
     | Ames Void
     | Init Void
     | Term Void
+    | Blit [Blit]
     | Hill [Term]
     | Turf (Maybe (PutDel, [Text])) -- TODO Unsure
-  deriving (Eq, Ord, Show, Generic, ToNoun)
+  deriving (Eq, Ord, Show)
 
-instance FromNoun Eff where
-  parseNoun = \case
-    Atom _ ->
-      fail "Eff: Expecting cell, but got an atom"
-    Cell h t ->
-      parseNoun h >>= \case
-        Cord "hill" -> do
-          paths <- parseNoun t
-          pure (Hill paths)
-        Cord "turf" -> do
-          arg <- parseNoun t
-          pure (Turf arg)
-        Cord nm -> do
-          fail ("Eff: unknown effect " <> unpack (decodeUtf8Lenient nm))
+newtype Path = Path [Knot]
+  deriving newtype (Eq, Ord, Show, ToNoun, FromNoun)
+
+data Blit
+    = Bel
+    | Clr
+    | Hop Word64
+    | Lin [Char]
+    | Mor
+    | Sag Path Noun
+    | Sav Path Atom
+    | Url Text
+  deriving (Eq, Ord, Show)
+
+deriveNoun ''Blit
+deriveNoun ''Eff
+deriveNoun ''Event
+deriveNoun ''PutDel
+deriveNoun ''EffBs
+deriveNoun ''RecEx
+deriveNoun ''NewtEx
 
 data Varience = Gold | Iron | Lead
 
 type Perform = Eff -> IO ()
 
-newtype Path = Path [Knot]
-  deriving newtype (Eq, Ord, Show, ToNoun, FromNoun)
-
 data Ovum = Ovum Path Event
   deriving (Eq, Ord, Show, Generic, ToNoun)
 

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

@@ -89,24 +89,19 @@ type Play = Maybe (EventId, Mug, ShipId)
 data Plea
     = Play Play
     | Work EventId Mug Job
-    | Done EventId Mug [Either Text (Path, Eff)]
+    | Done EventId Mug [(Path, Eff)]
     | Stdr EventId Cord
     | Slog EventId Word32 Tank
   deriving (Eq, Show)
 
-fromRight (Right x) = x
-
 instance ToNoun Plea where
   toNoun = \case
     Play p     -> toNoun (Cord "play", p)
     Work i m j -> toNoun (Cord "work", i, m, j)
-    Done i m o -> toNoun (Cord "done", i, m, fromRight <$> o)
+    Done i m o -> toNoun (Cord "done", i, m, o)
     Stdr i msg -> toNoun (Cord "stdr", i, msg)
     Slog i p t -> toNoun (Cord "slog", i, p, t)
 
-instance FromNoun (Either Text (Path, Eff)) where
-  parseNoun = pure . fromNounErr
-
 instance FromNoun Plea where
   parseNoun n =
     parseNoun n >>= \case
@@ -125,7 +120,7 @@ type NextEventId = Word64
 type SerfState = (EventId, Mug)
 
 type ReplacementEv = (EventId, Mug, Job)
-type WorkResult  = (EventId, Mug, [Either Text (Path, Eff)])
+type WorkResult  = (EventId, Mug, [(Path, Eff)])
 type SerfResp    = (Either ReplacementEv WorkResult)
 
 -- Exceptions ------------------------------------------------------------------