Merge pull request #4616 from urbit/pp/vegeta

king: commit seppuku when server is out of fds, also setrlimit allowing for more fds

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

@@ -99,6 +99,7 @@ import qualified Data.Set                as Set
 import qualified Data.Text               as T
 import qualified Network.HTTP.Client     as C
 import qualified System.Posix.Signals    as Sys
+import qualified System.Posix.Resource   as Sys
 import qualified System.ProgressBar      as PB
 import qualified System.Random           as Sys
 import qualified Urbit.EventLog.LMDB     as Log
@@ -460,6 +461,13 @@ pillFrom = \case
     noun <- cueBS body & either throwIO pure
     fromNounErr noun & either (throwIO . uncurry ParseErr) pure
 
+multiOnFatal :: HasKingEnv e => e -> IO ()
+multiOnFatal env = runRIO env $ do
+  (view stderrLogFuncL >>=) $ flip runRIO $ logError
+    ("Urbit is shutting down because of a problem with the HTTP server.\n"
+    <> "Please restart it at your leisure.")
+  view killKingActionL >>= atomically
+
 newShip :: CLI.New -> CLI.Opts -> RIO KingEnv ()
 newShip CLI.New{..} opts = do
   {-
@@ -472,7 +480,8 @@ newShip CLI.New{..} opts = do
     "run ship" flow, and possibly sequence them from the outside if
     that's really needed.
   -}
-  multi <- multiEyre (MultiEyreConf Nothing Nothing True)
+  env <- ask
+  multi <- multiEyre (multiOnFatal env) (MultiEyreConf Nothing Nothing True)
 
   -- TODO: We hit the same problem as above: we need a host env to boot a ship
   -- because it may autostart the ship, so build an inactive port configuration.
@@ -660,6 +669,7 @@ main = do
 
   hSetBuffering stdout NoBuffering
   setupSignalHandlers
+  setRLimits
 
   runKingEnv args log $ case args of
     CLI.CmdRun ko ships                       -> runShips ko ships
@@ -693,6 +703,15 @@ main = do
     for_ [Sys.sigTERM, Sys.sigINT] $ \sig -> do
       Sys.installHandler sig (Sys.Catch onKillSig) Nothing
 
+  setRLimits = do
+    openFiles <- Sys.getResourceLimit Sys.ResourceOpenFiles
+    let soft = case Sys.hardLimit openFiles of
+          Sys.ResourceLimit lim     -> Sys.ResourceLimit lim
+          Sys.ResourceLimitInfinity -> Sys.ResourceLimit 10240  -- macOS
+          Sys.ResourceLimitUnknown  -> Sys.ResourceLimit 10240
+    Sys.setResourceLimit Sys.ResourceOpenFiles
+      openFiles { Sys.softLimit = soft }
+
   verboseLogging :: CLI.Cmd -> Bool
   verboseLogging = \case
     CLI.CmdRun ko ships -> any CLI.oVerbose (ships <&> \(_, o, _) -> o)
@@ -716,7 +735,6 @@ main = do
       CLI.CmdRun ko _                          -> CLI.LogStderr
       _                                        -> CLI.LogStderr
 
-
 {-
   Runs a ship but restarts it if it crashes or shuts down on it's own.
 
@@ -792,7 +810,8 @@ runShips CLI.Host {..} ships = do
                                    -- a king-wide option.
         }
 
-  multi <- multiEyre meConf
+  env <- ask
+  multi <- multiEyre (multiOnFatal env) meConf
 
   ports <- buildPortHandler hUseNatPmp
 

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 "A web server problem has occurred. 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,38 @@ 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 = do
+        when (isFatal e) $ do
+          runRIO envir $ logError $ display $ msg r e
+          onFatal
+        when (W.defaultShouldDisplayException e) $ do
+          runRIO envir $ logWarn $ display $ msg r e
+
+      isFatal e
+        | Just (IOError {ioe_type = ResourceExhausted}) <- fromException e
+        = True
+        | otherwise = False
+
+      msg r e = case r of
+        Just r  -> "eyre: failed request from " <> (tshow $ W.remoteHost r)
+                <> " for " <> (tshow $ W.rawPathInfo r) <> ": " <> tshow e
+        Nothing -> "eyre: server exception: " <> tshow e
+
   let opts =
         W.defaultSettings
           & W.setHost host
           & W.setPort (fromIntegral por)
-          & W.setTimeout (5 * 60)
+          & W.setTimeout 30
+          & W.setOnException handler
 
   -- TODO build Eyre.Site.app in pier, thread through here
   let runAppl who = E.app envir who vLive
@@ -338,8 +358,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 +375,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