king: eyre: [WIP] Got multi-tenet HTTPS working.

pkg/hs/urbit-king/lib/Urbit/Vere/Ames/UDP.hs

@@ -97,15 +97,14 @@ forceBind por hos = go
 -}
 sendPacket :: HasLogFunc e => ByteString -> SockAddr -> Socket -> RIO e Bool
 sendPacket fullBytes adr sok = do
-  logTrace ("AMES: UDP: Sending packet")
+  logTrace $ displayShow ("AMES", "UDP", "Sending packet.")
   res <- io $ tryIOError $ go fullBytes
   case res of
     Left err -> do
-      logError $ display ("AMES: UDP: " <> tshow err)
-      logError "AMES: UDP: Failed to send packet"
+      logError $ displayShow ("AMES", "UDP", "Failed to send packet", err)
       pure False
     Right () -> do
-      logError "AMES: UDP: Packet sent"
+      logTrace $ displayShow ("AMES", "UDP", "Packet sent.")
       pure True
  where
   go byt = do
@@ -138,7 +137,7 @@ recvPacket sok = do
 -}
 fakeUdpServ :: HasLogFunc e => RIO e UdpServ
 fakeUdpServ = do
-  logTrace "AMES: UDP: \"Starting\" fake UDP server."
+  logTrace $ displayShow ("AMES", "UDP", "\"Starting\" fake UDP server.")
   pure UdpServ { .. }
  where
   usSend = \_ _ -> pure ()
@@ -154,7 +153,7 @@ fakeUdpServ = do
 realUdpServ
   :: forall e . HasLogFunc e => PortNumber -> HostAddress -> RIO e UdpServ
 realUdpServ por hos = do
-  logTrace "AMES: UDP: Starting real UDP server."
+  logTrace $ displayShow ("AMES", "UDP", "Starting real UDP server.")
 
   env <- ask
 
@@ -174,7 +173,9 @@ realUdpServ por hos = do
   -}
   let signalBrokenSocket :: Socket -> RIO e ()
       signalBrokenSocket sock = do
-        logTrace "AMES: UDP: Socket broken. Requesting new socket"
+        logTrace $ displayShow ("AMES", "UDP"
+                               , "Socket broken. Requesting new socket"
+                               )
         atomically $ do
           mSock <- readTVar vSock
           mFail <- tryReadTMVar vFail
@@ -186,7 +187,8 @@ realUdpServ por hos = do
       enqueueRecvPacket p a b = do
         did <- atomically (tryWriteTBQueue qRecv (p, a, b))
         when (did == False) $ do
-          logWarn "AMES: UDP: Dropping inbound packet because queue is full."
+          logWarn $ displayShow $ ("AMES", "UDP",)
+            "Dropping inbound packet because queue is full."
 
       enqueueSendPacket :: SockAddr -> ByteString -> RIO e ()
       enqueueSendPacket a b = do

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

@@ -172,7 +172,7 @@ startServ
   -> (Ev -> STM ())
   -> RIO e Serv
 startServ multi who isFake conf plan = do
-  logTrace "startServ"
+  logTrace (displayShow ("EYRE", "startServ"))
 
   let vLive = meaLive multi
 
@@ -180,6 +180,14 @@ startServ multi who isFake conf plan = do
 
   let mTls = hscSecure conf >>= parseTlsConfig
 
+  mCre <- mTls & \case
+   Nothing -> pure Nothing
+   Just tc -> configCreds tc & \case
+     Right rs -> pure (Just rs)
+     Left err -> do
+       logError "Couldn't Load TLS Credentials."
+       pure Nothing
+
   ptt <- httpServerPorts isFake
 
   {-
@@ -200,9 +208,11 @@ startServ multi who isFake conf plan = do
   let onKilReq :: Ship -> Word64 -> STM ()
       onKilReq _ship = plan . cancelEv srvId . fromIntegral
 
-  atomically (joinMultiEyre multi who mTls onReq onKilReq)
+  logTrace (displayShow ("EYRE", "joinMultiEyre", who, mTls, mCre))
 
-  logTrace "Starting loopback server"
+  atomically (joinMultiEyre multi who mCre onReq onKilReq)
+
+  logTrace $ displayShow ("EYRE", "Starting loopback server")
   lop <- serv vLive $ ServConf
     { scHost = soHost (pttLop ptt)
     , scPort = soWhich (pttLop ptt)
@@ -213,7 +223,7 @@ startServ multi who isFake conf plan = do
         }
     }
 
-  logTrace "Starting insecure server"
+  logTrace $ displayShow ("EYRE", "Starting insecure server")
   ins <- serv vLive $ ServConf
     { scHost = soHost (pttIns ptt)
     , scPort = soWhich (pttIns ptt)

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

@@ -54,17 +54,15 @@ data MultiEyreApi = MultiEyreApi
 joinMultiEyre
   :: MultiEyreApi
   -> Ship
-  -> Maybe TlsConfig
+  -> Maybe Credential
   -> 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)
+  for_ mTls $ \creds -> do
+    modifyTVar' (meaTlsC api) (insertMap who creds)
 
 leaveMultiEyre :: MultiEyreApi -> Ship -> STM ()
 leaveMultiEyre MultiEyreApi {..} who = do