king: commit seppuku when server is out of fds

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

@@ -11,7 +11,11 @@ where
 import Urbit.Prelude hiding (Builder)
 
 import Urbit.Arvo                hiding (ServerId, reqUrl)
-import Urbit.King.App            (HasKingId(..), HasMultiEyreApi(..), HasPierEnv(..))
+import Urbit.King.App            ( killKingActionL
+                                 , HasKingId(..)
+                                 , HasMultiEyreApi(..)
+                                 , HasPierEnv(..)
+                                 )
 import Urbit.King.Config
 import Urbit.Vere.Eyre.Multi
 import Urbit.Vere.Eyre.PortsFile
@@ -177,9 +181,10 @@ startServ
   -> HttpServerConf
   -> (EvErr -> STM ())
   -> (Text -> RIO e ())
+  -> IO ()
   -> KingSubsite
   -> RIO e Serv
-startServ who isFake conf plan stderr sub = do
+startServ who isFake conf plan stderr onFatal sub = do
   logInfo (displayShow ("EYRE", "startServ"))
 
   multi <- view multiEyreApiL
@@ -228,7 +233,7 @@ startServ who isFake conf plan stderr sub = do
   atomically (joinMultiEyre multi who mCre onReq onKilReq sub)
 
   logInfo $ displayShow ("EYRE", "Starting loopback server")
-  lop <- serv vLive $ ServConf
+  lop <- serv vLive onFatal $ ServConf
     { scHost = soHost (pttLop ptt)
     , scPort = soWhich (pttLop ptt)
     , scRedi = Nothing
@@ -240,7 +245,7 @@ startServ who isFake conf plan stderr sub = do
     }
 
   logInfo $ displayShow ("EYRE", "Starting insecure server")
-  ins <- serv vLive $ ServConf
+  ins <- serv vLive onFatal $ ServConf
     { scHost = soHost (pttIns ptt)
     , scPort = soWhich (pttIns ptt)
     , scRedi = secRedi
@@ -253,7 +258,7 @@ startServ who isFake conf plan stderr sub = do
 
   mSec <- for mTls $ \tls -> do
     logInfo "Starting secure server"
-    serv vLive $ ServConf
+    serv vLive onFatal $ ServConf
       { scHost = soHost (pttSec ptt)
       , scPort = soWhich (pttSec ptt)
       , scRedi = Nothing
@@ -356,7 +361,11 @@ eyre env who plan isFake stderr sub = (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 sub
+    let onFatal = runRIO env $ do
+          -- XX instead maybe restart following logic under HSESetConfig below
+          stderr "You've been DDoSed. Please restart your ship."
+          view killKingActionL >>= atomically
+    let startAct = startServ who isFake conf plan stderr onFatal sub
     res <- fromEither =<< restartService var startAct kill
     logInfo "Done restating http server"
     pure res

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

@@ -75,8 +75,8 @@ leaveMultiEyre MultiEyreApi {..} who = do
   modifyTVar' meaTlsC (deleteMap who)
   modifyTVar' meaSite (deleteMap who)
 
-multiEyre :: HasLogFunc e => MultiEyreConf -> RIO e MultiEyreApi
-multiEyre conf@MultiEyreConf {..} = do
+multiEyre :: HasLogFunc e => IO () -> MultiEyreConf -> RIO e MultiEyreApi
+multiEyre onFatal conf@MultiEyreConf {..} = do
   logInfo (displayShow ("EYRE", "MULTI", conf))
 
   vLive <- io emptyLiveReqs >>= newTVarIO
@@ -108,7 +108,7 @@ multiEyre conf@MultiEyreConf {..} = do
 
   mIns <- for mecHttpPort $ \por -> do
     logInfo (displayShow ("EYRE", "MULTI", "HTTP", por))
-    serv vLive $ ServConf
+    serv vLive onFatal $ ServConf
       { scHost = host
       , scPort = SPChoices $ singleton $ fromIntegral por
       , scRedi = Nothing -- TODO
@@ -121,7 +121,7 @@ multiEyre conf@MultiEyreConf {..} = do
 
   mSec <- for mecHttpsPort $ \por -> do
     logInfo (displayShow ("EYRE", "MULTI", "HTTPS", por))
-    serv vLive $ ServConf
+    serv vLive onFatal $ ServConf
       { scHost = host
       , scPort = SPChoices $ singleton $ fromIntegral por
       , scRedi = Nothing

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

@@ -35,6 +35,7 @@ import Urbit.Prelude hiding (Builder)
 
 import Data.Default                (def)
 import Data.List.NonEmpty          (NonEmpty((:|)))
+import GHC.IO.Exception            (IOException(..), IOErrorType(..))
 import Network.TLS                 ( Credential
                                    , Credentials(..)
                                    , ServerHooks(..)
@@ -254,19 +255,28 @@ startServer
   -> Net.Socket
   -> Maybe W.Port
   -> TVar E.LiveReqs
+  -> IO ()
   -> RIO e ()
-startServer typ hos por sok red vLive = do
+startServer typ hos por sok red vLive onFatal = do
   envir <- ask
 
   let host = case hos of
         SHLocalhost -> "127.0.0.1"
         SHAnyHostOk -> "*"
 
+  let handler r e
+        | Just (IOError {ioe_type = ResourceExhausted}) <- fromException e
+        = runRIO envir $ do
+            logError (displayShow e)
+            io onFatal
+        | otherwise = W.defaultOnException r e
+
   let opts =
         W.defaultSettings
           & W.setHost host
           & W.setPort (fromIntegral por)
           & W.setTimeout (5 * 60)
+          & W.setOnException handler
 
   -- TODO build Eyre.Site.app in pier, thread through here
   let runAppl who = E.app envir who vLive
@@ -338,8 +348,9 @@ 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
+         => TVar E.LiveReqs -> IO () -> ServConf -> RIO e ServApi
+realServ vLive onFatal conf@ServConf {..} = do
   logInfo (displayShow ("EYRE", "SERV", "Running Real Server"))
   por <- newEmptyTMVarIO
 
@@ -354,10 +365,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 vLive onFatal
 
-serv :: HasLogFunc e => TVar E.LiveReqs -> ServConf -> RIO e ServApi
-serv vLive conf = do
+serv :: HasLogFunc e => TVar E.LiveReqs -> IO () -> ServConf -> RIO e ServApi
+serv vLive onFatal conf = do
   if scFake conf
     then fakeServ conf
-    else realServ vLive conf
+    else realServ vLive onFatal conf