urbit/shrub
1
1
Fork 0
mirror of https://github.com/urbit/shrub.git synced 2024-12-20 17:32:11 +03:00
Code Issues Packages Projects Releases Wiki Activity

Merge remote-tracking branch 'origin/master' into release/next-vere

Browse Source
This commit is contained in:
Philip Monk 2021-01-29 14:49:43 -08:00
commit f7697719fb
No known key found for this signature in database
GPG Key ID: B66E1F02604E44EC
24 changed files with 407 additions and 218 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
default.nix
View File

@ -155,8 +155,7 @@ let
contents = {
"${name}/urbit" = "${urbit}/bin/urbit";
"${name}/urbit-worker" = "${urbit}/bin/urbit-worker";
# temporarily removed for compatibility reasons
# "${name}/urbit-king" = "${urbit-king}/bin/urbit-king";
"${name}/urbit-king" = "${urbit-king}/bin/urbit-king";
};
};

34
pkg/hs/urbit-king/lib/Urbit/Arvo/Common.hs
View File

@ -12,6 +12,7 @@
-}
module Urbit.Arvo.Common
( KingId(..), ServId(..)
, Vere(..), Wynn(..)
, Json, JsonNode(..)
, Desk(..), Mime(..)
, Port(..), Turf(..)
@ -21,9 +22,10 @@ module Urbit.Arvo.Common
, AmesDest, Ipv4(..), Ipv6(..), Patp(..), Galaxy, AmesAddress(..)
) where
import Urbit.Prelude hiding (Term)
import Urbit.Prelude
import Control.Monad.Fail (fail)
import Data.Bits
import qualified Network.HTTP.Types.Method as H
import qualified Urbit.Ob as Ob
@ -45,6 +47,25 @@ newtype KingId = KingId { unKingId :: UV }
newtype ServId = ServId { unServId :: UV }
deriving newtype (Eq, Ord, Show, Num, Enum, Integral, Real, FromNoun, ToNoun)
-- Arvo Version Negotiation ----------------------------------------------------
-- Information about the king runtime passed to Arvo.
data Vere = Vere { vereName :: Term,
vereRev :: [Cord],
vereWynn :: Wynn }
deriving (Eq, Ord, Show)
instance ToNoun Vere where
toNoun Vere{..} = toNoun ((vereName, vereRev), vereWynn)
instance FromNoun Vere where
parseNoun n = named "Vere" $ do
((vereName, vereRev), vereWynn) <- parseNoun n
pure $ Vere {..}
-- A list of names and their kelvin numbers, used in version negotiations.
newtype Wynn = Wynn { unWynn :: [(Term, Word)] }
deriving newtype (Eq, Ord, Show, FromNoun, ToNoun)
-- Http Common -----------------------------------------------------------------
@ -112,7 +133,7 @@ deriveNoun ''HttpServerConf
-- Desk and Mime ---------------------------------------------------------------
newtype Desk = Desk { unDesk :: Cord }
deriving newtype (Eq, Ord, Show, ToNoun, FromNoun)
deriving newtype (Eq, Ord, Show, ToNoun, FromNoun, IsString)
data Mime = Mime Path File
deriving (Eq, Ord, Show)
@ -146,7 +167,14 @@ newtype Port = Port { unPort :: Word16 }
-- @if
newtype Ipv4 = Ipv4 { unIpv4 :: Word32 }
deriving newtype (Eq, Ord, Show, Enum, Real, Integral, Num, ToNoun, FromNoun)
deriving newtype (Eq, Ord, Enum, Real, Integral, Num, ToNoun, FromNoun)
instance Show Ipv4 where
show (Ipv4 i) =
show ((shiftL i 24) .&. 0xff) ++ "." ++
show ((shiftL i 16) .&. 0xff) ++ "." ++
show ((shiftL i 8) .&. 0xff) ++ "." ++
show (i .&. 0xff)
-- @is
newtype Ipv6 = Ipv6 { unIpv6 :: Word128 }

18
pkg/hs/urbit-king/lib/Urbit/Arvo/Effect.hs
View File

@ -18,7 +18,7 @@ import Urbit.Arvo.Common (KingId(..), ServId(..))
import Urbit.Arvo.Common (Header, HttpEvent, HttpServerConf, Method, Mime)
import Urbit.Arvo.Common (AmesDest, Turf)
import Urbit.Arvo.Common (ReOrg(..), reorgThroughNoun)
import Urbit.Arvo.Common (Desk)
import Urbit.Arvo.Common (Desk, Wynn)
-- Newt Effects ----------------------------------------------------------------
@ -259,20 +259,32 @@ data Ef
= EfVane VaneEf
| EfVega Cord EvilPath -- second path component, rest of path
| EfExit Cord EvilPath -- second path component, rest of path
| EfWend Wynn
deriving (Eq, Ord, Show)
-- XX HACK
clip :: Noun -> Noun
clip (C (C _ x) y) = C x y
clip _ = error "misclip"
tack :: Noun -> Noun
tack (C x y) = C (C (A 0) x) y
tack _ = error "mistack"
instance ToNoun Ef where
toNoun = \case
toNoun = clip . \case
EfVane v -> toNoun $ reorgThroughNoun ("", v)
EfExit s p -> toNoun $ ReOrg "" s "exit" p (A 0)
EfVega s p -> toNoun $ ReOrg "" s "vega" p (A 0)
EfWend w -> toNoun $ reorgThroughNoun ("", w)
instance FromNoun Ef where
parseNoun = parseNoun >=> \case
parseNoun = tack >>> parseNoun >=> \case
ReOrg "" s "exit" p (A 0) -> pure (EfExit s p)
ReOrg "" s "exit" p _ -> fail "%exit effect expects nil value"
ReOrg "" s "vega" p (A 0) -> pure (EfVega s p)
ReOrg "" s "vega" p _ -> fail "%vega effect expects nil value"
ReOrg "" s "wend" p val -> EfWend <$> parseNoun val
ReOrg "" s tag p val -> EfVane <$> parseNoun (toNoun (s, tag, p, val))
ReOrg _ _ _ _ _ -> fail "Non-empty first path-element"

59
pkg/hs/urbit-king/lib/Urbit/Arvo/Event.hs
View File

@ -9,10 +9,10 @@
-}
module Urbit.Arvo.Event where
import Urbit.Prelude hiding (Term)
import Urbit.Prelude
import Control.Monad.Fail (fail)
import Urbit.Arvo.Common (KingId(..), ServId(..))
import Urbit.Arvo.Common (KingId(..), ServId(..), Vere(..))
import Urbit.Arvo.Common (Desk, Mime)
import Urbit.Arvo.Common (Header(..), HttpEvent)
import Urbit.Arvo.Common (AmesDest, Ipv4, Ipv6, Port, Turf)
@ -218,9 +218,12 @@ instance Show Entropy where
data ArvoEv
= ArvoEvWhom () Ship
| ArvoEvWack () Entropy
| ArvoEvWarn Path Noun
| ArvoEvWyrd () Vere
| ArvoEvCrud Path Noun
| ArvoEvVeer Atom Noun
| ArvoEvTrim UD
| ArvoEvWhat [Noun]
| ArvoEvWhey ()
| ArvoEvVerb (Maybe Bool)
deriving (Eq, Ord, Show)
deriveNoun ''ArvoEv
@ -318,50 +321,29 @@ data BlipEv
deriveNoun ''BlipEv
-- Boot Events -----------------------------------------------------------------
data Vane
= VaneVane VaneEv
| VaneZuse ZuseEv
deriving (Eq, Ord, Show)
data VaneName
= Ames | Behn | Clay | Dill | Eyre | Ford | Gall | Iris | Jael
deriving (Eq, Ord, Show, Enum, Bounded)
data ZuseEv
= ZEVeer () Cord Path BigCord
| ZEVoid Void
deriving (Eq, Ord, Show)
data VaneEv
= VEVeer (VaneName, ()) Cord Path BigCord
| VEVoid Void
deriving (Eq, Ord, Show)
deriveNoun ''Vane
deriveNoun ''VaneName
deriveNoun ''VaneEv
deriveNoun ''ZuseEv
-- The Main Event Type ---------------------------------------------------------
data Ev
= EvBlip BlipEv
| EvVane Vane
deriving (Eq, Show)
instance ToNoun Ev where
toNoun = \case
EvBlip v -> toNoun $ reorgThroughNoun (Cord "", v)
EvVane v -> toNoun $ reorgThroughNoun (Cord "vane", v)
toNoun = toNoun . \case
EvBlip v@BlipEvAmes{} -> reorgThroughNoun ("ames", v)
EvBlip v@BlipEvArvo{} -> reorgThroughNoun ("", v)
EvBlip v@BlipEvBehn{} -> reorgThroughNoun ("behn", v)
EvBlip v@BlipEvBoat{} -> reorgThroughNoun ("clay", v)
EvBlip v@BlipEvHttpClient{} -> reorgThroughNoun ("iris", v)
EvBlip v@BlipEvHttpServer{} -> reorgThroughNoun ("eyre", v)
EvBlip v@BlipEvNewt{} -> reorgThroughNoun ("ames", v)
EvBlip v@BlipEvSync{} -> reorgThroughNoun ("clay", v)
EvBlip v@BlipEvTerm{} -> reorgThroughNoun ("dill", v)
-- XX We really should check the first path element, but since this is used only
-- in the event browser, which otherwise is broken, I don't care right now.
instance FromNoun Ev where
parseNoun = parseNoun >=> \case
ReOrg "" s t p v -> fmap EvBlip $ parseNoun $ toNoun (s,t,p,v)
ReOrg "vane" s t p v -> fmap EvVane $ parseNoun $ toNoun (s,t,p,v)
ReOrg _ _ _ _ _ -> fail "First path-elem must be ?($ %vane)"
ReOrg _ s t p v -> fmap EvBlip $ parseNoun $ toNoun (s,t,p,v)
-- Short Event Names -----------------------------------------------------------
@ -373,7 +355,6 @@ instance FromNoun Ev where
-}
getSpinnerNameForEvent :: Ev -> Maybe Text
getSpinnerNameForEvent = \case
EvVane _ -> Nothing
EvBlip b -> case b of
BlipEvAmes _ -> Just "ames"
BlipEvArvo _ -> Just "arvo"

18
pkg/hs/urbit-king/lib/Urbit/King/App.hs
View File

@ -4,6 +4,7 @@
module Urbit.King.App
( KingEnv
, runKingEnvStderr
, runKingEnvStderrRaw
, runKingEnvLogFile
, runKingEnvNoLog
, kingEnvKillSignal
@ -29,6 +30,7 @@ where
import Urbit.King.Config
import Urbit.Prelude
import RIO (logGeneric)
import System.Directory ( createDirectoryIfMissing
, getXdgDirectory
, XdgDirectory(XdgCache)
@ -90,6 +92,22 @@ runKingEnvStderr verb lvl inner = do
<&> setLogMinLevel lvl
withLogFunc logOptions $ \logFunc -> runKingEnv logFunc logFunc inner
runKingEnvStderrRaw :: Bool -> LogLevel -> RIO KingEnv a -> IO a
runKingEnvStderrRaw verb lvl inner = do
logOptions <-
logOptionsHandle stderr verb
<&> setLogUseTime True
<&> setLogUseLoc False
<&> setLogMinLevel lvl
withLogFunc logOptions $ \logFunc ->
let lf = wrapCarriage logFunc
in runKingEnv lf lf inner
-- XX loses callstack
wrapCarriage :: LogFunc -> LogFunc
wrapCarriage lf = mkLogFunc $ \_ ls ll bldr ->
runRIO lf $ logGeneric ls ll (bldr <> "\r")
runKingEnvLogFile :: Bool -> LogLevel -> Maybe FilePath -> RIO KingEnv a -> IO a
runKingEnvLogFile verb lvl fileM inner = do
logFile <- case fileM of

7
pkg/hs/urbit-king/lib/Urbit/King/Main.hs
View File

@ -382,7 +382,7 @@ replayPartEvs top last = do
{-|
Interesting
-}
testPill :: HasLogFunc e => FilePath -> Bool -> Bool -> RIO e ()
testPill :: HasKingEnv e => FilePath -> Bool -> Bool -> RIO e ()
testPill pax showPil showSeq = do
logInfo "Reading pill file."
pillBytes <- readFile pax
@ -678,10 +678,13 @@ main = do
runKingEnv args log =
let
verb = verboseLogging args
runStderr = case args of
CLI.CmdRun {} -> runKingEnvStderrRaw
_ -> runKingEnvStderr
CLI.Log {..} = log
in case logTarget lTarget args of
CLI.LogFile f -> runKingEnvLogFile verb lLevel f
CLI.LogStderr -> runKingEnvStderr verb lLevel
CLI.LogStderr -> runStderr verb lLevel
CLI.LogOff -> runKingEnvNoLog
setupSignalHandlers = do

36
pkg/hs/urbit-king/lib/Urbit/King/Scry.hs
View File

@ -2,30 +2,32 @@
Scry helpers
-}
module Urbit.King.Scry (scryNow) where
module Urbit.King.Scry
( scryNow
, module Urbit.Vere.Pier.Types
)
where
import Urbit.Prelude
import Urbit.Vere.Serf.Types
import qualified Urbit.Noun.Time as Time
import Urbit.Arvo.Common (Desk)
import Urbit.Vere.Pier.Types (ScryFunc)
scryNow :: forall e n
. (HasLogFunc e, FromNoun n)
=> (Time.Wen -> Gang -> Path -> IO (Maybe (Term, Noun)))
-> Text -- ^ vane + care as two-letter string
-> Ship -- ^ ship in scry path, usually the local ship
-> Text -- ^ desk in scry path
=> ScryFunc
-> Term -- ^ vane + care as two-letter string
-> Desk -- ^ desk in scry path
-> [Text] -- ^ resource path to scry for
-> RIO e (Maybe n)
scryNow scry vare ship desk path = do
env <- ask
wen <- io Time.now
let wan = tshow $ Time.MkDate wen
let pax = Path $ fmap MkKnot $ vare : (tshow ship) : desk : wan : path
io (scry wen Nothing pax) >>= \case
Just (_, fromNoun @n -> Just v) -> pure $ Just v
Just (_, n) -> do
logError $ displayShow ("uncanny scry result", vare, pax, n)
pure Nothing
Nothing -> pure Nothing
scryNow scry vare desk path =
io (scry Nothing (EachNo $ DemiOnce vare desk (Path $ MkKnot <$> path)))
>>= \case
Just ("omen", fromNoun @(Path, Term, n) -> Just (_,_,v)) -> pure $ Just v
Just (_, fromNoun @n -> Just v) -> pure $ Just v
Just (_, n) -> do
logError $ displayShow ("uncanny scry result", vare, path, n)
pure Nothing
Nothing -> pure Nothing

14
pkg/hs/urbit-king/lib/Urbit/Vere/Ames.hs
View File

@ -26,8 +26,6 @@ import Urbit.Vere.Ames.DNS (galaxyPort, resolvServ)
import Urbit.Vere.Ames.UDP (UdpServ(..), fakeUdpServ, realUdpServ)
import Urbit.Vere.Stat (AmesStat(..), bump, bump')
import qualified Urbit.Noun.Time as Time
-- Constants -------------------------------------------------------------------
@ -143,7 +141,7 @@ ames'
=> Ship
-> Bool
-> AmesStat
-> (Time.Wen -> Gang -> Path -> IO (Maybe (Term, Noun)))
-> ScryFunc
-> (Text -> RIO e ())
-> RIO e ([Ev], RAcquire e (DriverApi NewtEf))
ames' who isFake stat scry stderr = do
@ -198,7 +196,7 @@ ames
-> Ship
-> Bool
-> AmesStat
-> (Time.Wen -> Gang -> Path -> IO (Maybe (Term, Noun)))
-> ScryFunc
-> (EvErr -> STM PacketOutcome)
-> (Text -> RIO e ())
-> ([Ev], RAcquire e (NewtEf -> IO ()))
@ -269,7 +267,6 @@ ames env who isFake stat scry enqueueEv stderr = (initialEvents, runAmes)
-- port number, host address, bytestring
(p, a, b) <- atomically (bump' asRcv >> usRecv)
ver <- readTVarIO vers
case decode b of
Right (pkt@Packet {..}) | ver == Nothing || ver == Just pktVersion -> do
logDebug $ displayShow ("ames: bon packet", pkt, showUD $ bytesAtom b)
@ -284,7 +281,8 @@ ames env who isFake stat scry enqueueEv stderr = (initialEvents, runAmes)
-> do
bump asFwd
forward dest $ encode pkt
{ pktOrigin = pktOrigin <|> Just (ipDest p a) }
{ pktOrigin = pktOrigin
<|> Just (AAIpv4 (Ipv4 a) (fromIntegral p)) }
where
notSelf (EachYes g) = who /= Ship (fromIntegral g)
notSelf (EachNo _) = True
@ -362,12 +360,12 @@ ames env who isFake stat scry enqueueEv stderr = (initialEvents, runAmes)
EachNo addr -> to (ipv4Addr addr)
scryVersion :: HasLogFunc e => RIO e (Maybe Version)
scryVersion = scryNow scry "ax" who "" ["protocol", "version"]
scryVersion = scryNow scry "ax" "" ["protocol", "version"]
scryLane :: HasLogFunc e
=> Ship
-> RIO e (Maybe [AmesDest])
scryLane ship = scryNow scry "ax" who "" ["peers", tshow ship, "forward-lane"]
scryLane ship = scryNow scry "ax" "" ["peers", tshow ship, "forward-lane"]
ipv4Addr (Jammed (AAVoid v )) = absurd v
ipv4Addr (Jammed (AAIpv4 a p)) = SockAddrInet (fromIntegral p) (unIpv4 a)

170
pkg/hs/urbit-king/lib/Urbit/Vere/Ames/Packet.hs
View File

@ -9,18 +9,19 @@ import Urbit.Prelude
import Control.Monad.Fail
import Data.Bits
import Data.LargeWord
import Data.List (genericIndex)
import Data.Serialize
import Urbit.Arvo (AmesDest)
import Urbit.Arvo (AmesAddress(..), Ipv4(..), Port(..))
data Packet = Packet
{ pktVersion :: Word8
, pktEncrypted :: Bool
--
, pktSndr :: Ship
, pktRcvr :: Ship
, pktOrigin :: Maybe AmesDest
, pktContent :: Bytes
{ pktVersion :: Word3
, pktSndr :: Ship
, pktRcvr :: Ship
, pktSndrTick :: Word4
, pktRcvrTick :: Word4
, pktOrigin :: Maybe AmesAddress
, pktContent :: ByteString
}
deriving Eq
@ -28,73 +29,140 @@ instance Show Packet where
show Packet {..}
= "Packet {pktVersion = "
<> show pktVersion
<> ", pktEncrypted = "
<> show pktEncrypted
<> ", pktSndr = "
<> show pktSndr
<> ", pktRcvr = "
<> show pktRcvr
<> ", pktSndrTick = "
<> show pktSndrTick
<> ", pktRcvrTick = "
<> show pktRcvrTick
<> ", pktOrigin = "
<> show pktOrigin
<> ", pktContent = "
<> showUD (bytesAtom $ unBytes pktContent)
<> showUD (bytesAtom pktContent)
<> "}"
{-
-- Wire format
data PacketHeader = PacketHeader
{ pktIsAmes :: Bool -- sim_o
, pktVersion :: Word3 -- ver_y
, pktSndrClass :: ShipClass -- sac_y
, pktRcvrClass :: ShipClass -- rac_y
, pktChecksum :: Word20 -- mug_l
, pktIsRelayed :: Bool -- rel_o
}
deriving Eq
data PacketBody = PacketBody
{ pktSndr :: Ship -- sen_d
, pktRcvr :: Ship -- rec_d
, pktSndrTick :: Word4 -- sic_y
, pktRcvrTick :: Word4 -- ric_y
, pktContent :: ByteString -- (con_s, con_y)
, pktOrigin :: Maybe AmesAddress -- rog_d
}
deriving Eq
-}
type Word3 = Word8
type Word4 = Word8
type Word20 = Word32
data ShipClass
= Lord
| Planet
| Moon
| Comet
deriving (Eq, Show)
muk :: ByteString -> Word20
muk bs = mugBS bs .&. (2 ^ 20 - 1)
-- XX check this
getAmesAddress :: Get AmesAddress
getAmesAddress = AAIpv4 <$> (Ipv4 <$> getWord32le) <*> (Port <$> getWord16le)
putAmesAddress :: Putter AmesAddress
putAmesAddress = \case
AAIpv4 (Ipv4 ip) (Port port) -> putWord32le ip >> putWord16le port
instance Serialize Packet where
get = do
-- header
head <- getWord32le
let pktVersion = head .&. 0b111 & fromIntegral
let checksum = shiftR head 3 .&. (2 ^ 20 - 1)
let sndrRank = shiftR head 23 .&. 0b11
let rcvrRank = shiftR head 25 .&. 0b11
let pktEncrypted = testBit head 27 & not -- loobean
-- verify checksum
-- skip first three bits
let isAmes = testBit head 3 & not
let pktVersion = shiftR head 4 .&. 0b111 & fromIntegral
let sndrRank = shiftR head 7 .&. 0b11
let rcvrRank = shiftR head 9 .&. 0b11
let checksum = shiftR head 11 .&. (2 ^ 20 - 1)
let isRelayed = testBit head 31 & not -- loobean
let sndrClass = genericIndex [Lord, Planet, Moon, Comet] sndrRank
let rcvrClass = genericIndex [Lord, Planet, Moon, Comet] rcvrRank
guard isAmes
pktOrigin <- if isRelayed
then Just <$> getAmesAddress
else pure Nothing
-- body
lookAhead $ do
len <- remaining
len <- remaining
body <- getBytes len
let chk = fromIntegral (mugBS body) .&. (2 ^ 20 - 1)
let chk = muk body
when (checksum /= chk) $
fail ("checksum mismatch: expected " <> show checksum
<> "; got " <> show chk)
-- body
pktSndr <- getShip sndrRank
pktRcvr <- getShip rcvrRank
len <- remaining
payload <- getBytes len
-- data ("payload")
(pktOrigin, pktContent) <- case cueBS payload of
Left e -> fail (show e)
Right n -> case fromNounErr n of
Left e -> fail (show e)
Right c -> pure c
pure Packet {..}
tick <- getWord8
let pktSndrTick = tick .&. 0b1111
let pktRcvrTick = shiftR tick 4
pktSndr <- getShip sndrClass
pktRcvr <- getShip rcvrClass
len <- remaining
pktContent <- getBytes len
pure Packet{..}
where
getShip = fmap Ship . \case
0 -> fromIntegral <$> getWord16le -- galaxy / star
1 -> fromIntegral <$> getWord32le -- planet
2 -> fromIntegral <$> getWord64le -- moon
3 -> LargeKey <$> getWord64le <*> getWord64le -- comet
_ -> fail "impossibiru"
Lord -> fromIntegral <$> getWord16le
Planet -> fromIntegral <$> getWord32le
Moon -> fromIntegral <$> getWord64le
Comet -> LargeKey <$> getWord64le <*> getWord64le
put Packet {..} = do
let load = jamBS $ toNoun (pktOrigin, pktContent)
put Packet{..} = do
let (sndR, putSndr) = putShipGetRank pktSndr
let (rcvR, putRcvr) = putShipGetRank pktRcvr
let body = runPut (putSndr <> putRcvr <> putByteString load)
let chek = fromIntegral (mugBS body) .&. (2 ^ 20 - 1)
let encr = pktEncrypted
let body = runPut $ do
putWord8 $ (pktSndrTick .&. 0b1111)
.|. shiftL (pktRcvrTick .&. 0b1111) 4
putSndr
putRcvr
putByteString pktContent
let vers = fromIntegral pktVersion .&. 0b111
let head = vers
.|. shiftL chek 3
.|. shiftL sndR 23
.|. shiftL rcvR 25
.|. if encr then 0 else bit 27
let chek = muk body
-- skip first 3 bytes, set 4th to yes (0) for "is ames"
let head = shiftL vers 4
.|. shiftL sndR 7
.|. shiftL rcvR 9
.|. shiftL chek 11
.|. if isJust pktOrigin then 0 else bit 31
putWord32le head
putByteString body -- XX can we avoid copy?
case pktOrigin of
Just o -> putAmesAddress o
Nothing -> pure ()
putByteString body
where
putShipGetRank s@(Ship (LargeKey p q)) = case () of
_ | s < 2 ^ 16 -> (0, putWord16le $ fromIntegral s) -- gar
| s < 2 ^ 32 -> (1, putWord32le $ fromIntegral s) -- pan
| s < 2 ^ 64 -> (2, putWord64le $ fromIntegral s) -- mon
| otherwise -> (3, putWord64le p >> putWord64le q) -- com
_ | s < 2 ^ 16 -> (0, putWord16le $ fromIntegral s) -- lord
| s < 2 ^ 32 -> (1, putWord32le $ fromIntegral s) -- planet
| s < 2 ^ 64 -> (2, putWord64le $ fromIntegral s) -- moon
| otherwise -> (3, putWord64le p >> putWord64le q) -- comet

2
pkg/hs/urbit-king/lib/Urbit/Vere/Behn.hs
View File

@ -10,7 +10,7 @@ module Urbit.Vere.Behn (behn, DriverApi(..), behn') where
import Data.Time.Clock.System (SystemTime)
import Urbit.Arvo hiding (Behn)
import Urbit.Arvo
import Urbit.Prelude
import Urbit.Vere.Pier.Types

6
pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/KingSubsite.hs
View File

@ -13,7 +13,6 @@ import Urbit.Prelude hiding (Builder)
import Data.ByteString.Builder
import Urbit.King.Scry
import Urbit.Vere.Serf.Types
import Data.Conduit (ConduitT, Flush(..), yield)
import Data.Text.Encoding (encodeUtf8Builder)
@ -23,7 +22,6 @@ import qualified Data.Text.Encoding as E
import qualified Network.HTTP.Types as H
import qualified Network.Wai as W
import qualified Network.Wai.Conduit as W
import qualified Urbit.Noun.Time as Time
newtype KingSubsite = KS { runKingSubsite :: W.Application }
@ -44,7 +42,7 @@ streamSlog a = do
kingSubsite :: HasLogFunc e
=> Ship
-> (Time.Wen -> Gang -> Path -> IO (Maybe (Term, Noun)))
-> ScryFunc
-> IO RenderedStat
-> TVar ((Atom, Tank) -> IO ())
-> RAcquire e KingSubsite
@ -118,7 +116,7 @@ kingSubsite who scry stat func = do
=> Text
-> RIO e (Maybe Bool)
scryAuth cookie =
scryNow scry "ex" who "" ["authenticated", "cookie", textAsTa cookie]
scryNow scry "ex" "" ["authenticated", "cookie", textAsTa cookie]
fourOhFourSubsite :: Ship -> KingSubsite
fourOhFourSubsite who = KS $ \req respond ->

101
pkg/hs/urbit-king/lib/Urbit/Vere/Pier.hs
View File

@ -32,11 +32,11 @@ import System.Posix.Files (ownerModes, setFileMode)
import Urbit.EventLog.LMDB (EventLog)
import Urbit.EventLog.Event (buildLogEvent)
import Urbit.King.API (TermConn)
import Urbit.Noun.Time (Wen)
import Urbit.TermSize (TermSize(..), termSize)
import Urbit.Vere.Serf (Serf)
import qualified Data.Text as T
import qualified Data.List as L
import qualified System.Entropy as Ent
import qualified Urbit.EventLog.LMDB as Log
import qualified Urbit.King.API as King
@ -72,16 +72,22 @@ setupPierDirectory shipPath = do
-- Load pill into boot sequence. -----------------------------------------------
data CannotBootFromIvoryPill = CannotBootFromIvoryPill
deriving (Show, Exception)
genEntropy :: MonadIO m => m Entropy
genEntropy = Entropy . fromIntegral . bytesAtom <$> io (Ent.getEntropy 64)
genBootSeq :: MonadIO m => Ship -> Pill -> Bool -> LegacyBootEvent -> m BootSeq
genBootSeq ship Pill {..} lite boot = io $ do
ent <- genEntropy
let ovums = preKern ent <> pKernelOvums <> postKern <> pUserspaceOvums
pure $ BootSeq ident pBootFormulas ovums
genBootSeq :: HasKingEnv e
=> Ship -> Pill -> Bool -> LegacyBootEvent -> RIO e BootSeq
genBootSeq _ PillIvory {} _ _ = throwIO CannotBootFromIvoryPill
genBootSeq ship PillPill {..} lite boot = do
ent <- io genEntropy
wyr <- wyrd
let ova = preKern ent <> [wyr] <> pKernelOva <> postKern <> pUserspaceOva
pure $ BootSeq ident pBootFormulae ova
where
ident = LogIdentity ship isFake (fromIntegral $ length pBootFormulas)
ident = LogIdentity ship isFake (fromIntegral $ length pBootFormulae)
preKern ent =
[ EvBlip $ BlipEvArvo $ ArvoEvWhom () ship
, EvBlip $ BlipEvArvo $ ArvoEvWack () ent
@ -296,9 +302,9 @@ pier (serf, log) vSlog startedSig injected = do
let execute = writeTQueue executeQ
let persist = writeTQueue persistQ
let sigint = Serf.sendSIGINT serf
let scry = \w b g -> do
let scry = \g r -> do
res <- newEmptyMVar
atomically $ writeTQueue scryQ (w, b, g, putMVar res)
atomically $ writeTQueue scryQ (g, r, putMVar res)
takeMVar res
-- Set up the runtime stat counters.
@ -316,9 +322,9 @@ pier (serf, log) vSlog startedSig injected = do
io $ readTVarIO siteSlog >>= ($ s)
logOther "serf" (display $ T.strip $ tankToText tank)
let err = atomically . Term.trace muxed . (<> "\r\n")
(bootEvents, startDrivers) <- do
env <- ask
let err = atomically . Term.trace muxed . (<> "\r\n")
siz <- atomically $ Term.curDemuxSize demux
let fak = isFake logId
drivers env ship fak compute scry (siz, muxed) err sigint stat runtimeSubsite
@ -335,6 +341,8 @@ pier (serf, log) vSlog startedSig injected = do
tSerf <- acquireWorker "Serf" (runCompute serf computeConfig)
doVersionNegotiation compute err
-- Run all born events and retry them until they succeed.
wackEv <- EvBlip . BlipEvArvo . ArvoEvWack () <$> genEntropy
rio $ for_ (wackEv : bootEvents) $ \ev -> do
@ -346,7 +354,7 @@ pier (serf, log) vSlog startedSig injected = do
cb :: Int -> WorkError -> IO ()
cb n | n >= 3 = error ("boot event failed: " <> show ev)
cb n = \case
RunOkay _ -> putMVar okaySig ()
RunOkay _ _ -> putMVar okaySig ()
RunSwap _ _ _ _ _ -> putMVar okaySig ()
RunBail _ -> inject (n + 1)
@ -373,7 +381,7 @@ pier (serf, log) vSlog startedSig injected = do
let inject = atomically $ compute $ RRWork $ EvErr ev $ cb
cb :: WorkError -> IO ()
cb = \case
RunOkay _ -> putMVar okaySig (Right ())
RunOkay _ _ -> putMVar okaySig (Right ())
RunSwap _ _ _ _ _ -> putMVar okaySig (Right ())
RunBail goofs -> putMVar okaySig (Left goofs)
@ -414,6 +422,68 @@ death tag tid = do
Left exn -> Left (tag, exn)
Right () -> Right tag
-- %wyrd version negotiation ---------------------------------------------------
data PierVersionNegotiationFailed = PierVersionNegotiationFailed
deriving (Show, Exception)
zuseVersion :: Word
zuseVersion = 420
wyrd :: HasKingEnv e => RIO e Ev
wyrd = do
king <- tshow <$> view kingIdL
let k = Wynn [("zuse", zuseVersion),
("lull", 330),
("arvo", 240),
("hoon", 140),
("nock", 4)]
sen = MkTerm king
v = Vere sen [Cord "king-haskell", Cord "1.0"] k
pure $ EvBlip $ BlipEvArvo $ ArvoEvWyrd () v
doVersionNegotiation
:: HasPierEnv e
=> (RunReq -> STM ())
-> (Text -> RIO e ())
-> RAcquire e ()
doVersionNegotiation compute stderr = do
ev <- rio wyrd
okaySig :: MVar (Either [Goof] FX) <- newEmptyMVar
let inject = atomically $ compute $ RRWork $ EvErr ev $ cb
cb :: WorkError -> IO ()
cb = \case
RunOkay _ fx -> putMVar okaySig (Right fx)
RunSwap _ _ _ _ fx -> putMVar okaySig (Right fx)
RunBail goofs -> putMVar okaySig (Left goofs)
rio $ stderr "vere: checking version compatibility"
io inject
takeMVar okaySig >>= \case
Left goof -> do
rio $ stderr "pier: version negotation failed"
logError $ display @Text ("Goof in wyrd event: " <> tshow goof)
throwIO PierVersionNegotiationFailed
Right fx -> do
-- Walk through the returned fx looking for a wend effect. If we find
-- one, check the zuse versions.
rio $ for_ fx $ \case
GoodParse (EfWend (Wynn xs)) -> case L.lookup "zuse" xs of
Nothing -> pure ()
Just zuseVerInWynn ->
if zuseVerInWynn /= zuseVersion
then do
rio $ stderr "pier: pier: version negotiation failed; downgrade"
throwIO PierVersionNegotiationFailed
else
pure ()
_ -> pure ()
-- Start All Drivers -----------------------------------------------------------
@ -432,7 +502,7 @@ drivers
-> Ship
-> Bool
-> (RunReq -> STM ())
-> (Wen -> Gang -> Path -> IO (Maybe (Term, Noun)))
-> ScryFunc
-> (TermSize, Term.Client)
-> (Text -> RIO e ())
-> IO ()
@ -502,6 +572,7 @@ router slog waitFx Drivers {..} = do
case ef of
GoodParse (EfVega _ _ ) -> vega
GoodParse (EfExit _ _ ) -> exit
GoodParse (EfWend _ ) -> pure ()
GoodParse (EfVane (VEBehn ef)) -> io (dBehn ef)
GoodParse (EfVane (VEBoat ef)) -> io (dSync ef)
GoodParse (EfVane (VEClay ef)) -> io (dSync ef)
@ -537,7 +608,7 @@ data ComputeConfig = ComputeConfig
{ ccOnWork :: STM RunReq
, ccOnKill :: STM ()
, ccOnSave :: STM ()
, ccOnScry :: STM (Wen, Gang, Path, Maybe (Term, Noun) -> IO ())
, ccOnScry :: STM (Gang, ScryReq, Maybe (Term, Noun) -> IO ())
, ccPutResult :: (Fact, FX) -> STM ()
, ccShowSpinner :: Maybe Text -> STM ()
, ccHideSpinner :: STM ()
@ -551,7 +622,7 @@ runCompute serf ComputeConfig {..} = do
let onRR = asum [ ccOnKill <&> Serf.RRKill
, ccOnSave <&> Serf.RRSave
, ccOnWork
, ccOnScry <&> \(w,g,p,k) -> Serf.RRScry w g p k
, ccOnScry <&> \(g,r,k) -> Serf.RRScry g r k
]
vEvProcessing :: TMVar Ev <- newEmptyTMVarIO

20
pkg/hs/urbit-king/lib/Urbit/Vere/Pier/Types.hs
View File

@ -14,10 +14,11 @@ module Urbit.Vere.Pier.Types
, jobId
, jobMug
, DriverApi(..)
, ScryFunc
)
where
import Urbit.Prelude hiding (Term)
import Urbit.Prelude
import Urbit.Arvo
import Urbit.Noun.Time
@ -44,11 +45,14 @@ instance Show Nock where
--------------------------------------------------------------------------------
data Pill = Pill
{ pBootFormulas :: ![Nock]
, pKernelOvums :: ![Ev]
, pUserspaceOvums :: ![Ev]
}
data Pill
= PillIvory [Noun]
| PillPill
{ pName :: Noun
, pBootFormulae :: ![Nock] -- XX not actually nock, semantically
, pKernelOva :: ![Ev]
, pUserspaceOva :: ![Ev]
}
deriving (Eq, Show)
data BootSeq = BootSeq !LogIdentity ![Nock] ![Ev]
@ -87,6 +91,10 @@ data DriverApi ef = DriverApi
}
-- Scrying --------------------------------------------------------------------
type ScryFunc = Gang -> ScryReq -> IO (Maybe (Term, Noun))
-- Instances -------------------------------------------------------------------
instance ToNoun Work where

42
pkg/hs/urbit-king/lib/Urbit/Vere/Serf/IPC.hs
View File

@ -16,15 +16,16 @@
|%
:: +writ: from king to serf
::
+$ gang (unit (set ship))
+$ writ
$% $: %live
$% [%cram eve=@]
[%exit cod=@]
[%save eve=@]
[%meld ~]
[%pack ~]
== ==
[%peek mil=@ now=@da lyc=gang pat=path]
:: sam=[gang (each path $%([%once @tas @tas path] [beam @tas beam]))]
[%peek mil=@ sam=*]
[%play eve=@ lit=(list ?((pair @da ovum) *))]
[%work mil=@ job=(pair @da ovum)]
==
@ -33,7 +34,8 @@
+$ plea
$% [%live ~]
[%ripe [pro=%1 hon=@ nok=@] eve=@ mug=@]
[%slog pri=@ ?(cord tank)]
[%slog pri=@ tank]
[%flog cord]
$: %peek
$% [%done dat=(unit (cask))]
[%bail dud=goof]
@ -48,6 +50,7 @@
[%bail lud=(list goof)]
== ==
==
--
```
-}
@ -84,7 +87,8 @@ import Foreign.Ptr (castPtr)
import Foreign.Storable (peek, poke)
import RIO.Prelude (decodeUtf8Lenient)
import System.Posix.Signals (sigINT, sigKILL, signalProcess)
import Urbit.Arvo (Ev, FX)
import Urbit.Arvo (FX)
import Urbit.Arvo.Event
import Urbit.Noun.Time (Wen)
import qualified Data.ByteString as BS
@ -171,9 +175,9 @@ recvPleaHandlingSlog :: Serf -> IO Plea
recvPleaHandlingSlog serf = loop
where
loop = recvPlea serf >>= \case
PSlog info -> serfSlog serf info >> loop
other -> pure other
PSlog info -> serfSlog serf info >> loop
PFlog (Cord ofni) -> serfSlog serf (0, Tank $ Leaf $ Tape $ ofni) >> loop
other -> pure other
-- Higher-Level IPC Functions --------------------------------------------------
@ -219,9 +223,9 @@ sendCompactionRequest serf = do
sendWrit serf (WLive $ LPack ())
recvLive serf
sendScryRequest :: Serf -> Wen -> Gang -> Path -> IO (Maybe (Term, Noun))
sendScryRequest serf w g p = do
sendWrit serf (WPeek 0 w g p)
sendScryRequest :: Serf -> Gang -> ScryReq -> IO (Maybe (Term, Noun))
sendScryRequest serf g r = do
sendWrit serf (WPeek 0 g r)
recvPeek serf
sendShutdownRequest :: Serf -> Atom -> IO ()
@ -370,10 +374,9 @@ compact serf = withSerfLockIO serf $ \ss -> do
{-|
Peek into the serf state.
-}
scry :: Serf -> Wen -> Gang -> Path -> IO (Maybe (Term, Noun))
scry serf w g p = withSerfLockIO serf $ \ss -> do
(ss,) <$> sendScryRequest serf w g p
scry :: Serf -> Gang -> ScryReq -> IO (Maybe (Term, Noun))
scry serf g r = withSerfLockIO serf $ \ss -> do
(ss,) <$> sendScryRequest serf g r
{-|
Given a list of boot events, send them to to the serf in a single
@ -493,7 +496,7 @@ run serf maxBatchSize getLastEvInLog onInput sendOn spin = topLoop
RRSave () -> doSave
RRKill () -> doKill
RRPack () -> doPack
RRScry w g p k -> doScry w g p k
RRScry g r k -> doScry g r k
doPack :: IO ()
doPack = compact serf >> topLoop
@ -511,8 +514,8 @@ run serf maxBatchSize getLastEvInLog onInput sendOn spin = topLoop
doKill :: IO ()
doKill = waitForLog >> snapshot serf >> pure ()
doScry :: Wen -> Gang -> Path -> (Maybe (Term, Noun) -> IO ()) -> IO ()
doScry w g p k = (scry serf w g p >>= k) >> topLoop
doScry :: Gang -> ScryReq -> (Maybe (Term, Noun) -> IO ()) -> IO ()
doScry g r k = (scry serf g r >>= k) >> topLoop
doWork :: EvErr -> IO ()
doWork firstWorkErr = do
@ -529,13 +532,13 @@ run serf maxBatchSize getLastEvInLog onInput sendOn spin = topLoop
RRKill () -> atomically (closeTBMQueue que) >> pure doKill
RRSave () -> atomically (closeTBMQueue que) >> pure doSave
RRPack () -> atomically (closeTBMQueue que) >> pure doPack
RRScry w g p k -> atomically (closeTBMQueue que) >> pure (doScry w g p k)
RRScry g r k -> atomically (closeTBMQueue que) >> pure (doScry g r k)
RRWork workErr -> atomically (writeTBMQueue que workErr) >> workLoop que
onWorkResp :: Wen -> EvErr -> Work -> IO ()
onWorkResp wen (EvErr evn err) = \case
WDone eid hash fx -> do
io $ err (RunOkay eid)
io $ err (RunOkay eid fx)
atomically $ sendOn ((Fact eid hash wen (toNoun evn)), fx)
WSwap eid hash (wen, noun) fx -> do
io $ err (RunSwap eid hash wen noun fx)
@ -543,6 +546,7 @@ run serf maxBatchSize getLastEvInLog onInput sendOn spin = topLoop
WBail goofs -> do
io $ err (RunBail goofs)
{-|
Given:

3
pkg/hs/urbit-king/lib/Urbit/Vere/Serf/IPC/Types.hs
View File

@ -35,7 +35,7 @@ data Work
data Writ
= WLive Live
| WPeek Atom Wen Gang Path
| WPeek Atom Gang ScryReq
| WPlay EventId [Noun]
| WWork Atom Wen Ev
deriving (Show)
@ -44,6 +44,7 @@ data Plea
= PLive ()
| PRipe SerfInfo
| PSlog Slog
| PFlog Cord
| PPeek Scry
| PPlay Play
| PWork Work

20
pkg/hs/urbit-king/lib/Urbit/Vere/Serf/Types.hs
View File

@ -2,7 +2,7 @@ module Urbit.Vere.Serf.Types where
import Urbit.Prelude
import Urbit.Arvo (Ev, FX)
import Urbit.Arvo (Desk, Ev, FX)
import Urbit.Noun.Time (Wen)
@ -82,7 +82,7 @@ data EvErr = EvErr Ev (WorkError -> IO ())
data WorkError -- TODO Rename type and constructors
= RunSwap EventId Mug Wen Noun FX -- TODO Maybe provide less info here?
| RunBail [Goof]
| RunOkay EventId
| RunOkay EventId FX
{-
- RRWork: Ask the serf to do work, will output (Fact, FX) if work
@ -94,7 +94,19 @@ data RunReq
| RRSave ()
| RRKill ()
| RRPack ()
| RRScry Wen Gang Path (Maybe (Term, Noun) -> IO ())
| RRScry Gang ScryReq (Maybe (Term, Noun) -> IO ())
type ScryReq = (Each Path Demi)
data Demi
= DemiOnce Term Desk Path
| DemiBeam Term Beam
deriving (Show)
-- TODO
type Beam = Void
deriveNoun ''Demi
-- Exceptions ------------------------------------------------------------------
@ -111,6 +123,8 @@ data SerfExn
| SerfNotRunning
| MissingBootEventsInEventLog Word Word
| SnapshotAheadOfLog EventId EventId
| BailDuringWyrd [Goof]
| SwapDuringWyrd Mug (Wen, Noun) FX
deriving (Show, Exception)

2
pkg/hs/urbit-king/package.yaml
View File

@ -1,5 +1,5 @@
name: urbit-king
version: 0.10.8
version: 1.1
license: MIT
license-file: LICENSE
data-files:

3
pkg/hs/urbit-king/test/AmesTests.hs
View File

@ -108,9 +108,10 @@ instance Arbitrary LogIdentity where
instance Arbitrary Packet where
arbitrary = do
pktVersion <- suchThat arb (< 8)
pktEncrypted <- arb
pktSndr <- arb
pktRcvr <- arb
pktSndrTick <- suchThat arb (< 16)
pktRcvrTick <- suchThat arb (< 16)
pktOrigin <- arb
pktContent <- arb
pure Packet {..}

30
pkg/hs/urbit-king/test/ArvoTests.hs
View File

@ -31,18 +31,6 @@ roundTrip x = Just x == fromNoun (toNoun x)
nounEq :: (ToNoun a, ToNoun b) => a -> b -> Bool
nounEq x y = toNoun x == toNoun y
data EvExample = EvEx Ev Noun
deriving (Eq, Show)
eventSanity :: [EvExample] -> Bool
eventSanity = all $ \(EvEx e n) -> toNoun e == n
instance Arbitrary EvExample where
arbitrary = oneof $ fmap pure $
[ EvEx (EvVane $ VaneVane $ VEVeer (Jael, ()) "" (Path []) "")
(toNoun (Path ["vane", "vane", "jael"], Cord "veer", (), (), ()))
]
--------------------------------------------------------------------------------
tests :: TestTree
@ -51,7 +39,6 @@ tests =
[ testProperty "Round Trip Effect" (roundTrip @Ef)
, testProperty "Round Trip Event" (roundTrip @Ev)
, testProperty "Round Trip AmesDest" (roundTrip @AmesDest)
, testProperty "Basic Event Sanity" eventSanity
]
@ -131,24 +118,9 @@ instance Arbitrary BlipEv where
]
instance Arbitrary Ev where
arbitrary = oneof [ EvVane <$> arb
, EvBlip <$> arb
arbitrary = oneof [ EvBlip <$> arb
]
instance Arbitrary Vane where
arbitrary = oneof [ VaneVane <$> arb
, VaneZuse <$> arb
]
instance Arbitrary VaneName where
arbitrary = oneof $ pure <$> [minBound .. maxBound]
instance Arbitrary VaneEv where
arbitrary = VEVeer <$> arb <*> arb <*> arb <*> arb
instance Arbitrary ZuseEv where
arbitrary = ZEVeer () <$> arb <*> arb <*> arb
instance Arbitrary StdMethod where
arbitrary = oneof $ pure <$> [ minBound .. maxBound ]

2
pkg/hs/urbit-king/test/Options.hs
View File

@ -35,7 +35,7 @@ instance KnownSymbol name => Options.IsOption (Pill name) where
)
defaultValue =
Pill ( "../../../bin"
Pill ( "../../../bin/"
++ TypeLits.symbolVal (Proxy @name)
++ ".pill"
)

2
pkg/hs/urbit-king/test/gold/hoontree.gold
View File

@ -1 +1 @@
2082167031
233234490

24
pkg/hs/urbit-noun-core/lib/Urbit/Noun/Mug.hs
View File

@ -5,6 +5,7 @@ module Urbit.Noun.Mug where
import ClassyPrelude
import Data.Bits
import Data.ByteString.Builder
import Urbit.Atom
import Data.Hash.Murmur (murmur3)
@ -13,14 +14,7 @@ type Mug = Word32
{-# INLINE mugBS #-}
mugBS :: ByteString -> Word32
mugBS = go 0xcafebabe
where
go seed buf =
let haz = murmur3 seed buf
ham = shiftR haz 31 `xor` (haz .&. 0x7fff_ffff)
in if ham == 0
then go (seed + 1) buf
else ham
mugBS = mum 0xcafe_babe 0x7fff
-- XX is there a way to do this without copy?
{-# INLINE mugAtom #-}
@ -29,4 +23,16 @@ mugAtom = mugBS . atomBytes
{-# INLINE mugBoth #-}
mugBoth :: Word32 -> Word32 -> Word32
mugBoth m n = mugAtom $ fromIntegral $ m `xor` 0x7fff_ffff `xor` n
mugBoth m n = mum 0xdead_beef 0xfffe
$ toStrict $ toLazyByteString (word32LE m <> word32LE n)
mum :: Word32 -> Word32 -> ByteString -> Word32
mum syd fal key = go syd 0
where
go syd 8 = fal
go syd i =
let haz = murmur3 syd key
ham = shiftR haz 31 `xor` (haz .&. 0x7fff_ffff)
in if ham /= 0
then ham
else go (syd + 1) (i + 1)

7
pkg/hs/urbit-noun-core/lib/Urbit/Noun/TH.hs
View File

@ -147,7 +147,9 @@ enumFromAtom :: [(String, Name)] -> Exp
enumFromAtom cons = LamE [VarP x] body
where
(x, c) = (mkName "x", mkName "c")
getTag = BindS (VarP c) $ AppE (VarE 'parseNounUtf8Atom) (VarE x)
getTag = BindS (VarP c)
$ AppE (AppE (VarE 'named) matchFail)
$ AppE (VarE 'parseNounUtf8Atom) (VarE x)
examine = NoBindS $ CaseE (VarE c) (matches ++ [fallback])
matches = mkMatch <$> cons
fallback = Match WildP (NormalB $ AppE (VarE 'fail) matchFail) []
@ -194,6 +196,7 @@ taggedFromNoun cons = LamE [VarP n] (DoE [getHead, getTag, examine])
$ AppE (VarE 'parseNoun) (VarE n)
getTag = BindS (SigP (VarP c) (ConT ''Text))
$ AppE (AppE (VarE 'named) tagFail)
$ AppE (VarE 'parseNounUtf8Atom) (VarE h)
examine = NoBindS
@ -208,6 +211,8 @@ taggedFromNoun cons = LamE [VarP n] (DoE [getHead, getTag, examine])
fallback = Match WildP (NormalB $ AppE (VarE 'fail) matchFail) []
matchFail = unexpectedTag (fst <$> cons) (VarE c)
tagFail = LitE $ StringL (intercalate " " (('%':) <$> (fst <$> cons)))
--------------------------------------------------------------------------------
tagString :: Int -> Name -> String

2
pkg/urbit/version
View File

@ -1 +1 @@
1.0
1.1