mirror of
https://github.com/ilyakooo0/urbit.git
synced 2024-12-18 20:31:40 +03:00
420 lines
11 KiB
Haskell
420 lines
11 KiB
Haskell
{-# OPTIONS_GHC -Wwarn #-}
|
|
module Arvo.Event where
|
|
|
|
import UrbitPrelude hiding (Term)
|
|
|
|
import Arvo.Common (KingId(..), ServId(..))
|
|
import Arvo.Common (NounMap, NounSet)
|
|
import Arvo.Common (Desk, Mime)
|
|
import Arvo.Common (Header(..), HttpEvent)
|
|
import Arvo.Common (AmesDest, Ipv4, Ipv6, Port, Turf)
|
|
import Arvo.Common (ReOrg(..), reorgThroughNoun)
|
|
|
|
import qualified Crypto.ECC.Edwards25519 as Ed
|
|
import qualified Crypto.Error as Ed
|
|
import qualified Data.ByteString as BS
|
|
import qualified Data.ByteString.Char8 as C
|
|
import qualified Network.HTTP.Types.Method as H
|
|
|
|
import Numeric (showHex)
|
|
-- Misc Types ------------------------------------------------------------------
|
|
|
|
--type Pass = Atom -- Public Key
|
|
type Rift = Atom -- Continuity number
|
|
type Life = Word -- Number of Azimoth key revs.
|
|
type Bloq = Atom -- TODO
|
|
--type Ring = Atom -- Private Key
|
|
type Oath = Atom -- Signature
|
|
|
|
|
|
|
|
|
|
|
|
-- Parsed URLs -----------------------------------------------------------------
|
|
|
|
type Host = Either Turf Ipv4
|
|
type Hart = (Bool, Maybe Atom, Host)
|
|
type Pork = (Maybe Knot, [Cord])
|
|
type Quay = [(Cord, Cord)]
|
|
|
|
data PUrl = PUrl Hart Pork Quay
|
|
deriving (Eq, Ord, Show)
|
|
|
|
deriveNoun ''PUrl
|
|
|
|
|
|
-- Dawn Records ----------------------------------------------------------------
|
|
|
|
padByteString :: BS.ByteString -> Int -> BS.ByteString
|
|
padByteString bs length | remaining > 0 = bs <> (BS.replicate remaining 0)
|
|
| otherwise = bs
|
|
where remaining = (length - (BS.length bs))
|
|
|
|
-- A Pass is the Atom concatenation of 'b', the public encryption key, and the
|
|
-- public authentication key. (see +pass-from-eth.)
|
|
--
|
|
-- For
|
|
data Pass = Pass { passSign :: Ed.Point, passCrypt :: Ed.Point }
|
|
deriving (Eq, Show)
|
|
|
|
instance ToNoun Pass where
|
|
toNoun Pass{..} =
|
|
Atom $ bs ^. from atomBytes
|
|
where
|
|
bs = (C.singleton 'b' <> (padByteString (Ed.pointEncode passSign) 32) <>
|
|
(padByteString (Ed.pointEncode passCrypt) 32))
|
|
|
|
instance FromNoun Pass where
|
|
parseNoun n = named "Pass" $ do
|
|
MkBytes unpadded <- parseNoun n
|
|
let bs = padByteString unpadded 65
|
|
when ((length bs) /= 65) $ do
|
|
fail ("Expecting ByteString of length 65, actual size " ++
|
|
(show (length bs)))
|
|
when ((C.head bs) /= 'b') $ do
|
|
fail "Expecting 'b' prefix in public key structure"
|
|
let removedPrefix = C.tail bs
|
|
let passSign =
|
|
Ed.throwCryptoError $ Ed.pointDecode (take 32 removedPrefix)
|
|
let passCrypt =
|
|
Ed.throwCryptoError $ Ed.pointDecode (drop 32 removedPrefix)
|
|
pure $ Pass{..}
|
|
|
|
|
|
-- A Ring is the concatenation of 'B', the private encryption key, and the
|
|
-- private authentication key. (see +nol:nu:crub:crypto.)
|
|
data Ring = Ring { ringSign :: Ed.Scalar, ringCrypt :: Ed.Scalar }
|
|
deriving (Eq, Show)
|
|
|
|
-- TODO: OK, reversing the string here isn't correct; we need to instead
|
|
--
|
|
-- Attempts at doing simple padding and cuts aren't actually having the effects
|
|
-- I'd assume they have. I now suspect the best way to move forward here is to
|
|
-- actually implement a real
|
|
instance ToNoun Ring where
|
|
toNoun Ring{..} =
|
|
Atom $ bs ^. from atomBytes
|
|
where
|
|
bs = (C.singleton 'B' <> (padByteString (Ed.scalarEncode ringSign) 32) <>
|
|
(padByteString (Ed.scalarEncode ringCrypt) 32))
|
|
|
|
prettyPrint :: ByteString -> String
|
|
prettyPrint = BS.foldr showHex ""
|
|
|
|
-- 'B' is 0x42.
|
|
instance FromNoun Ring where
|
|
parseNoun n = named "Ring" $ do
|
|
MkBytes unpadded <- parseNoun n
|
|
traceM ("Reversed: " ++ (prettyPrint unpadded))
|
|
let bs = padByteString unpadded 65
|
|
traceM ("BS: " ++ (prettyPrint bs))
|
|
when ((length bs) /= 65) $ do
|
|
fail ("Expecting ByteString of length 65, actual size " ++
|
|
(show (length bs)))
|
|
when ((C.head bs) /= 'B') $ do
|
|
traceM "Expecting 'B' prefix in public key structure"
|
|
fail "Expecting 'B' prefix in public key structure"
|
|
let removedPrefix = C.tail bs
|
|
ringSign <- case decodeToEither (take 32 removedPrefix) of
|
|
Left x -> do
|
|
traceM (show x)
|
|
fail (show x)
|
|
Right y -> pure y
|
|
ringCrypt <- case decodeToEither (drop 32 removedPrefix) of
|
|
Left x -> do
|
|
traceM (show x)
|
|
fail (show x)
|
|
Right y -> pure y
|
|
pure $ Ring ringSign ringCrypt
|
|
where
|
|
decodeToEither = Ed.eitherCryptoError . Ed.scalarDecodeLong
|
|
|
|
|
|
data Seed = Seed Ship Life Ring (Maybe Oath)
|
|
deriving (Eq, Show)
|
|
|
|
type Public = (Life, NounMap Life Pass)
|
|
|
|
data Dnses = Dnses { dPri::Cord, dSec::Cord, dTer::Cord }
|
|
deriving (Eq, Ord, Show)
|
|
|
|
type EthAddr = Atom --Bytes -- 20 bytes
|
|
type ContNum = Word
|
|
|
|
data EthPoint = EthPoint
|
|
{ epOwn :: (EthAddr, EthAddr, EthAddr, EthAddr)
|
|
, epNet :: Maybe (Life, Pass, ContNum, (Bool, Ship), Maybe Ship)
|
|
, epKid :: Maybe (EthAddr, NounSet Ship)
|
|
}
|
|
deriving (Eq, Show)
|
|
|
|
data EthEventId = EthEventId
|
|
{ eeiBlock :: Atom
|
|
, eeiLog :: Atom
|
|
}
|
|
deriving (Eq, Ord, Show)
|
|
|
|
data EthBookmark = EthBookmark
|
|
{ ebHeard :: NounSet EthEventId
|
|
, ebLatestBlock :: Atom
|
|
}
|
|
deriving (Eq, Ord, Show)
|
|
|
|
data Snap = Snap (NounMap Ship Public)
|
|
(Dnses, NounMap Ship EthPoint)
|
|
EthBookmark
|
|
deriving (Eq, Show)
|
|
|
|
data Dawn = MkDawn
|
|
{ dSeed :: Seed
|
|
, dSponsor :: EthPoint
|
|
, dCzar :: NounMap Ship (Rift, Life, Pass)
|
|
, dTurf :: [Turf]
|
|
, dBloq :: Bloq
|
|
, dNode :: (Maybe PUrl)
|
|
}
|
|
deriving (Eq, Show)
|
|
|
|
deriveNoun ''EthEventId
|
|
deriveNoun ''EthBookmark
|
|
deriveNoun ''Dnses
|
|
deriveNoun ''EthPoint
|
|
deriveNoun ''Snap
|
|
deriveNoun ''Seed
|
|
deriveNoun ''Dawn
|
|
|
|
|
|
-- HTTP ------------------------------------------------------------------------
|
|
|
|
type ServerId = Atom
|
|
|
|
data Address
|
|
= AIpv4 Ipv4
|
|
| AIpv6 Ipv6
|
|
| AAmes Ship
|
|
deriving (Eq, Ord, Show)
|
|
|
|
data HttpRequest = HttpRequest
|
|
{ reqMeth :: H.StdMethod
|
|
, reqUrl :: Cord
|
|
, reqHead :: [Header]
|
|
, reqBody :: Maybe File
|
|
}
|
|
deriving (Eq, Ord, Show)
|
|
|
|
data HttpServerReq = HttpServerReq
|
|
{ hsrSecure :: Bool
|
|
, hsrAddress :: Address
|
|
, hsrRequest :: HttpRequest
|
|
}
|
|
deriving (Eq, Ord, Show)
|
|
|
|
data HttpClientEv
|
|
= HttpClientEvReceive (KingId, ()) ServerId HttpEvent
|
|
| HttpClientEvBorn (KingId, ()) ()
|
|
| HttpClientEvCrud Path Cord Tang
|
|
deriving (Eq, Ord, Show)
|
|
|
|
data HttpServerEv
|
|
= HttpServerEvRequest (ServId, UD, UD, ()) HttpServerReq
|
|
| HttpServerEvCancelRequest (ServId, UD, UD, ()) ()
|
|
| HttpServerEvRequestLocal (ServId, UD, UD, ()) HttpServerReq
|
|
| HttpServerEvLive (ServId, ()) Port (Maybe Port)
|
|
| HttpServerEvBorn (KingId, ()) ()
|
|
| HttpServerEvCrud Path Cord Tang
|
|
deriving (Eq, Ord, Show)
|
|
|
|
deriveNoun ''Address
|
|
deriveNoun ''HttpClientEv
|
|
deriveNoun ''HttpRequest
|
|
deriveNoun ''HttpServerEv
|
|
deriveNoun ''HttpServerReq
|
|
|
|
|
|
-- Ames ------------------------------------------------------------------------
|
|
|
|
data AmesEv
|
|
= AmesEvHear () AmesDest Bytes
|
|
| AmesEvWake () ()
|
|
| AmesEvWant Path Ship Path Noun
|
|
| AmesEvCrud Path Cord Tang
|
|
deriving (Eq, Ord, Show)
|
|
|
|
deriveNoun ''AmesEv
|
|
|
|
|
|
-- Arvo Events -----------------------------------------------------------------
|
|
|
|
data ArvoEv
|
|
= ArvoEvWhom () Ship
|
|
| ArvoEvWack () Word512
|
|
| ArvoEvWarn Path Noun
|
|
| ArvoEvCrud Path Cord Tang
|
|
| ArvoEvVeer Atom Noun
|
|
deriving (Eq, Ord, Show)
|
|
|
|
deriveNoun ''ArvoEv
|
|
|
|
|
|
-- Boat Events -----------------------------------------------------------------
|
|
|
|
data BoatEv
|
|
= BoatEvBoat () ()
|
|
| BoatEvCrud Path Cord Tang
|
|
deriving (Eq, Ord, Show)
|
|
|
|
deriveNoun ''BoatEv
|
|
|
|
|
|
-- Timer Events ----------------------------------------------------------------
|
|
|
|
data BehnEv
|
|
= BehnEvWake () ()
|
|
| BehnEvBorn (KingId, ()) ()
|
|
| BehnEvCrud Path Cord Tang
|
|
deriving (Eq, Ord, Show)
|
|
|
|
deriveNoun ''BehnEv
|
|
|
|
|
|
-- Newt Events -----------------------------------------------------------------
|
|
|
|
data NewtEv
|
|
= NewtEvBarn (Atom, ()) ()
|
|
| NewtEvCrud Path Cord Tang
|
|
deriving (Eq, Ord, Show)
|
|
|
|
deriveNoun ''NewtEv
|
|
|
|
|
|
-- FileSystem Events -----------------------------------------------------------
|
|
|
|
data SyncEv
|
|
= SyncEvInto (Nullable (KingId, ())) Desk Bool [(Path, Maybe Mime)]
|
|
| SyncEvCrud Path Cord Tang
|
|
deriving (Eq, Ord, Show)
|
|
|
|
deriveNoun ''SyncEv
|
|
|
|
|
|
-- Terminal Events -------------------------------------------------------------
|
|
|
|
data LegacyBootEvent
|
|
= Fake Ship
|
|
| Dawn Dawn
|
|
deriving (Eq, Show)
|
|
|
|
data ArrowKey = D | L | R | U
|
|
deriving (Eq, Ord, Show)
|
|
|
|
data Belt
|
|
= Aro ArrowKey
|
|
| Bac ()
|
|
| Ctl Cord
|
|
| Del ()
|
|
| Met Cord
|
|
| Ret ()
|
|
| Txt Tour
|
|
deriving (Eq, Ord, Show)
|
|
|
|
data TermEv
|
|
= TermEvBelt (UD, ()) Belt
|
|
| TermEvBlew (UD, ()) Word Word
|
|
| TermEvBoot (UD, ()) LegacyBootEvent
|
|
| TermEvHail (UD, ()) ()
|
|
| TermEvCrud Path Cord Tang
|
|
deriving (Eq, Show)
|
|
|
|
deriveNoun ''LegacyBootEvent
|
|
deriveNoun ''ArrowKey
|
|
deriveNoun ''Belt
|
|
deriveNoun ''TermEv
|
|
|
|
|
|
-- Events for Device Drivers ---------------------------------------------------
|
|
|
|
data BlipEv
|
|
= BlipEvAmes AmesEv
|
|
| BlipEvArvo ArvoEv
|
|
| BlipEvBehn BehnEv
|
|
| BlipEvBoat BoatEv
|
|
| BlipEvHttpClient HttpClientEv
|
|
| BlipEvHttpServer HttpServerEv
|
|
| BlipEvNewt NewtEv
|
|
| BlipEvSync SyncEv
|
|
| BlipEvTerm TermEv
|
|
deriving (Eq, Show)
|
|
|
|
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)
|
|
|
|
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)"
|
|
|
|
-- Short Event Names -----------------------------------------------------------
|
|
|
|
{-
|
|
In the case of the user hitting enter, the cause is technically a
|
|
terminal event, but we don't display any name because the cause is
|
|
really the user.
|
|
-}
|
|
getSpinnerNameForEvent :: Ev -> Maybe Text
|
|
getSpinnerNameForEvent = \case
|
|
EvVane _ -> Nothing
|
|
EvBlip b -> case b of
|
|
BlipEvAmes _ -> Just "ames"
|
|
BlipEvArvo _ -> Just "arvo"
|
|
BlipEvBehn _ -> Just "behn"
|
|
BlipEvBoat _ -> Just "boat"
|
|
BlipEvHttpClient _ -> Just "iris"
|
|
BlipEvHttpServer _ -> Just "eyre"
|
|
BlipEvNewt _ -> Just "newt"
|
|
BlipEvSync _ -> Just "clay"
|
|
BlipEvTerm t | isRet t -> Nothing
|
|
BlipEvTerm t -> Just "term"
|
|
where
|
|
isRet (TermEvBelt _ (Ret ())) = True
|
|
isRet _ = False
|