shrub/pkg/hs/urbit-king/lib/Urbit/Arvo/Effect.hs

{-# 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 #-}

{-|
    Effect Types and Their Noun Conversions
-}
module Urbit.Arvo.Effect where

import Urbit.Noun.Time
import Urbit.Prelude

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)


-- Newt Effects ----------------------------------------------------------------

{-|
    %turf -- Set which domain names we've bound.
    %send -- Send a UDP packet.
-}
data NewtEf
    = NewtEfTurf (Atom, ()) [Turf]
    | NewtEfSend (Atom, ()) AmesDest Bytes
  deriving (Eq, Ord, Show)

deriveNoun ''NewtEf


-- HTTP Client Effects ---------------------------------------------------------

data HttpClientReq = HttpClientReq
    { method     :: Method
    , url        :: Cord
    , headerList :: [Header]
    , body       :: Maybe Octs
    }
  deriving (Eq, Ord, Show)

{-|
    %request        -- TODO
    %cancel-request -- TODO
-}
data HttpClientEf
    = HCERequest       (Atom, ()) Word HttpClientReq
    | HCECancelRequest Path       Word
  deriving (Eq, Ord, Show)

deriveNoun ''HttpClientReq
deriveNoun ''HttpClientEf


-- HTTP Server Effects ---------------------------------------------------------

{-|
    %set-config -- Update HTTP server configuration.
    %response   -- Respond to an active HTTP request.
-}
data HttpServerEf
    = HSESetConfig (ServId, ())         HttpServerConf
    | HSEResponse  (ServId, UD, UD, ()) HttpEvent
  deriving (Eq, Ord, Show)

deriveNoun ''HttpServerEf


-- File System Effects ---------------------------------------------------------

{-|
    %hill -- TODO
    %dirk -- mark mount dirty
    %ergo -- TODO
    %ogre -- TODO
-}
data SyncEf
    = SyncEfHill ()  [Desk]
    | SyncEfDirk Path Desk
    | SyncEfErgo Path Desk [(Path, Maybe Mime)]
    | SyncEfOgre Path Desk
  deriving (Eq, Ord, Show)

deriveNoun ''SyncEf


-- Timer Effects ---------------------------------------------------------------

{-|
    %doze -- Set or clear timer.
    %void -- Nasty hack to make the parser not treat this as a record.
-}
data BehnEf
    = BehnEfDoze (KingId, ()) (Maybe Wen)
    | BehnEfVoid Void
  deriving (Eq, Ord, Show)

deriveNoun ''BehnEf


-- Terminal Effects ------------------------------------------------------------

{-|
    %bel -- TODO
    %clr -- TODO
    %hop -- TODO
    %lin -- TODO
    %mor -- TODO
    %sag -- TODO
    %sav -- TODO
    %url -- TODO
-}
data Blit
    = Bel ()
    | Clr ()
    | Hop Word64
    | Klr Stub
    | Lin [Char]
    | Mor ()
    | Sag Path Noun
    | Sav Path Atom
    | Url Cord
  deriving (Eq, Ord)

data Deco
    = DecoBl
    | DecoBr
    | DecoUn
    | DecoNull
  deriving (Eq, Ord, Show)

data Tint
    = TintR
    | TintG
    | TintB
    | TintC
    | TintM
    | TintY
    | TintK
    | TintW
    | TintNull
  deriving (Eq, Ord, Show)

data Stye = Stye
    { deco :: (HoonSet Deco)
    , back :: Tint
    , fore :: Tint
    }
  deriving (Eq, Ord, Show)

newtype Stub = Stub [(Stye, [Char])]
  deriving (Eq, Ord, Show)

instance ToNoun Deco where
  toNoun = \case
    DecoBl   -> toNoun $ Cord "bl"
    DecoBr   -> toNoun $ Cord "br"
    DecoUn   -> toNoun $ Cord "un"
    DecoNull -> Atom 0

instance FromNoun Deco where
  parseNoun = named "Deco" . \case
    Atom 0 -> pure DecoNull
    n      -> parseNoun @Cord n <&> unCord >>= \case
                "bl" -> pure DecoBl
                "br" -> pure DecoBr
                "un" -> pure DecoUn
                t    -> fail ("invalid: " <> unpack t)

instance ToNoun Tint where
  toNoun = \case
    TintR    -> toNoun $ Cord "r"
    TintG    -> toNoun $ Cord "g"
    TintB    -> toNoun $ Cord "b"
    TintC    -> toNoun $ Cord "c"
    TintM    -> toNoun $ Cord "m"
    TintY    -> toNoun $ Cord "y"
    TintK    -> toNoun $ Cord "k"
    TintW    -> toNoun $ Cord "w"
    TintNull -> Atom 0

instance FromNoun Tint where
  parseNoun = named "Tint" . \case
    Atom 0 -> pure TintNull
    n      -> parseNoun @Cord n <&> unCord >>= \case
                "r" -> pure TintR
                "g" -> pure TintG
                "b" -> pure TintB
                "c" -> pure TintC
                "m" -> pure TintM
                "y" -> pure TintY
                "k" -> pure TintK
                "w" -> pure TintW
                t   -> fail ("invalid: " <> unpack t)

-- Manual instance to not save the noun/atom in Sag/Sav, because these can be
-- megabytes and makes king hang.
instance Show Blit where
  show (Bel ())     = "Bel ()"
  show (Clr ())     = "Clr ()"
  show (Hop x)      = "Hop " ++ (show x)
  show (Klr s)      = "Klr " ++ (show s)
  show (Lin c)      = "Lin " ++ (show c)
  show (Mor ())     = "Mor ()"
  show (Sag path _) = "Sag " ++ (show path)
  show (Sav path _) = "Sav " ++ (show path)
  show (Url c)      = "Url " ++ (show c)

{-|
    %blip -- TODO
    %init -- TODO
    %logo -- Shutdown
    %mass -- Measure memory usage (unused)
-}
data TermEf
    = TermEfBlit (UD, ()) [Blit]
    | TermEfInit (UD, ()) Ship
    | TermEfLogo Path ()
    | TermEfMass Path Noun -- Irrelevant
  deriving (Eq, Ord, Show)

deriveNoun ''Stye
deriveNoun ''Stub
deriveNoun ''Blit
deriveNoun ''TermEf


-- IO-Driver Routing -----------------------------------------------------------

data VaneEf
    = VENewt       NewtEf
    | VEHttpClient HttpClientEf
    | VEHttpServer HttpServerEf
    | VEBehn       BehnEf
    | VETerm       TermEf
    | VEClay       SyncEf
    | VESync       SyncEf
    | VEBoat       SyncEf
  deriving (Eq, Ord, Show)

deriveNoun ''VaneEf


-- Top-Level Ef Type -----------------------------------------------------------

data Ef
    = EfVane VaneEf
    | EfVega Cord EvilPath -- second path component, rest of path
    | EfExit Cord EvilPath -- second path component, rest of path
  deriving (Eq, Ord, Show)

instance ToNoun Ef where
  toNoun = \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)

instance FromNoun Ef where
  parseNoun = 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 tag    p val   -> EfVane <$> parseNoun (toNoun (s, tag, p, val))
    ReOrg _  _ _      _ _     -> fail "Non-empty first path-element"

summarizeEffect :: Lenient Ef -> Text
summarizeEffect ef =
  fromNoun (toNoun ef) & \case
    Nothing -> "//invalid %effect"
    Just (pax :: [Cord], tag :: Cord, val :: Noun) ->
      "/" <> intercalate "/" (unCord <$> pax) <> " %" <> unCord tag