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

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
+runOrExitImmediately
-                        , HasConfigDir e
+  :: (HasLogFunc e, HasNetworkConfig e, HasPierConfig e, HasConfigDir e)
-                        )
+  => RAcquire e (Serf e, Log.EventLog, SerfState)
-                     => RAcquire e (Serf e, Log.EventLog, SerfState)
+  -> Bool
-                     -> Bool
+  -> MVar ()
-                     -> MVar ()
+  -> MultiEyreApi
-                     -> RIO e ()
+  -> RIO e ()
-runOrExitImmediately getPier oExit mStart =
+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
+tryPlayShip
-               , HasPierConfig e, HasConfigDir e
+  :: ( HasStderrLogFunc e
-               )
+     , HasLogFunc e
-            => Bool -> Bool -> Maybe Word64 -> Serf.Flags -> MVar () -> RIO e ()
+     , HasNetworkConfig e
-tryPlayShip exitImmediately fullReplay playFrom flags mStart = do
+     , 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 -> CLI.Opts -> Bool -> MultiEyreApi -> IO ()
-runShip (CLI.Run pierPath) opts daemon = do
+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 :: STM () -> CLI.Run -> CLI.Opts -> MultiEyreApi -> IO ()
-runShipRestarting waitForKillRequ r o = do
+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
+runShips CLI.KingOpts {..} ships = do
-  []                 -> pure ()
+  let meConf = MultiEyreConf
-  [(r, o, d)]        -> runShip r o d
+        { mecHttpPort      = fromIntegral <$> koSharedHttpPort
-  ships | sharedHttp -> error "TODO Shared HTTP not yet implemented."
+        , mecHttpsPort     = fromIntegral <$> koSharedHttpsPort
-  ships              -> runMultipleShips (ships <&> \(r, o, _) -> (r, o))
+        , mecLocalhostOnly = False -- TODO Localhost-only needs to be
-  where sharedHttp = isJust koSharedHttpPort || isJust koSharedHttpsPort
+                                   -- 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

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)
-    }

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)
+    }

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)
+drivers
-        => KingId -> Ship -> Bool -> (Ev -> STM ())
+  :: (HasLogFunc e, HasNetworkConfig e, HasPierConfig e)
-        -> STM()
+  => KingId
-        -> (Term.TSize, Term.Client)
+  -> MultiEyreApi
-        -> (Text -> RIO e ())
+  -> Ship
-        -> ([Ev], RAcquire e (Drivers e))
+  -> Bool
-drivers inst who isFake plan shutdownSTM termSys stderr =
+  -> (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