diff --git a/pkg/hs-urbit/lib/Data/Noun/Pill.hs b/pkg/hs-urbit/lib/Data/Noun/Pill.hs index 20e4dd77b8..b85a9906f9 100644 --- a/pkg/hs-urbit/lib/Data/Noun/Pill.hs +++ b/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) diff --git a/pkg/hs-urbit/lib/Data/Noun/Poet.hs b/pkg/hs-urbit/lib/Data/Noun/Poet.hs index 8da625ee86..27e140c1a8 100644 --- a/pkg/hs-urbit/lib/Data/Noun/Poet.hs +++ b/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) diff --git a/pkg/hs-urbit/lib/Data/Noun/Poet/TH.hs b/pkg/hs-urbit/lib/Data/Noun/Poet/TH.hs index a8a9fecbe9..38576d43de 100644 --- a/pkg/hs-urbit/lib/Data/Noun/Poet/TH.hs +++ b/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 -------------------------------------------------------------------------------- diff --git a/pkg/hs-urbit/lib/Vere/Http.hs b/pkg/hs-urbit/lib/Vere/Http.hs index f0e6613458..4fe12d3347 100644 --- a/pkg/hs-urbit/lib/Vere/Http.hs +++ b/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 diff --git a/pkg/hs-urbit/lib/Vere/Http/Client.hs b/pkg/hs-urbit/lib/Vere/Http/Client.hs index 34b610be1c..44b553a91b 100644 --- a/pkg/hs-urbit/lib/Vere/Http/Client.hs +++ b/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 diff --git a/pkg/hs-urbit/lib/Vere/Http/Server.hs b/pkg/hs-urbit/lib/Vere/Http/Server.hs index 7e65bc7f8f..c47bfe63b9 100644 --- a/pkg/hs-urbit/lib/Vere/Http/Server.hs +++ b/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) diff --git a/pkg/hs-urbit/lib/Vere/Pier/Types.hs b/pkg/hs-urbit/lib/Vere/Pier/Types.hs index 3fb0e9ce4c..469fd26716 100644 --- a/pkg/hs-urbit/lib/Vere/Pier/Types.hs +++ b/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) diff --git a/pkg/hs-urbit/lib/Vere/Serf.hs b/pkg/hs-urbit/lib/Vere/Serf.hs index b1b382778f..e871644804 100644 --- a/pkg/hs-urbit/lib/Vere/Serf.hs +++ b/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 ------------------------------------------------------------------