king: implement ~_~/slog without cookies; problems with MultiEyre

pkg/hs/urbit-king/lib/Urbit/Prelude.hs

@@ -15,6 +15,7 @@ module Urbit.Prelude
     , module RIO
     , io, rio
     , logTrace
+    , acquireWorker, acquireWorkerBound
     ) where
 
 import ClassyPrelude
@@ -46,3 +47,21 @@ rio = liftRIO
 
 logTrace :: HasLogFunc e => Utf8Builder -> RIO e ()
 logTrace = logOther "trace"
+
+
+-- Utils for Spawning Worker Threads -------------------------------------------
+
+acquireWorker :: HasLogFunc e => Text -> RIO e () -> RAcquire e (Async ())
+acquireWorker nam act = mkRAcquire (async act) kill
+ where
+  kill tid = do
+    logInfo ("Killing worker thread: " <> display nam)
+    cancel tid
+
+acquireWorkerBound :: HasLogFunc e => Text -> RIO e () -> RAcquire e (Async ())
+acquireWorkerBound nam act = mkRAcquire (asyncBound act) kill
+ where
+  kill tid = do
+    logInfo ("Killing worker thread: " <> display nam)
+    cancel tid
+

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

@@ -26,7 +26,8 @@ import RIO.Prelude        (decodeUtf8Lenient)
 import System.Random      (randomIO)
 import Urbit.Vere.Http    (convertHeaders, unconvertHeaders)
 
-import qualified Network.HTTP.Types as H
+import qualified Network.HTTP.Types  as H
+import qualified Network.Wai.Conduit as W
 
 
 -- Types -----------------------------------------------------------------------
@@ -176,8 +177,9 @@ startServ
   -> HttpServerConf
   -> (EvErr -> STM ())
   -> (Text -> RIO e ())
+  -> W.Application
   -> RIO e Serv
-startServ who isFake conf plan stderr = do
+startServ who isFake conf plan stderr sub = do
   logInfo (displayShow ("EYRE", "startServ"))
 
   multi <- view multiEyreApiL
@@ -226,7 +228,7 @@ startServ who isFake conf plan stderr = do
   atomically (joinMultiEyre multi who mCre onReq onKilReq)
 
   logInfo $ displayShow ("EYRE", "Starting loopback server")
-  lop <- serv vLive $ ServConf
+  lop <- serv sub vLive $ ServConf
     { scHost = soHost (pttLop ptt)
     , scPort = soWhich (pttLop ptt)
     , scRedi = Nothing
@@ -238,7 +240,7 @@ startServ who isFake conf plan stderr = do
     }
 
   logInfo $ displayShow ("EYRE", "Starting insecure server")
-  ins <- serv vLive $ ServConf
+  ins <- serv sub vLive $ ServConf
     { scHost = soHost (pttIns ptt)
     , scPort = soWhich (pttIns ptt)
     , scRedi = secRedi
@@ -251,7 +253,7 @@ startServ who isFake conf plan stderr = do
 
   mSec <- for mTls $ \tls -> do
     logInfo "Starting secure server"
-    serv vLive $ ServConf
+    serv sub vLive $ ServConf
       { scHost = soHost (pttSec ptt)
       , scPort = soWhich (pttSec ptt)
       , scRedi = Nothing
@@ -291,14 +293,15 @@ eyre'
   => Ship
   -> Bool
   -> (Text -> RIO e ())
+  -> W.Application
   -> RIO e ([Ev], RAcquire e (DriverApi HttpServerEf))
 
-eyre' who isFake stderr = do
+eyre' who isFake stderr sub = do
   ventQ :: TQueue EvErr <- newTQueueIO
   env <- ask
 
   let (bornEvs, startDriver) =
-        eyre env who (writeTQueue ventQ) isFake stderr
+        eyre env who (writeTQueue ventQ) isFake stderr sub
 
   let runDriver = do
         diOnEffect <- startDriver
@@ -327,8 +330,9 @@ eyre
   -> (EvErr -> STM ())
   -> Bool
   -> (Text -> RIO e ())
+  -> W.Application
   -> ([Ev], RAcquire e (HttpServerEf -> IO ()))
-eyre env who plan isFake stderr = (initialEvents, runHttpServer)
+eyre env who plan isFake sub stderr = (initialEvents, runHttpServer)
  where
   king = fromIntegral (env ^. kingIdL)
   multi = env ^. multiEyreApiL
@@ -352,7 +356,7 @@ eyre env who plan isFake stderr = (initialEvents, runHttpServer)
   restart :: Drv -> HttpServerConf -> RIO e Serv
   restart (Drv var) conf = do
     logInfo "Restarting http server"
-    let startAct = startServ who isFake conf plan stderr
+    let startAct = startServ who isFake conf plan sub stderr
     res <- fromEither =<< restartService var startAct kill
     logInfo "Done restating http server"
     pure res

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

@@ -22,6 +22,8 @@ import Urbit.Vere.Eyre.Wai
 
 import Network.TLS (Credential)
 
+import Network.Wai as W
+
 
 -- Types -----------------------------------------------------------------------
 
@@ -70,8 +72,8 @@ leaveMultiEyre MultiEyreApi {..} who = do
   modifyTVar' meaPlan (deleteMap who)
   modifyTVar' meaTlsC (deleteMap who)
 
-multiEyre :: HasLogFunc e => MultiEyreConf -> RIO e MultiEyreApi
-multiEyre conf@MultiEyreConf {..} = do
+multiEyre :: HasLogFunc e => MultiEyreConf -> W.Application -> RIO e MultiEyreApi
+multiEyre conf@MultiEyreConf {..} sub = do
   logInfo (displayShow ("EYRE", "MULTI", conf))
 
   vLive <- io emptyLiveReqs >>= newTVarIO
@@ -97,7 +99,7 @@ multiEyre conf@MultiEyreConf {..} = do
 
   mIns <- for mecHttpPort $ \por -> do
     logInfo (displayShow ("EYRE", "MULTI", "HTTP", por))
-    serv vLive $ ServConf
+    serv sub vLive $ ServConf
       { scHost = host
       , scPort = SPChoices $ singleton $ fromIntegral por
       , scRedi = Nothing -- TODO
@@ -110,7 +112,7 @@ multiEyre conf@MultiEyreConf {..} = do
 
   mSec <- for mecHttpsPort $ \por -> do
     logInfo (displayShow ("EYRE", "MULTI", "HTTPS", por))
-    serv vLive $ ServConf
+    serv sub vLive $ ServConf
       { scHost = host
       , scPort = SPChoices $ singleton $ fromIntegral por
       , scRedi = Nothing

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

@@ -247,9 +247,10 @@ startServer
   -> W.Port
   -> Net.Socket
   -> Maybe W.Port
+  -> W.Application
   -> TVar E.LiveReqs
   -> RIO e ()
-startServer typ hos por sok red vLive = do
+startServer typ hos por sok red sub vLive = do
   envir <- ask
 
   let host = case hos of
@@ -262,7 +263,8 @@ startServer typ hos por sok red vLive = do
           & W.setPort (fromIntegral por)
           & W.setTimeout (5 * 60)
 
-  let runAppl who = E.app envir who vLive
+  -- TODO build Eyre.Site.app in pier, thread through here
+  let runAppl who = E.app envir who sub vLive
       reqShip = hostShip . W.requestHeaderHost
 
   case typ of
@@ -329,8 +331,8 @@ getFirstTlsConfig (MTC var) = do
     []  -> STM.retry
     x:_ -> pure (fst x)
 
-realServ :: HasLogFunc e => TVar E.LiveReqs -> ServConf -> RIO e ServApi
-realServ vLive conf@ServConf {..} = do
+realServ :: HasLogFunc e => W.Application -> TVar E.LiveReqs -> ServConf -> RIO e ServApi
+realServ sub vLive conf@ServConf {..} = do
   logInfo (displayShow ("EYRE", "SERV", "Running Real Server"))
   kil <- newEmptyTMVarIO
   por <- newEmptyTMVarIO
@@ -347,10 +349,10 @@ realServ vLive conf@ServConf {..} = do
     logInfo (displayShow ("EYRE", "SERV", "runServ"))
     rwith (forceOpenSocket scHost scPort) $ \(por, sok) -> do
       atomically (putTMVar vPort por)
-      startServer scType scHost por sok scRedi vLive
+      startServer scType scHost por sok scRedi sub vLive
 
-serv :: HasLogFunc e => TVar E.LiveReqs -> ServConf -> RIO e ServApi
-serv vLive conf = do
+serv :: HasLogFunc e => W.Application -> TVar E.LiveReqs -> ServConf -> RIO e ServApi
+serv sub vLive conf = do
   if scFake conf
     then fakeServ conf
-    else realServ vLive conf
+    else realServ sub vLive conf

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

@@ -0,0 +1,53 @@
+module Urbit.Vere.Eyre.Site (app) where
+
+import Urbit.Prelude hiding (Builder)
+
+import Data.ByteString.Builder
+
+import Data.Conduit       (ConduitT, Flush(..), yield)
+import Data.Text.Encoding (encodeUtf8Builder)
+import Urbit.Noun.Tank    (wash)
+
+import qualified Network.HTTP.Types  as H
+import qualified Network.Wai         as W
+import qualified Network.Wai.Conduit as W
+
+data SlogAction
+  = KeepAlive
+  | Slog (Atom, Tank)
+
+-- veify that if you have multiple open uwu slogs, you multiplex
+-- thread TVar func and this server through from pier (loopback only)
+-- LATER check cookies & scry, support on all servers
+
+conduit :: SlogAction -> ConduitT () (Flush Builder) IO ()
+conduit a = do
+  case a of
+    KeepAlive -> pure ()
+    Slog (_, t) -> for_ (wash (WashCfg 0 80) (tankTree t)) $ \l -> do
+      yield $ Chunk "data:"
+      yield $ Chunk $ encodeUtf8Builder $ unTape l
+      yield $ Chunk "\n"
+  yield $ Chunk "\n"
+  yield $ Flush
+
+app :: HasLogFunc e
+    => TVar ((Atom, Tank) -> IO ())
+    -> RAcquire e W.Application
+app func = do
+  slogQ :: TQueue (Atom, Tank) <- newTQueueIO
+  baton :: TMVar ()            <- newEmptyTMVarIO
+  atomically $ writeTVar func (\s -> atomically $ writeTQueue slogQ s)
+  acquireWorker "Runtime subsite keep-alive" $ forever $ do
+    atomically $ putTMVar baton ()
+    threadDelay 30_000_000
+
+  let action = (KeepAlive <$ takeTMVar baton)  -- every 30s
+           <|> (Slog <$> readTQueue slogQ)
+  
+  -- TODO write more compactly
+  let loop = forever (atomically action >>= conduit)
+
+  pure $ \req respond -> respond $ case W.pathInfo req of
+    ("~_~":"slog":_) -> W.responseSource (H.mkStatus 200 "OK")        [] loop
+    _                -> W.responseLBS    (H.mkStatus 404 "Not Found") [] ""

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

@@ -25,6 +25,7 @@ module Urbit.Vere.Eyre.Wai
 where
 
 import Urbit.Prelude hiding (Builder)
+import Urbit.Prelude (RIO)
 
 import Data.Binary.Builder (Builder, fromByteString)
 import Data.Bits           (shiftL, (.|.))
@@ -206,24 +207,28 @@ app
   :: HasLogFunc e
   => e
   -> Ship
+  -> W.Application
   -> TVar LiveReqs
   -> (Word64 -> ReqInfo -> STM ())
   -> (Word64 -> STM ())
   -> W.Application
-app env who liv inform cancel req respond =
-  runRIO env $ rwith (liveReq who liv) $ \(reqId, respApi) -> do
-    bod <- io (toStrict <$> W.strictRequestBody req)
-    met <- maybe (error "bad method") pure (cookMeth req)
-
-    let adr = reqAddr req
-        hdr = W.requestHeaders req
-        url = reqUrl req
-
-    atomically $ inform reqId $ ReqInfo adr met url hdr bod
-
-    try (sendResponse respond respApi) >>= \case
-      Right rr  -> pure rr
-      Left  exn -> do
-        atomically (cancel reqId)
-        logError $ display ("Exception during request" <> tshow exn)
-        throwIO (exn :: SomeException)
+app env who kingSubsite liv inform cancel req respond =
+  case W.pathInfo req of
+    ("~_~":_) -> kingSubsite req respond
+    _ ->
+      runRIO env $ rwith (liveReq who liv) $ \(reqId, respApi) -> do
+        bod <- io (toStrict <$> W.strictRequestBody req)
+        met <- maybe (error "bad method") pure (cookMeth req)
+    
+        let adr = reqAddr req
+            hdr = W.requestHeaders req
+            url = reqUrl req
+        
+        atomically $ inform reqId $ ReqInfo adr met url hdr bod
+    
+        try (sendResponse respond respApi) >>= \case
+          Right rr  -> pure rr
+          Left  exn -> do
+            atomically (cancel reqId)
+            logError $ display ("Exception during request" <> tshow exn)
+            throwIO (exn :: SomeException)

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

@@ -35,6 +35,7 @@ import Urbit.TermSize         (TermSize(..), termSize)
 import Urbit.Vere.Serf        (Serf)
 
 import qualified Data.Text              as T
+import qualified Network.Wai            as W
 import qualified System.Entropy         as Ent
 import qualified Urbit.EventLog.LMDB    as Log
 import qualified Urbit.King.API         as King
@@ -43,6 +44,7 @@ import qualified Urbit.Vere.Ames        as Ames
 import qualified Urbit.Vere.Behn        as Behn
 import qualified Urbit.Vere.Clay        as Clay
 import qualified Urbit.Vere.Eyre        as Eyre
+import qualified Urbit.Vere.Eyre.Site   as Site
 import qualified Urbit.Vere.Http.Client as Iris
 import qualified Urbit.Vere.Serf        as Serf
 import qualified Urbit.Vere.Term        as Term
@@ -240,24 +242,6 @@ getSnapshot top last = do
     pure $ sort (filter (<= fromIntegral last) snapshotNums)
 
 
--- Utils for Spawning Worker Threads -------------------------------------------
-
-acquireWorker :: HasLogFunc e => Text -> RIO e () -> RAcquire e (Async ())
-acquireWorker nam act = mkRAcquire (async act) kill
- where
-  kill tid = do
-    logInfo ("Killing worker thread: " <> display nam)
-    cancel tid
-
-acquireWorkerBound :: HasLogFunc e => Text -> RIO e () -> RAcquire e (Async ())
-acquireWorkerBound nam act = mkRAcquire (asyncBound act) kill
- where
-  kill tid = do
-    logInfo ("Killing worker thread: " <> display nam)
-    cancel tid
-
-
-
 -- Run Pier --------------------------------------------------------------------
 
 pier
@@ -296,10 +280,15 @@ pier (serf, log) vSlog startedSig = do
       Term.addDemux ext demux
     logInfo "TERMSERV External terminal connected."
 
-  --  Slogs go to both stderr and to the terminal.
+  -- Set up the runtime subsite server and its capability to slog
+  siteSlog <- newTVarIO (const $ pure ())
+  runtimeSubsite <- Site.app siteSlog
+
+  --  Slogs go to stderr, to the runtime subsite, and to the terminal.
   env <- ask
   atomically $ writeTVar vSlog $ \s@(_, tank) -> runRIO env $ do
       atomically $ Term.slog muxed s
+      io $ readTVarIO siteSlog >>= ($ s)
       logOther "serf" (display $ T.strip $ tankToText tank)
 
   -- Our call above to set the logging function which echos errors from the
@@ -316,7 +305,7 @@ pier (serf, log) vSlog startedSig = do
     let err = atomically . Term.trace muxed . (<> "\r\n")
     siz <- atomically $ Term.curDemuxSize demux
     let fak = isFake logId
-    drivers env ship fak compute (siz, muxed) err sigint
+    drivers env ship fak compute (siz, muxed) err sigint runtimeSubsite
 
   scrySig <- newEmptyTMVarIO
   onKill  <- view onKillPierSigL
@@ -423,12 +412,13 @@ drivers
   -> (TermSize, Term.Client)
   -> (Text -> RIO e ())
   -> IO ()
+  -> W.Application
   -> RAcquire e ([Ev], RAcquire e Drivers)
-drivers env who isFake plan termSys stderr serfSIGINT = do
+drivers env who isFake plan termSys stderr serfSIGINT sub = do
   (behnBorn, runBehn) <- rio Behn.behn'
   (termBorn, runTerm) <- rio (Term.term' termSys serfSIGINT)
   (amesBorn, runAmes) <- rio (Ames.ames' who isFake stderr)
-  (httpBorn, runEyre) <- rio (Eyre.eyre' who isFake stderr)
+  (httpBorn, runEyre) <- rio (Eyre.eyre' who isFake stderr sub)
   (clayBorn, runClay) <- rio Clay.clay'
   (irisBorn, runIris) <- rio Iris.client'