king: eyre: Got multi-tenet HTTP working.

pkg/hs/urbit-king/lib/Urbit/King/Main.hs

@@ -91,6 +91,7 @@ import Control.Exception      (AsyncException(UserInterrupt))
 import Control.Lens           ((&))
 import System.Process         (system)
 import Text.Show.Pretty       (pPrint)
+import Urbit.King.App         (App)
 import Urbit.King.App         (runApp, runAppLogFile, runAppNoLog, runPierApp)
 import Urbit.King.App         (HasConfigDir(..), HasStderrLogFunc(..))
 import Urbit.Noun.Conversions (cordToUW)
@@ -514,8 +515,8 @@ newShip' multi CLI.New{..} opts
 ------  tryBootFromPill (CLI.oExit opts) pill nLite flags ship bootEvent
 
 
-runShip :: CLI.Run -> CLI.Opts -> Bool -> MultiEyreApi -> IO ()
-runShip (CLI.Run pierPath) opts daemon multi = do
+runShip :: MonadIO m => CLI.Run -> CLI.Opts -> Bool -> MultiEyreApi -> m ()
+runShip (CLI.Run pierPath) opts daemon multi = io $ do
     tid <- myThreadId
     let onTermExit = throwTo tid UserInterrupt
     mStart <- newEmptyMVar
@@ -588,7 +589,7 @@ main = do
     Sys.installHandler Sys.sigINT  (Sys.Catch onKillSig) Nothing
 
     CLI.parseArgs >>= \case
-        CLI.CmdRun ko ships                     -> runShips ko ships
+        CLI.CmdRun ko ships                     -> runApp $ runShips ko ships
         CLI.CmdNew n o                          -> runApp $ newShip n o
         CLI.CmdBug (CLI.CollectAllFX pax)       -> runApp $ collectAllFx pax
         CLI.CmdBug (CLI.EventBrowser pax)       -> runApp $ startBrowser pax
@@ -632,7 +633,7 @@ runShipRestarting waitForKillRequ r o multi = do
       putStrLn ("Ship terminated: " <> pier)
 
 
-runShips :: CLI.KingOpts -> [(CLI.Run, CLI.Opts, Bool)] -> IO ()
+runShips :: CLI.KingOpts -> [(CLI.Run, CLI.Opts, Bool)] -> RIO App ()
 runShips CLI.KingOpts {..} ships = do
   let meConf = MultiEyreConf
         { mecHttpPort      = fromIntegral <$> koSharedHttpPort
@@ -650,7 +651,7 @@ runShips CLI.KingOpts {..} ships = do
       - In pier environment: pier path and config available.
       - In running ship environment: serf state, event queue available.
   -}
-  multi <- runApp (multiEyre meConf)
+  multi <- multiEyre meConf
 
   go multi ships
  where
@@ -659,8 +660,8 @@ runShips CLI.KingOpts {..} ships = do
     [(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
+runMultipleShips :: MonadIO m => [(CLI.Run, CLI.Opts)] -> MultiEyreApi -> m ()
+runMultipleShips ships multi = io $ do
   killSignal <- newEmptyTMVarIO
 
   let waitForKillRequ = readTMVar killSignal

pkg/hs/urbit-king/lib/Urbit/Vere/Eyre.hs

@@ -174,6 +174,8 @@ startServ
 startServ multi who isFake conf plan = do
   logTrace "startServ"
 
+  let vLive = meaLive multi
+
   srvId <- io $ ServId . UV . fromIntegral <$> (randomIO :: IO Word32)
 
   let mTls = hscSecure conf >>= parseTlsConfig
@@ -191,8 +193,6 @@ startServ multi who isFake conf plan = do
   let soHost :: SockOpts -> ServHost
       soHost so = if soLocalhost so then SHLocalhost else SHAnyHostOk
 
-  vLive <- newTVarIO emptyLiveReqs
-
   let onReq :: WhichServer -> Ship -> Word64 -> ReqInfo -> STM ()
       onReq which _ship reqId reqInfo =
         plan (requestEvent srvId which reqId reqInfo)

pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/Multi.hs

@@ -33,6 +33,7 @@ data MultiEyreConf = MultiEyreConf
   , mecHttpPort :: Maybe Port
   , mecLocalhostOnly :: Bool
   }
+ deriving (Show)
 
 type OnMultiReq = WhichServer -> Ship -> Word64 -> ReqInfo -> STM ()
 
@@ -72,7 +73,9 @@ leaveMultiEyre MultiEyreApi {..} who = do
   modifyTVar' meaTlsC (deleteMap who)
 
 multiEyre :: HasLogFunc e => MultiEyreConf -> RIO e MultiEyreApi
-multiEyre conf@MultiEyreConf{..} = do
+multiEyre conf@MultiEyreConf {..} = do
+  logTrace (displayShow ("EYRE", "MULTI", conf))
+
   vLive <- newTVarIO emptyLiveReqs
   vPlan <- newTVarIO mempty
   vCanc <- newTVarIO (mempty :: Map Ship (Ship -> Word64 -> STM ()))
@@ -94,7 +97,9 @@ multiEyre conf@MultiEyreConf{..} = do
           Nothing -> pure ()
           Just cb -> cb who reqId
 
-  mIns <- for mecHttpPort $ \por -> serv vLive $ ServConf
+  mIns <- for mecHttpPort $ \por -> do
+    logTrace (displayShow ("EYRE", "MULTI", "HTTP", por))
+    serv vLive $ ServConf
       { scHost = host
       , scPort = SPChoices $ singleton $ fromIntegral por
       , scRedi = Nothing -- TODO
@@ -104,11 +109,13 @@ multiEyre conf@MultiEyreConf{..} = do
           }
       }
 
-  mSec <- for mecHttpsPort $ \por -> serv vLive $ ServConf
+  mSec <- for mecHttpsPort $ \por -> do
+    logTrace (displayShow ("EYRE", "MULTI", "HTTPS", por))
+    serv vLive $ ServConf
       { scHost = host
       , scPort = SPChoices $ singleton $ fromIntegral por
       , scRedi = Nothing
-    , scType = STMultiHttps vTlsC $ ReqApi
+      , scType = STMultiHttps (MTC vTlsC) $ ReqApi
           { rcReq = onReq Secure
           , rcKil = onKil
           }

pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/Serv.hs

@@ -21,7 +21,7 @@
 module Urbit.Vere.Eyre.Serv
   ( ServApi(..)
   , TlsConfig(..)
-  , MultiTlsConfig
+  , MultiTlsConfig(..)
   , ReqApi(..)
   , ServType(..)
   , ServPort(..)
@@ -61,27 +61,37 @@ data TlsConfig = TlsConfig
   , tcCerti :: ByteString
   , tcChain :: [ByteString]
   }
+ deriving (Show)
 
-type MultiTlsConfig = TVar (Map Ship Credential)
+newtype MultiTlsConfig = MTC (TVar (Map Ship Credential))
+
+instance Show MultiTlsConfig where
+  show = const "MultiTlsConfig"
 
 data ReqApi = ReqApi
   { rcReq :: Ship -> Word64 -> E.ReqInfo -> STM ()
   , rcKil :: Ship -> Word64 -> STM ()
   }
 
+instance Show ReqApi where
+  show = const "ReqApi"
+
 data ServType
   = STHttp Ship ReqApi
   | STHttps Ship TlsConfig ReqApi
   | STMultiHttp ReqApi
   | STMultiHttps MultiTlsConfig ReqApi
+ deriving (Show)
 
 data ServPort
   = SPAnyPort
   | SPChoices (NonEmpty W.Port)
+ deriving (Show)
 
 data ServHost
   = SHLocalhost
   | SHAnyHostOk
+ deriving (Show)
 
 data ServConf = ServConf
   { scType :: ServType
@@ -89,6 +99,7 @@ data ServConf = ServConf
   , scPort :: ServPort
   , scRedi :: Maybe W.Port
   }
+ deriving (Show)
 
 
 -- Opening Sockets -------------------------------------------------------------
@@ -179,6 +190,7 @@ forceOpenSocket hos por = mkRAcquire opn kil
   kil = io . Net.close . snd
 
   opn = do
+    logTrace (displayShow ("EYRE", "SERV", "forceOpenSocket", hos, por))
     (p, s) <- retry $ case por of
       SPAnyPort    -> tryOpenAny bind
       SPChoices ps -> tryOpenChoices bind ps
@@ -202,8 +214,8 @@ hostShip (Just bs) = byteShip (hedLabel bs) & \case
   bytePatp = Ob.parsePatp . decodeUtf8Lenient
   hedLabel = fst . break (== fromIntegral (C.ord '.'))
 
-onSniHdr :: TVar (Map Ship Credential) -> Maybe String -> IO Credentials
-onSniHdr mtls mHos = do
+onSniHdr :: MultiTlsConfig -> Maybe String -> IO Credentials
+onSniHdr (MTC mtls) mHos = do
   ship <- hostShip (encodeUtf8 . pack <$> mHos)
   tabl <- atomically (readTVar mtls)
   tcfg <- lookup ship tabl & maybe (notRunning ship) pure
@@ -271,14 +283,13 @@ configCreds TlsConfig {..} =
     Right rs  -> Right rs
 
 serv :: HasLogFunc e => TVar E.LiveReqs -> ServConf -> RIO e ServApi
-serv vLive ServConf {..} = do
+serv vLive conf@ServConf {..} = do
+  logTrace (displayShow ("EYRE", "SERV", "Start", conf))
   kil <- newEmptyTMVarIO
   por <- newEmptyTMVarIO
 
-  void $ async $ do
   tid <- async (runServ por)
-    atomically (takeTMVar kil)
-    cancel tid
+  _   <- async (atomically (takeTMVar kil) >> cancel tid)
 
   pure $ ServApi
     { saKil = void (tryPutTMVar kil ())
@@ -286,6 +297,7 @@ serv vLive ServConf {..} = do
     }
  where
   runServ vPort = do
+    logTrace (displayShow ("EYRE", "SERV", "runServ"))
     rwith (forceOpenSocket scHost scPort) $ \(por, sok) -> do
       atomically (putTMVar vPort por)
       startServer scType scHost por sok scRedi vLive

pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/Wai.hs

@@ -136,11 +136,6 @@ noHeader = do
   logError "Response block with no response header."
   error "Bad HttpEvent: Response block with no response header."
 
-emptyChunk :: HasLogFunc e => RIO e a
-emptyChunk = do
-  logError "Bad response action: empty chunk"
-  error "Bad response action: empty chunk"
-
 dupHead :: HasLogFunc e => RIO e a
 dupHead = do
   logError "Multiple %head actions on one request"
@@ -165,7 +160,7 @@ streamBlocks env init getAct = send init >> loop
     RADone       -> pure ()
     RABloc c     -> send c >> loop
 
-  send "" = runRIO env emptyChunk
+  send "" = pure ()
   send c  = do
     runRIO env (logTrace (display ("sending chunk " <> tshow c)))
     yield $ Chunk $ fromByteString c