king: eyre: Hooked up multi-tenet HTTP. Start-up is a bit hacky. Still totally untested.

2024-12-19 00:13:12 +03:00 · 2020-05-11 13:42:30 -07:00 · 2020-05-11 13:42:30 -07:00 · f8cd148f0e
commit f8cd148f0e
parent 965f599788
4 changed files with 213 additions and 147 deletions
--- a/pkg/hs/urbit-king/lib/Urbit/King/Main.hs
+++ b/pkg/hs/urbit-king/lib/Urbit/King/Main.hs
@ -82,6 +82,7 @@ import Urbit.Arvo
 import Urbit.King.Config
 import Urbit.Vere.Dawn
 import Urbit.Vere.Pier
+import Urbit.Vere.Eyre.Multi (multiEyre, MultiEyreApi, MultiEyreConf(..))
 import Urbit.Vere.Pier.Types
 import Urbit.Vere.Serf

@ -169,10 +170,11 @@ tryBootFromPill :: ( HasLogFunc e, HasNetworkConfig e, HasPierConfig e
                   )
                => Bool -> Pill -> Bool -> Serf.Flags -> Ship
                -> LegacyBootEvent
+                -> MultiEyreApi
                -> RIO e ()
-tryBootFromPill oExit pill lite flags ship boot = do
+tryBootFromPill oExit pill lite flags ship boot multi = do
    mStart <- newEmptyMVar
-    runOrExitImmediately bootedPier oExit mStart
+    runOrExitImmediately bootedPier oExit mStart multi
  where
    bootedPier = do
        view pierPathL >>= lockFile
@ -181,14 +183,14 @@ tryBootFromPill oExit pill lite flags ship boot = do
        rio $ logTrace "Completed boot"
        pure sls

-runOrExitImmediately :: ( HasLogFunc e, HasNetworkConfig e, HasPierConfig e
-                        , HasConfigDir e
-                        )
-                     => RAcquire e (Serf e, Log.EventLog, SerfState)
-                     -> Bool
-                     -> MVar ()
-                     -> RIO e ()
-runOrExitImmediately getPier oExit mStart =
+runOrExitImmediately
+  :: (HasLogFunc e, HasNetworkConfig e, HasPierConfig e, HasConfigDir e)
+  => RAcquire e (Serf e, Log.EventLog, SerfState)
+  -> Bool
+  -> MVar ()
+  -> MultiEyreApi
+  -> RIO e ()
+runOrExitImmediately getPier oExit mStart multi =
    rwith getPier $ if oExit then shutdownImmediately else runPier
  where
    shutdownImmediately (serf, log, ss) = do
@ -203,15 +205,25 @@ runOrExitImmediately getPier oExit mStart =
        logTrace "Shutdown!"

    runPier sls = do
-        runRAcquire $ Pier.pier sls mStart
+        runRAcquire $ Pier.pier sls mStart multi

-tryPlayShip :: ( HasStderrLogFunc e, HasLogFunc e, HasNetworkConfig e
-               , HasPierConfig e, HasConfigDir e
-               )
-            => Bool -> Bool -> Maybe Word64 -> Serf.Flags -> MVar () -> RIO e ()
-tryPlayShip exitImmediately fullReplay playFrom flags mStart = do
+tryPlayShip
+  :: ( HasStderrLogFunc e
+     , HasLogFunc e
+     , HasNetworkConfig e
+     , HasPierConfig e
+     , HasConfigDir e
+     )
+  => Bool
+  -> Bool
+  -> Maybe Word64
+  -> Serf.Flags
+  -> MVar ()
+  -> MultiEyreApi
+  -> RIO e ()
+tryPlayShip exitImmediately fullReplay playFrom flags mStart multi = do
    when fullReplay wipeSnapshot
-    runOrExitImmediately resumeShip exitImmediately mStart
+    runOrExitImmediately resumeShip exitImmediately mStart multi
  where
    wipeSnapshot = do
        shipPath <- view pierPathL
@ -422,7 +434,12 @@ pillFrom (CLI.PillSourceURL url) = do
  fromNounErr noun & either (throwIO . uncurry ParseErr) pure

 newShip :: forall e. HasLogFunc e => CLI.New -> CLI.Opts -> RIO e ()
-newShip CLI.New{..} opts
+newShip new opts = do
+  multi <- multiEyre (MultiEyreConf Nothing Nothing True) -- TODO Hack
+  newShip' multi new opts
+
+newShip' :: forall e. HasLogFunc e => MultiEyreApi -> CLI.New -> CLI.Opts -> RIO e ()
+newShip' multi CLI.New{..} opts
  | CLI.BootComet <- nBootType = do
      pill <- pillFrom nPillSource
      putStrLn "boot: retrieving list of stars currently accepting comets"
@ -493,12 +510,12 @@ newShip CLI.New{..} opts
      let pierConfig = toPierConfig (pierPath name) opts
      let networkConfig = toNetworkConfig opts
      io $ runPierApp pierConfig networkConfig True $
-        tryBootFromPill True pill nLite flags ship bootEvent
+        tryBootFromPill True pill nLite flags ship bootEvent multi
 ------  tryBootFromPill (CLI.oExit opts) pill nLite flags ship bootEvent


-runShip :: CLI.Run -> CLI.Opts -> Bool -> IO ()
-runShip (CLI.Run pierPath) opts daemon = do
+runShip :: CLI.Run -> CLI.Opts -> Bool -> MultiEyreApi -> IO ()
+runShip (CLI.Run pierPath) opts daemon multi = do
    tid <- myThreadId
    let onTermExit = throwTo tid UserInterrupt
    mStart <- newEmptyMVar
@ -518,6 +535,7 @@ runShip (CLI.Run pierPath) opts daemon = do
              (CLI.oDryFrom opts)
              (toSerfFlags opts)
              mStart
+              multi
    pierConfig = toPierConfig pierPath opts
    networkConfig = toNetworkConfig opts

@ -591,12 +609,12 @@ main = do

  TODO Use logging system instead of printing.
 -}
-runShipRestarting :: STM () -> CLI.Run -> CLI.Opts -> IO ()
-runShipRestarting waitForKillRequ r o = do
+runShipRestarting :: STM () -> CLI.Run -> CLI.Opts -> MultiEyreApi -> IO ()
+runShipRestarting waitForKillRequ r o multi = do
  let pier = pack (CLI.rPierPath r)
-      loop = runShipRestarting waitForKillRequ r o
+      loop = runShipRestarting waitForKillRequ r o multi

-  tid <- asyncBound (runShip r o True)
+  tid <- asyncBound (runShip r o True multi)

  let onShipExit = Left <$> waitCatchSTM tid
      onKillRequ = Right <$> waitForKillRequ
@ -615,21 +633,40 @@ runShipRestarting waitForKillRequ r o = do


 runShips :: CLI.KingOpts -> [(CLI.Run, CLI.Opts, Bool)] -> IO ()
-runShips CLI.KingOpts {..} = \case
-  []                 -> pure ()
-  [(r, o, d)]        -> runShip r o d
-  ships | sharedHttp -> error "TODO Shared HTTP not yet implemented."
-  ships              -> runMultipleShips (ships <&> \(r, o, _) -> (r, o))
-  where sharedHttp = isJust koSharedHttpPort || isJust koSharedHttpsPort
+runShips CLI.KingOpts {..} ships = do
+  let meConf = MultiEyreConf
+        { mecHttpPort      = fromIntegral <$> koSharedHttpPort
+        , mecHttpsPort     = fromIntegral <$> koSharedHttpsPort
+        , mecLocalhostOnly = False -- TODO Localhost-only needs to be
+                                   -- a king-wide option.
+        }

-runMultipleShips :: [(CLI.Run, CLI.Opts)] -> IO ()
-runMultipleShips ships = do
+  {-
+    TODO Need to rework RIO environment to fix this. Should have a
+    bunch of nested contexts:
+
+      - King has started. King has Id. Logging available.
+      - In running environment. MultiEyre and global config available.
+      - In pier environment: pier path and config available.
+      - In running ship environment: serf state, event queue available.
+  -}
+  multi <- runApp (multiEyre meConf)
+
+  go multi ships
+ where
+  go me = \case
+    []          -> pure ()
+    [(r, o, d)] -> runShip r o d me
+    ships       -> runMultipleShips (ships <&> \(r, o, _) -> (r, o)) me
+
+runMultipleShips :: [(CLI.Run, CLI.Opts)] -> MultiEyreApi -> IO ()
+runMultipleShips ships multi = do
  killSignal <- newEmptyTMVarIO

  let waitForKillRequ = readTMVar killSignal

  shipThreads <- for ships $ \(r, o) -> do
-    async (runShipRestarting waitForKillRequ r o)
+    async (runShipRestarting waitForKillRequ r o multi)

  {-
    Since `spin` never returns, this will run until the main
--- a/pkg/hs/urbit-king/lib/Urbit/Vere/Eyre.hs
+++ b/pkg/hs/urbit-king/lib/Urbit/Vere/Eyre.hs
@ -4,7 +4,6 @@

 module Urbit.Vere.Eyre
  ( eyre
-  , multiEyre
  )
 where

@ -15,12 +14,12 @@ import Urbit.King.Config
 import Urbit.Vere.Eyre.PortsFile
 import Urbit.Vere.Eyre.Serv
 import Urbit.Vere.Eyre.Service
+import Urbit.Vere.Eyre.Multi
 import Urbit.Vere.Eyre.Wai
 import Urbit.Vere.Pier.Types

 import Data.List.NonEmpty (NonEmpty((:|)))
 import Data.PEM           (pemParseBS, pemWriteBS)
-import Network.TLS        (Credential)
 import RIO.Prelude        (decodeUtf8Lenient)
 import System.Random      (randomIO)
 import Urbit.Vere.Http    (convertHeaders, unconvertHeaders)
@ -36,9 +35,6 @@ type ReqId = UD

 newtype Drv = Drv (MVar (Maybe Serv))

-data WhichServer = Secure | Insecure | Loopback
-  deriving (Eq)
-
 data SockOpts = SockOpts
  { soLocalhost :: Bool
  , soWhich     :: ServPort
@ -303,101 +299,3 @@ eyre king multi who plan isFake = (initialEvents, runHttpServer)
    HSEResponse (i, req, _seq, ()) ev -> do
      logDebug (displayShow ("EYRE", "%response"))
      execRespActs drv who (fromIntegral req) ev
-
-
-- Multi-Tenet HTTP ------------------------------------------------------------
-
-data MultiEyreConf = MultiEyreConf
-  { mecHttpsPort :: Maybe Port
-  , mecHttpPort :: Maybe Port
-  , mecLocalhostOnly :: Bool
-  }
-
-type OnMultiReq = WhichServer -> Ship -> Word64 -> ReqInfo -> STM ()
-
-type OnMultiKil = Ship -> Word64 -> STM ()
-
-data MultiEyreApi = MultiEyreApi
-  { meaConf :: MultiEyreConf
-  , meaLive :: TVar LiveReqs
-  , meaPlan :: TVar (Map Ship OnMultiReq)
-  , meaCanc :: TVar (Map Ship OnMultiKil)
-  , meaTlsC :: TVar (Map Ship Credential)
-  , meaKill :: STM ()
-  }
-
-joinMultiEyre
-  :: MultiEyreApi
-  -> Ship
-  -> Maybe TlsConfig
-  -> OnMultiReq
-  -> OnMultiKil
-  -> STM ()
-joinMultiEyre api who mTls onReq onKil = do
-  modifyTVar' (meaPlan api) (insertMap who onReq)
-  modifyTVar' (meaCanc api) (insertMap who onKil)
-  for_ mTls $ \tls -> do
-    configCreds tls & \case
-      Left err -> pure ()
-      Right cd -> modifyTVar' (meaTlsC api) (insertMap who cd)
-
-leaveMultiEyre :: MultiEyreApi -> Ship -> STM ()
-leaveMultiEyre MultiEyreApi {..} who = do
-  modifyTVar' meaCanc (deleteMap who)
-  modifyTVar' meaPlan (deleteMap who)
-  modifyTVar' meaTlsC (deleteMap who)
-
-multiEyre
-  :: (HasPierConfig e, HasLogFunc e, HasNetworkConfig e)
-  => MultiEyreConf
-  -> RIO e MultiEyreApi
-multiEyre conf@MultiEyreConf{..} = do
-  vLive <- newTVarIO emptyLiveReqs
-  vPlan <- newTVarIO mempty
-  vCanc <- newTVarIO (mempty :: Map Ship (Ship -> Word64 -> STM ()))
-  vTlsC <- newTVarIO mempty
-
-  let host = if mecLocalhostOnly then SHLocalhost else SHAnyHostOk
-
-  let onReq :: WhichServer -> Ship -> Word64 -> ReqInfo -> STM ()
-      onReq which who reqId reqInfo = do
-        plan <- readTVar vPlan
-        lookup who plan & \case
-          Nothing -> pure ()
-          Just cb -> cb which who reqId reqInfo
-
-  let onKil :: Ship -> Word64 -> STM ()
-      onKil who reqId = do
-        canc <- readTVar vCanc
-        lookup who canc & \case
-          Nothing -> pure ()
-          Just cb -> cb who reqId
-
-  mIns <- for mecHttpPort $ \por -> serv vLive $ ServConf
-    { scHost = host
-    , scPort = SPChoices $ singleton $ fromIntegral por
-    , scRedi = Nothing -- TODO
-    , scType = STMultiHttp $ ReqApi
-        { rcReq = onReq Insecure
-        , rcKil = onKil
-        }
-    }
-
-  mSec <- for mecHttpsPort $ \por -> serv vLive $ ServConf
-    { scHost = host
-    , scPort = SPChoices $ singleton $ fromIntegral por
-    , scRedi = Nothing
-    , scType = STMultiHttps vTlsC $ ReqApi
-        { rcReq = onReq Secure
-        , rcKil = onKil
-        }
-    }
-
-  pure $ MultiEyreApi
-    { meaLive = vLive
-    , meaPlan = vPlan
-    , meaCanc = vCanc
-    , meaTlsC = vTlsC
-    , meaConf = conf
-    , meaKill = traverse_ saKil (toList mIns <> toList mSec)
-    }
--- a/pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/Multi.hs
+++ b/pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/Multi.hs
@ -0,0 +1,124 @@
+{-|
+  Eyre: Http Server Driver
+-}
+
+module Urbit.Vere.Eyre.Multi
+  ( WhichServer(..)
+  , MultiEyreConf(..)
+  , OnMultiReq
+  , OnMultiKil
+  , MultiEyreApi(..)
+  , joinMultiEyre
+  , leaveMultiEyre
+  , multiEyre
+  )
+where
+
+import Urbit.Prelude hiding (Builder)
+
+import Urbit.Arvo           hiding (ServerId, reqUrl, secure)
+import Urbit.Vere.Eyre.Serv
+import Urbit.Vere.Eyre.Wai
+
+import Network.TLS (Credential)
+
+
+-- Types -----------------------------------------------------------------------
+
+data WhichServer = Secure | Insecure | Loopback
+  deriving (Eq)
+
+data MultiEyreConf = MultiEyreConf
+  { mecHttpsPort :: Maybe Port
+  , mecHttpPort :: Maybe Port
+  , mecLocalhostOnly :: Bool
+  }
+
+type OnMultiReq = WhichServer -> Ship -> Word64 -> ReqInfo -> STM ()
+
+type OnMultiKil = Ship -> Word64 -> STM ()
+
+data MultiEyreApi = MultiEyreApi
+  { meaConf :: MultiEyreConf
+  , meaLive :: TVar LiveReqs
+  , meaPlan :: TVar (Map Ship OnMultiReq)
+  , meaCanc :: TVar (Map Ship OnMultiKil)
+  , meaTlsC :: TVar (Map Ship Credential)
+  , meaKill :: STM ()
+  }
+
+
+-- Multi-Tenet HTTP ------------------------------------------------------------
+
+joinMultiEyre
+  :: MultiEyreApi
+  -> Ship
+  -> Maybe TlsConfig
+  -> OnMultiReq
+  -> OnMultiKil
+  -> STM ()
+joinMultiEyre api who mTls onReq onKil = do
+  modifyTVar' (meaPlan api) (insertMap who onReq)
+  modifyTVar' (meaCanc api) (insertMap who onKil)
+  for_ mTls $ \tls -> do
+    configCreds tls & \case
+      Left err -> pure ()
+      Right cd -> modifyTVar' (meaTlsC api) (insertMap who cd)
+
+leaveMultiEyre :: MultiEyreApi -> Ship -> STM ()
+leaveMultiEyre MultiEyreApi {..} who = do
+  modifyTVar' meaCanc (deleteMap who)
+  modifyTVar' meaPlan (deleteMap who)
+  modifyTVar' meaTlsC (deleteMap who)
+
+multiEyre :: HasLogFunc e => MultiEyreConf -> RIO e MultiEyreApi
+multiEyre conf@MultiEyreConf{..} = do
+  vLive <- newTVarIO emptyLiveReqs
+  vPlan <- newTVarIO mempty
+  vCanc <- newTVarIO (mempty :: Map Ship (Ship -> Word64 -> STM ()))
+  vTlsC <- newTVarIO mempty
+
+  let host = if mecLocalhostOnly then SHLocalhost else SHAnyHostOk
+
+  let onReq :: WhichServer -> Ship -> Word64 -> ReqInfo -> STM ()
+      onReq which who reqId reqInfo = do
+        plan <- readTVar vPlan
+        lookup who plan & \case
+          Nothing -> pure ()
+          Just cb -> cb which who reqId reqInfo
+
+  let onKil :: Ship -> Word64 -> STM ()
+      onKil who reqId = do
+        canc <- readTVar vCanc
+        lookup who canc & \case
+          Nothing -> pure ()
+          Just cb -> cb who reqId
+
+  mIns <- for mecHttpPort $ \por -> serv vLive $ ServConf
+    { scHost = host
+    , scPort = SPChoices $ singleton $ fromIntegral por
+    , scRedi = Nothing -- TODO
+    , scType = STMultiHttp $ ReqApi
+        { rcReq = onReq Insecure
+        , rcKil = onKil
+        }
+    }
+
+  mSec <- for mecHttpsPort $ \por -> serv vLive $ ServConf
+    { scHost = host
+    , scPort = SPChoices $ singleton $ fromIntegral por
+    , scRedi = Nothing
+    , scType = STMultiHttps vTlsC $ ReqApi
+        { rcReq = onReq Secure
+        , rcKil = onKil
+        }
+    }
+
+  pure $ MultiEyreApi
+    { meaLive = vLive
+    , meaPlan = vPlan
+    , meaCanc = vCanc
+    , meaTlsC = vTlsC
+    , meaConf = conf
+    , meaKill = traverse_ saKil (toList mIns <> toList mSec)
+    }
--- a/pkg/hs/urbit-king/lib/Urbit/Vere/Pier.hs
+++ b/pkg/hs/urbit-king/lib/Urbit/Vere/Pier.hs
@ -24,6 +24,7 @@ import Urbit.Vere.Ames        (ames)
 import Urbit.Vere.Behn        (behn)
 import Urbit.Vere.Clay        (clay)
 import Urbit.Vere.Eyre        (eyre)
+import Urbit.Vere.Eyre.Multi  (MultiEyreApi)
 import Urbit.Vere.Http.Client (client)
 import Urbit.Vere.Log         (EventLog)
 import Urbit.Vere.Serf        (Serf, SerfState(..), doJob, sStderr)
@ -173,8 +174,9 @@ acquireWorker act = mkRAcquire (async act) cancel
 pier :: ∀e. (HasConfigDir e, HasLogFunc e, HasNetworkConfig e, HasPierConfig e)
     => (Serf e, EventLog, SerfState)
     -> MVar ()
+     -> MultiEyreApi
     -> RAcquire e ()
-pier (serf, log, ss) mStart = do
+pier (serf, log, ss) mStart multi = do
    computeQ  <- newTQueueIO
    persistQ  <- newTQueueIO
    executeQ  <- newTQueueIO
@ -222,7 +224,7 @@ pier (serf, log, ss) mStart = do
    -- add them.
    let showErr = atomically . Term.trace muxed . (flip append "\r\n")
    let (bootEvents, startDrivers) =
-            drivers inst ship (isFake logId)
+            drivers inst multi ship (isFake logId)
                (writeTQueue computeQ)
                shutdownEvent
                (Term.TSize{tsWide=80, tsTall=24}, muxed)
@ -283,18 +285,23 @@ data Drivers e = Drivers
    , dTerm       :: EffCb e TermEf
    }

-drivers :: (HasLogFunc e, HasNetworkConfig e, HasPierConfig e)
-        => KingId -> Ship -> Bool -> (Ev -> STM ())
-        -> STM()
-        -> (Term.TSize, Term.Client)
-        -> (Text -> RIO e ())
-        -> ([Ev], RAcquire e (Drivers e))
-drivers inst who isFake plan shutdownSTM termSys stderr =
+drivers
+  :: (HasLogFunc e, HasNetworkConfig e, HasPierConfig e)
+  => KingId
+  -> MultiEyreApi
+  -> Ship
+  -> Bool
+  -> (Ev -> STM ())
+  -> STM ()
+  -> (Term.TSize, Term.Client)
+  -> (Text -> RIO e ())
+  -> ([Ev], RAcquire e (Drivers e))
+drivers inst multi who isFake plan shutdownSTM termSys stderr =
    (initialEvents, runDrivers)
  where
    (behnBorn, runBehn) = behn inst plan
    (amesBorn, runAmes) = ames inst who isFake plan stderr
-    (httpBorn, runHttp) = eyre inst (error "TODO") who plan isFake
+    (httpBorn, runHttp) = eyre inst multi who plan isFake
    (clayBorn, runClay) = clay inst plan
    (irisBorn, runIris) = client inst plan
    (termBorn, runTerm) = Term.term termSys shutdownSTM inst plan