{-# 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(..) , 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 hiding (Term) 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) -- 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