mirror of
https://github.com/ilyakooo0/urbit.git
synced 2024-12-22 14:21:34 +03:00
271 lines
7.1 KiB
Haskell
271 lines
7.1 KiB
Haskell
{-# LANGUAGE StrictData #-}
|
|
|
|
-- This is required due to the use of 'Void' in a constructor slot in
|
|
-- combination with 'deriveNoun' which generates an unreachable pattern.
|
|
{-# OPTIONS_GHC -Wno-overlapping-patterns #-}
|
|
|
|
-- Hack. See comment above instance ToNoun H.StdMethod
|
|
{-# OPTIONS_GHC -Wno-orphans #-}
|
|
|
|
{-|
|
|
Types used in both Events and Effects.
|
|
-}
|
|
module Urbit.Arvo.Common
|
|
( KingId(..), ServId(..)
|
|
, Vere(..), Wynn(..)
|
|
, Json, JsonNode(..)
|
|
, Desk(..), Mime(..)
|
|
, Port(..), Turf(..)
|
|
, HttpServerConf(..), PEM(..), Key, Cert
|
|
, HttpEvent(..), Method, Header(..), ResponseHeader(..)
|
|
, ReOrg(..), reorgThroughNoun
|
|
, AmesDest, Ipv4(..), Ipv6(..), Patp(..), Galaxy, AmesAddress(..)
|
|
) where
|
|
|
|
import Urbit.Prelude
|
|
|
|
import Control.Monad.Fail (fail)
|
|
|
|
import qualified Network.HTTP.Types.Method as H
|
|
import qualified Urbit.Ob as Ob
|
|
|
|
|
|
-- Misc Types ------------------------------------------------------------------
|
|
|
|
{-|
|
|
Domain Name in TLD order:
|
|
|
|
["org", "urbit", "dns"] -> dns.urbit.org
|
|
-}
|
|
newtype Turf = Turf { unTurf :: [Cord] }
|
|
deriving newtype (Eq, Ord, Show, ToNoun, FromNoun)
|
|
|
|
newtype KingId = KingId { unKingId :: UV }
|
|
deriving newtype (Eq, Ord, Show, Num, Real, Enum, Integral, FromNoun, ToNoun)
|
|
|
|
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 :: (Term, UD, UD, UD),
|
|
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, UD)] }
|
|
deriving newtype (Eq, Ord, Show, FromNoun, ToNoun)
|
|
|
|
-- Http Common -----------------------------------------------------------------
|
|
|
|
data Header = Header Cord Bytes
|
|
deriving (Eq, Ord, Show)
|
|
|
|
data ResponseHeader = ResponseHeader
|
|
{ statusCode :: Word
|
|
, headers :: [Header]
|
|
}
|
|
deriving (Eq, Ord, Show)
|
|
|
|
data HttpEvent
|
|
= Start ResponseHeader (Maybe File) Bool
|
|
| Continue (Maybe File) Bool
|
|
| Cancel ()
|
|
deriving (Eq, Ord, Show)
|
|
|
|
deriveNoun ''ResponseHeader
|
|
deriveNoun ''Header
|
|
deriveNoun ''HttpEvent
|
|
|
|
|
|
-- Http Requests ---------------------------------------------------------------
|
|
|
|
type Method = H.StdMethod
|
|
|
|
-- TODO Hack! Don't write instances for library types. Write them for
|
|
-- our types instead.
|
|
|
|
instance ToNoun H.StdMethod where
|
|
toNoun = toNoun . MkBytes . H.renderStdMethod
|
|
|
|
instance FromNoun H.StdMethod where
|
|
parseNoun n = named "StdMethod" $ do
|
|
MkBytes bs <- parseNoun n
|
|
case H.parseMethod bs of
|
|
Left md -> fail ("Unexpected method: " <> unpack (decodeUtf8 md))
|
|
Right m -> pure m
|
|
|
|
|
|
|
|
-- Http Server Configuration ---------------------------------------------------
|
|
|
|
newtype PEM = PEM { unPEM :: Wain }
|
|
deriving newtype (Eq, Ord, ToNoun, FromNoun)
|
|
|
|
instance Show PEM where
|
|
show _ = "\"PEM (secret)\""
|
|
|
|
type Key = PEM
|
|
type Cert = PEM
|
|
|
|
data HttpServerConf = HttpServerConf
|
|
{ hscSecure :: Maybe (Key, Cert)
|
|
, hscProxy :: Bool
|
|
, hscLog :: Bool
|
|
, hscRedirect :: Bool
|
|
}
|
|
deriving (Eq, Ord, Show)
|
|
|
|
deriveNoun ''HttpServerConf
|
|
|
|
|
|
-- Desk and Mime ---------------------------------------------------------------
|
|
|
|
newtype Desk = Desk { unDesk :: Cord }
|
|
deriving newtype (Eq, Ord, Show, ToNoun, FromNoun)
|
|
|
|
data Mime = Mime Path File
|
|
deriving (Eq, Ord, Show)
|
|
|
|
deriveNoun ''Mime
|
|
|
|
|
|
-- Json ------------------------------------------------------------------------
|
|
|
|
type Json = Nullable JsonNode
|
|
|
|
data JsonNode
|
|
= JNA [Json]
|
|
| JNB Bool
|
|
| JNO (HoonMap Cord Json)
|
|
| JNN Knot
|
|
| JNS Cord
|
|
deriving (Eq, Ord, Show)
|
|
|
|
deriveNoun ''JsonNode
|
|
|
|
|
|
-- Ames Destinations -------------------------------------------------
|
|
|
|
newtype Patp a = Patp { unPatp :: a }
|
|
deriving newtype (Eq, Ord, Enum, Real, Integral, Num, ToNoun, FromNoun)
|
|
|
|
-- Network Port
|
|
newtype Port = Port { unPort :: Word16 }
|
|
deriving newtype (Eq, Ord, Show, Enum, Real, Integral, Num, ToNoun, FromNoun)
|
|
|
|
-- @if
|
|
newtype Ipv4 = Ipv4 { unIpv4 :: Word32 }
|
|
deriving newtype (Eq, Ord, Show, Enum, Real, Integral, Num, ToNoun, FromNoun)
|
|
|
|
-- @is
|
|
newtype Ipv6 = Ipv6 { unIpv6 :: Word128 }
|
|
deriving newtype (Eq, Ord, Show, Enum, Real, Integral, Num, ToNoun, FromNoun)
|
|
|
|
type Galaxy = Patp Word8
|
|
|
|
instance Integral a => Show (Patp a) where
|
|
show = show . Ob.renderPatp . Ob.patp . fromIntegral . unPatp
|
|
|
|
data AmesAddress
|
|
= AAIpv4 Ipv4 Port
|
|
| AAVoid Void
|
|
deriving (Eq, Ord, Show)
|
|
|
|
deriveNoun ''AmesAddress
|
|
|
|
type AmesDest = Each Galaxy (Jammed AmesAddress)
|
|
|
|
|
|
-- Path+Tagged Restructuring ---------------------------------------------------
|
|
|
|
{-|
|
|
This reorganized events and effects to be easier to parse. This is
|
|
complicated and gross, and a better way should be found!
|
|
|
|
ReOrg takes in nouns with the following shape:
|
|
|
|
[[fst snd rest] [tag val]]
|
|
|
|
And turns that into:
|
|
|
|
ReOrg fst snd tag rest val
|
|
|
|
For example,
|
|
|
|
[//behn/5 %doze ~ 9999]
|
|
|
|
Becomes:
|
|
|
|
Reorg "" "behn" "doze" ["5"] 9999
|
|
|
|
This is convenient, since we can then use our head-tag based FromNoun
|
|
and ToNoun instances.
|
|
|
|
NOTE:
|
|
|
|
Also, in the wild, I ran into this event:
|
|
|
|
[//term/1 %init]
|
|
|
|
So, I rewrite atom-events as follows:
|
|
|
|
[x y=@] -> [x [y ~]]
|
|
|
|
Which rewrites the %init example to:
|
|
|
|
[//term/1 [%init ~]]
|
|
|
|
TODO The reverse translation is not done yet.
|
|
|
|
-}
|
|
data ReOrg = ReOrg Cord Cord Cord EvilPath Noun
|
|
|
|
instance FromNoun ReOrg where
|
|
parseNoun = named "ReOrg" . \case
|
|
A _ -> expected "got atom"
|
|
C (A _) _ -> expected "empty route"
|
|
C h (A a) -> parseNoun (C h (C (A a) (A 0)))
|
|
C (C _ (A _)) (C _ _) -> expected "route is too short"
|
|
C (C f (C s p)) (C t v) -> do
|
|
fst :: Cord <- named "first-route" $ parseNoun f
|
|
snd :: Cord <- named "second-route" $ parseNoun s
|
|
pax :: EvilPath <- named "rest-of-route" $ parseNoun p
|
|
tag :: Cord <- named "tag" $ parseNoun t
|
|
val :: Noun <- pure v
|
|
pure (ReOrg fst snd tag pax val)
|
|
where
|
|
expected got = fail ("expected route+tagged; " <> got)
|
|
|
|
instance ToNoun ReOrg where
|
|
toNoun (ReOrg fst snd tag pax val) =
|
|
toNoun ((fst, snd, pax), (tag, val))
|
|
|
|
{-|
|
|
Given something parsed from a ReOrg Noun, convert that back to
|
|
a ReOrg.
|
|
|
|
This code may crash, but only if the FromNoun/ToNoun instances for
|
|
the effects are incorrect.
|
|
-}
|
|
reorgThroughNoun :: ToNoun x => (Cord, x) -> ReOrg
|
|
reorgThroughNoun =
|
|
fromNounCrash . toNoun >>> \case
|
|
(f, s, t, p, v) -> ReOrg f s t p v
|
|
where
|
|
fromNounCrash :: FromNoun a => Noun -> a
|
|
fromNounCrash =
|
|
fromNounErr >>> \case
|
|
Left err -> error (show err)
|
|
Right vl -> vl
|