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

{- |
  # Signal Handling (SIGTERM, SIGINT)

  We handle SIGTERM by causing the main thread to raise a `UserInterrupt`
  exception. This is the same behavior as SIGINT (the signal sent upon
  `CTRL-C`).

  The main thread is therefore responsible for handling this exception
  and causing everything to shut down properly.

  # Crashing and Shutting Down

  Rule number one: The King never crashes.

  This rule is asperational at the moment, but it needs to become as
  close to truth as possible. Shut down ships in extreme cases, but
  never let the king go down.
-}

{-
    TODO These some old scribbled notes. They don't belong here
    anymore. Do something about it.

    # Event Pruning

    - `king discard-events NUM_EVENTS`: Delete the last `n` events from
      the event log.

    - `king discard-events-interactive`: Iterate through the events in
      the event log, from last to first, pretty-print each event, and
      ask if it should be pruned.

    # Implement subcommands to test event and effect parsing.

    - `king * --collect-fx`: All effects that come from the serf get
      written into the `effects` LMDB database.

    - `king clear-fx PIER`: Deletes all collected effects.

    - `king full-replay PIER`: Replays the whole event log events, print
      any failures. On success, replace the snapshot.


    # Full Replay -- An Integration Test

    - Copy the event log:

      - Create a new event log at the destination.
      - Stream events from the first event log.
      - Parse each event.
      - Re-Serialize each event.
      - Verify that the round-trip was successful.
      - Write the event into the new database.

    - Replay the event log at the destination.
      - If `--collect-fx` is set, then record effects as well.

    - Snapshot.

    - Verify that the final mug is the same as it was before.

    # Implement Remaining Serf Flags

    - `DebugRam`: Memory debugging.
    - `DebugCpu`: Profiling
    - `CheckCorrupt`: Heap Corruption Tests
    - `CheckFatal`: TODO What is this?
    - `Verbose`: TODO Just the `-v` flag?
    - `DryRun`: TODO Just the `-N` flag?
    - `Quiet`: TODO Just the `-q` flag?
    - `Hashless`: Don't use hashboard for jets.
-}

module Urbit.King.Main (main) where

import Urbit.Prelude

import Data.Conduit
import Network.HTTP.Client.TLS
import RIO.Directory
import Urbit.Arvo
import Urbit.King.Config
import Urbit.Vere.Dawn
import Urbit.Vere.Pier
import Urbit.Vere.Ports
import Urbit.Vere.Eyre.Multi (multiEyre, MultiEyreConf(..))
import Urbit.Vere.Pier.Types
import Urbit.Vere.Serf
import Urbit.King.App

import Control.Concurrent     (myThreadId)
import Control.Exception      (AsyncException(UserInterrupt))
import System.Process         (system)
import System.IO              (hPutStrLn)
import Urbit.Noun.Time        (Wen)
import Urbit.Vere.LockFile    (lockFile)

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.ProgressBar      as PB
import qualified System.Random           as Sys
import qualified Urbit.EventLog.LMDB     as Log
import qualified Urbit.King.CLI          as CLI
import qualified Urbit.King.EventBrowser as EventBrowser
import qualified Urbit.Ob                as Ob
import qualified Urbit.Vere.Pier         as Pier
import qualified Urbit.Vere.Serf         as Serf
import qualified Urbit.Vere.Term         as Term


--------------------------------------------------------------------------------

removeFileIfExists :: HasLogFunc env => FilePath -> RIO env ()
removeFileIfExists pax = do
  exists <- doesFileExist pax
  when exists $ do
      removeFile pax


-- Compile CLI Flags to Pier Configuration -------------------------------------

{-
  TODO: This is not all of the flags.
  Urbit is basically useless with hashboard, so we ignore that flag.
-}
toSerfFlags :: CLI.Opts -> [Serf.Flag]
toSerfFlags CLI.Opts{..} = catMaybes m
  where
    m = [ setFrom oQuiet Serf.Quiet
        , setFrom oTrace Serf.Trace
        , setFrom (oHashless || True) Serf.Hashless
        , setFrom oQuiet Serf.Quiet
        , setFrom oVerbose Serf.Verbose
        , setFrom (oDryRun || isJust oDryFrom) Serf.DryRun
        ]
    setFrom True flag = Just flag
    setFrom False _   = Nothing

toPierConfig :: FilePath -> Maybe Text -> CLI.Opts -> PierConfig
toPierConfig pierPath serfExe o@(CLI.Opts{..}) = PierConfig { .. }
 where
  _pcPierPath  = pierPath
  _pcDryRun    = oDryRun || isJust oDryFrom
  _pcSerfExe   = serfExe
  _pcSerfFlags = toSerfFlags o

toNetworkConfig :: CLI.Opts -> NetworkConfig
toNetworkConfig CLI.Opts {..} = NetworkConfig { .. }
 where
  dryRun     = oDryRun || isJust oDryFrom
  offline    = dryRun || oOffline

  mode = case (dryRun, offline, oLocalhost) of
    (True, _   , _   ) -> NMNone
    (_   , True, _   ) -> NMNone
    (_   , _   , True) -> NMLocalhost
    (_   , _   , _   ) -> NMNormal

  _ncNetMode   = mode
  _ncAmesPort  = oAmesPort
  _ncHttpPort  = oHttpPort
  _ncHttpsPort = oHttpsPort
  _ncLocalPort = oLoopbackPort
  _ncNoAmes    = oNoAmes
  _ncNoHttp    = oNoHttp
  _ncNoHttps   = oNoHttps

logStderr :: HasStderrLogFunc e => RIO LogFunc a -> RIO e a
logStderr action = do
  logFunc <- view stderrLogFuncL
  runRIO logFunc action

logSlogs :: HasStderrLogFunc e => RIO e (TVar ((Atom, Tank) -> IO ()))
logSlogs = logStderr $ do
  env <- ask
  newTVarIO (runRIO env . logOther "serf" . display . T.strip . tankToText . snd)

tryBootFromPill
  :: Bool
  -> Pill
  -> Bool
  -> Ship
  -> LegacyBootEvent
  -> RIO PierEnv ()
tryBootFromPill oExit pill lite ship boot = do
  mStart <- newEmptyMVar
  vSlog  <- logSlogs
  runOrExitImmediately vSlog (bootedPier vSlog) oExit mStart []
 where
  bootedPier vSlog = do
    view pierPathL >>= lockFile
    rio $ logInfo "Starting boot"
    sls <- Pier.booted vSlog pill lite ship boot
    rio $ logInfo "Completed boot"
    pure sls

runOrExitImmediately
  :: TVar ((Atom, Tank) -> IO ())
  -> RAcquire PierEnv (Serf, Log.EventLog)
  -> Bool
  -> MVar ()
  -> [Ev]
  -> RIO PierEnv ()
runOrExitImmediately vSlog getPier oExit mStart injected = do
  rwith getPier (if oExit then shutdownImmediately else runPier)
 where
  shutdownImmediately :: (Serf, Log.EventLog) -> RIO PierEnv ()
  shutdownImmediately (serf, log) = do
    logInfo "Sending shutdown signal"
    Serf.stop serf
    logInfo "Shutdown!"

  runPier :: (Serf, Log.EventLog) -> RIO PierEnv ()
  runPier serfLog = do
    runRAcquire (Pier.pier serfLog vSlog mStart injected)

tryPlayShip
  :: Bool
  -> Bool
  -> Maybe Word64
  -> MVar ()
  -> [Ev]
  -> RIO PierEnv ()
tryPlayShip exitImmediately fullReplay playFrom mStart injected = do
  when fullReplay wipeSnapshot
  vSlog <- logSlogs
  runOrExitImmediately vSlog (resumeShip vSlog) exitImmediately mStart injected
 where
  wipeSnapshot = do
    shipPath <- view pierPathL
    logInfo "wipeSnapshot"
    logInfo $ display $ pack @Text ("Wiping " <> north shipPath)
    logInfo $ display $ pack @Text ("Wiping " <> south shipPath)
    removeFileIfExists (north shipPath)
    removeFileIfExists (south shipPath)

  north shipPath = shipPath <> "/.urb/chk/north.bin"
  south shipPath = shipPath <> "/.urb/chk/south.bin"

  resumeShip :: TVar ((Atom, Tank) -> IO ())
             -> RAcquire PierEnv (Serf, Log.EventLog)
  resumeShip vSlog = do
    view pierPathL >>= lockFile
    rio $ logInfo "RESUMING SHIP"
    sls <- Pier.resumed vSlog playFrom
    rio $ logInfo "SHIP RESUMED"
    pure sls

runRAcquire :: (MonadUnliftIO (m e),  MonadIO (m e), MonadReader e (m e))
            => RAcquire e a -> m e a
runRAcquire act = rwith act pure


--------------------------------------------------------------------------------

checkEvs :: FilePath -> Word64 -> Word64 -> RIO KingEnv ()
checkEvs pierPath first last = do
  rwith (Log.existing logPath) $ \log -> do
    let ident = Log.identity log
    let pbSty = PB.defStyle { PB.stylePostfix = PB.exact }
    logInfo (displayShow ident)

    last <- atomically $ Log.lastEv log <&> \lastReal -> min last lastReal

    let evCount = fromIntegral (last - first)

    pb <- PB.newProgressBar pbSty 10 (PB.Progress 1 evCount ())

    runConduit $ Log.streamEvents log first .| showEvents
      pb
      first
      (fromIntegral $ lifecycleLen ident)
 where
  logPath :: FilePath
  logPath = pierPath <> "/.urb/log"

  showEvents
    :: PB.ProgressBar ()
    -> EventId
    -> EventId
    -> ConduitT ByteString Void (RIO KingEnv) ()
  showEvents pb eId _ | eId > last = pure ()
  showEvents pb eId cycle          = await >>= \case
    Nothing -> do
      lift $ PB.killProgressBar pb
      lift $ logInfo "Everything checks out."
    Just bs -> do
      lift $ PB.incProgress pb 1
      lift $ do
        n <- io $ cueBSExn bs
        when (eId > cycle) $ do
          (mug, wen, evNoun) <- unpackJob n
          fromNounErr evNoun & \case
            Left  err       -> logError (displayShow (eId, err))
            Right (_ :: Ev) -> pure ()
      showEvents pb (succ eId) cycle

  unpackJob :: Noun -> RIO KingEnv (Mug, Wen, Noun)
  unpackJob = io . fromNounExn


--------------------------------------------------------------------------------

collectAllFx :: FilePath -> RIO KingEnv ()
collectAllFx = error "TODO"

{-
{-|
    This runs the serf at `$top/.tmpdir`, but we disable snapshots,
    so this should never actually be created. We just do this to avoid
    letting the serf use an existing snapshot.
-}
collectAllFx :: FilePath -> RIO KingEnv ()
collectAllFx top = do
    logInfo $ display $ pack @Text top
    vSlog <- logSlogs
    rwith (collectedFX vSlog) $ \() ->
        logInfo "Done collecting effects!"
  where
    tmpDir :: FilePath
    tmpDir = top </> ".tmpdir"

    collectedFX :: TVar (Text -> IO ()) -> RAcquire KingEnv ()
    collectedFX vSlog = do
        lockFile top
        log  <- Log.existing (top <> "/.urb/log")
        serf <- Pier.runSerf vSlog tmpDir serfFlags
        rio $ Serf.collectFX serf log

    serfFlags :: [Serf.Flag]
    serfFlags = [Serf.Hashless, Serf.DryRun]
-}


--------------------------------------------------------------------------------

replayPartEvs :: FilePath -> Word64 -> RIO KingEnv ()
replayPartEvs top last = do
    logInfo $ display $ pack @Text top
    fetchSnapshot
    rwith replayedEvs $ \() ->
        logInfo "Done replaying events!"
  where
    fetchSnapshot :: RIO KingEnv ()
    fetchSnapshot = do
      snap <- Pier.getSnapshot top last
      case snap of
        Nothing -> pure ()
        Just sn -> do
          liftIO $ system $ "cp -r \"" <> sn <> "\" \"" <> tmpDir <> "\""
          pure ()

    tmpDir :: FilePath
    tmpDir = top </> ".partial-replay" </> show last

    replayedEvs :: RAcquire KingEnv ()
    replayedEvs = do
        lockFile top
        log  <- Log.existing (top <> "/.urb/log")
        let onSlog = print
        let onStdr = print
        let onDead = error "DIED"
        let config = Serf.Config "urbit-worker" tmpDir serfFlags onSlog onStdr onDead
        (serf, info) <- io (Serf.start config)
        rio $ do
          eSs <- Serf.execReplay serf log (Just last)
          case eSs of
            Left bail -> error (show bail)
            Right 0   -> io (Serf.snapshot serf)
            Right num -> pure ()
          io $ threadDelay 500000 -- Copied from runOrExitImmediately
          pure ()

    serfFlags :: [Serf.Flag]
    serfFlags = [Serf.Hashless]


--------------------------------------------------------------------------------

{-|
    Interesting
-}
testPill :: HasKingEnv e => FilePath -> Bool -> Bool -> RIO e ()
testPill pax showPil showSeq = do
  logInfo "Reading pill file."
  pillBytes <- readFile pax

  logInfo "Cueing pill file."
  pillNoun <- io $ cueBS pillBytes & either throwIO pure

  logInfo "Parsing pill file."
  pill <- fromNounErr pillNoun & either (throwIO . uncurry ParseErr) pure

  logInfo "Using pill to generate boot sequence."
  bootSeq <- genBootSeq (Ship 0) pill False (Fake (Ship 0))

  logInfo "Validate jam/cue and toNoun/fromNoun on pill value"
  reJam <- validateNounVal pill

  logInfo "Checking if round-trip matches input file:"
  unless (reJam == pillBytes) $ do
    logInfo "    Our jam does not match the file...\n"
    logInfo "    This is surprising, but it is probably okay."

  when showPil $ do
      logInfo "\n\n== Pill ==\n"
      io $ pPrint pill

  when showSeq $ do
      logInfo "\n\n== Boot Sequence ==\n"
      io $ pPrint bootSeq

validateNounVal :: (HasLogFunc e, Eq a, ToNoun a, FromNoun a)
                => a -> RIO e ByteString
validateNounVal inpVal = do
    logInfo "  jam"
    inpByt <- evaluate $ jamBS $ toNoun inpVal

    logInfo "  cue"
    outNon <- cueBS inpByt & either throwIO pure

    logInfo "  fromNoun"
    outVal <- fromNounErr outNon & either (throwIO . uncurry ParseErr) pure

    logInfo "  toNoun"
    outNon <- evaluate (toNoun outVal)

    logInfo "  jam"
    outByt <- evaluate $ jamBS outNon

    logInfo "Checking if: x == cue (jam x)"
    unless (inpVal == outVal) $
        error "Value fails test: x == cue (jam x)"

    logInfo "Checking if: jam x == jam (cue (jam x))"
    unless (inpByt == outByt) $
        error "Value fails test: jam x == jam (cue (jam x))"

    pure outByt


--------------------------------------------------------------------------------

pillFrom :: CLI.PillSource -> RIO HostEnv Pill
pillFrom = \case
  CLI.PillSourceFile pillPath -> do
    logInfo $ display $ "boot: reading pill from " ++ (pack pillPath :: Text)
    io (loadFile pillPath >>= either throwIO pure)

  CLI.PillSourceURL url -> do
    logInfo $ display $ "boot: retrieving pill from " ++ (pack url :: Text)
    -- Get the jamfile with the list of stars accepting comets right now.
    manager <- io $ C.newManager tlsManagerSettings
    request <- io $ C.parseRequest url
    response <- io $ C.httpLbs (C.setRequestCheckStatus request) manager
    let body = toStrict $ C.responseBody response

    noun <- cueBS body & either throwIO pure
    fromNounErr noun & either (throwIO . uncurry ParseErr) pure

newShip :: CLI.New -> CLI.Opts -> RIO KingEnv ()
newShip CLI.New{..} opts = do
  {-
    TODO XXX HACK

    Because the "new ship" flow *may* automatically start the ship,
    we need to create this, but it's not actually correct.

    The right solution is to separate out the "new ship" flow from the
    "run ship" flow, and possibly sequence them from the outside if
    that's really needed.
  -}
  multi <- multiEyre (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.
  let ports = buildInactivePorts

  -- here we are with a king env, and we now need a multi env.
  runHostEnv multi ports $ case nBootType of
    CLI.BootComet -> do
      pill <- pillFrom nPillSource
      putStrLn "boot: retrieving list of stars currently accepting comets"
      starList <- dawnCometList
      putStrLn ("boot: " ++ (tshow $ length starList) ++
                " star(s) currently accepting comets")
      putStrLn "boot: mining a comet"
      eny <- io $ Sys.randomIO
      let seed = mineComet (Set.fromList starList) eny
      putStrLn ("boot: found comet " ++ renderShip (sShip seed))
      putStrLn ("code: " ++ (tshow $ deriveCode $ sRing seed))
      bootFromSeed pill seed

    CLI.BootFake name -> do
      pill <- pillFrom nPillSource
      ship <- shipFrom name
      runTryBootFromPill pill name ship (Fake ship)

    CLI.BootFromKeyfile keyFile -> do
      text <- readFileUtf8 keyFile
      asAtom <- case cordToUW (Cord $ T.strip text) of
        Nothing -> error "Couldn't parse keyfile. Hint: keyfiles start with 0w?"
        Just (UW a) -> pure a

      asNoun <- cueExn asAtom
      seed :: Seed <- case fromNoun asNoun of
        Nothing -> error "Keyfile does not seem to contain a seed."
        Just s  -> pure s

      pill <- pillFrom nPillSource

      bootFromSeed pill seed

  where
    shipFrom :: Text -> RIO HostEnv Ship
    shipFrom name = case Ob.parsePatp name of
      Left x  -> error "Invalid ship name"
      Right p -> pure $ Ship $ fromIntegral $ Ob.fromPatp p

    pierPath :: Text -> FilePath
    pierPath name = case nPierPath of
      Just x  -> x
      Nothing -> "./" <> unpack name

    nameFromShip :: HasKingEnv e => Ship -> RIO e Text
    nameFromShip s = name
      where
        nameWithSig = Ob.renderPatp $ Ob.patp $ fromIntegral s
        name = case stripPrefix "~" nameWithSig of
          Nothing -> error "Urbit.ob didn't produce string with ~"
          Just x  -> pure x

    bootFromSeed :: Pill -> Seed -> RIO HostEnv ()
    bootFromSeed pill seed = do
      ethReturn <- dawnVent nEthNode seed

      case ethReturn of
        Left x -> error $ unpack x
        Right dawn -> do
          let ship = sShip $ dSeed dawn
          name <- nameFromShip ship
          runTryBootFromPill pill name ship (Dawn dawn)

    -- Now that we have all the information for running an application with a
    -- PierConfig, do so.
    runTryBootFromPill :: Pill
                       -> Text
                       -> Ship
                       -> LegacyBootEvent
                       -> RIO HostEnv ()
    runTryBootFromPill pill name ship bootEvent = do
      vKill <- view (kingEnvL . kingEnvKillSignal)
      let pierConfig = toPierConfig (pierPath name) nSerfExe opts
      let networkConfig = toNetworkConfig opts
      runPierEnv pierConfig networkConfig vKill $
        tryBootFromPill True pill nLite ship bootEvent

runShipEnv :: Maybe Text -> CLI.Run -> CLI.Opts -> TMVar () -> RIO PierEnv a
           -> RIO HostEnv a
runShipEnv serfExe (CLI.Run pierPath) opts vKill act = do
  runPierEnv pierConfig netConfig vKill act
 where
  pierConfig = toPierConfig pierPath serfExe opts
  netConfig = toNetworkConfig opts

runShip
  :: CLI.Run -> CLI.Opts -> Bool -> RIO PierEnv ()
runShip (CLI.Run pierPath) opts daemon = do
    mStart  <- newEmptyMVar
    if daemon
    then runPier mStart
    else do
      -- Wait until the pier has started up, then connect a terminal. If
      -- the terminal ever shuts down, ask the ship to go down.
      connectionThread <- async $ do
        readMVar mStart
        finally (connTerm pierPath) $ do
          view killPierActionL >>= atomically

      -- Run the pier until it finishes, and then kill the terminal.
      finally (runPier mStart) $ do
        cancel connectionThread
  where
    runPier :: MVar () -> RIO PierEnv ()
    runPier mStart = do
      injections <- loadInjections (CLI.oInjectEvents opts)
      tryPlayShip
        (CLI.oExit opts)
        (CLI.oFullReplay opts)
        (CLI.oDryFrom opts)
        mStart
        injections

    loadInjections :: [CLI.Injection] -> RIO PierEnv [Ev]
    loadInjections injections = do
      perInjection :: [[Ev]] <- for injections $ \case
          CLI.InjectOneEvent filePath -> do
            logInfo $ display $ "boot: reading injected event from " ++
              (pack filePath :: Text)
            io (loadFile filePath >>= either throwIO (pure . singleton))

          CLI.InjectManyEvents filePath -> do
            logInfo $ display $ "boot: reading injected event list from " ++
              (pack filePath :: Text)
            io (loadFile filePath >>= either throwIO pure)
      pure $ concat perInjection



buildPortHandler :: HasLogFunc e => CLI.Nat -> RIO e PortControlApi
buildPortHandler CLI.NatNever  = pure buildInactivePorts
-- TODO: Figure out what to do about logging here. The "port: " messages are
-- the sort of thing that should be put on the muxed terminal log, but we don't
-- have that at this layer.
buildPortHandler CLI.NatAlways = buildNatPorts (io . hPutStrLn stderr . unpack)
buildPortHandler CLI.NatWhenPrivateNetwork =
  buildNatPortsWhenPrivate (io . hPutStrLn stderr . unpack)

startBrowser :: HasLogFunc e => FilePath -> RIO e ()
startBrowser pierPath = runRAcquire $ do
    -- lockFile pierPath
    log <- Log.existing (pierPath <> "/.urb/log")
    rio $ EventBrowser.run log

checkDawn :: HasLogFunc e => String -> FilePath -> RIO e ()
checkDawn provider keyfilePath = do
  -- The keyfile is a jammed Seed then rendered in UW format
  text <- readFileUtf8 keyfilePath
  asAtom <- case cordToUW (Cord $ T.strip text) of
    Nothing -> error "Couldn't parse keyfile. Hint: keyfiles start with 0w?"
    Just (UW a) -> pure a

  asNoun <- cueExn asAtom
  seed :: Seed <- case fromNoun asNoun of
    Nothing -> error "Keyfile does not seem to contain a seed."
    Just s  -> pure s

  print $ show seed

  e <- dawnVent provider seed
  print $ show e


checkComet :: HasLogFunc e => RIO e ()
checkComet = do
  starList <- dawnCometList
  putStrLn "Stars currently accepting comets:"
  let starNames = map (Ob.renderPatp . Ob.patp . fromIntegral) starList
  print starNames
  putStrLn "Trying to mine a comet..."
  eny <- io $ Sys.randomIO
  let s = mineComet (Set.fromList starList) eny
  print s

main :: IO ()
main = do
  (args, log) <- CLI.parseArgs

  hSetBuffering stdout NoBuffering
  setupSignalHandlers

  runKingEnv args log $ case args of
    CLI.CmdRun ko ships                       -> runShips ko ships
    CLI.CmdNew n  o                           -> newShip n o
    CLI.CmdBug (CLI.CollectAllFX pax        ) -> collectAllFx pax
    CLI.CmdBug (CLI.EventBrowser pax        ) -> startBrowser pax
    CLI.CmdBug (CLI.ValidatePill   pax pil s) -> testPill pax pil s
    CLI.CmdBug (CLI.ValidateEvents pax f   l) -> checkEvs pax f l
    CLI.CmdBug (CLI.ValidateFX     pax f   l) -> checkFx pax f l
    CLI.CmdBug (CLI.ReplayEvents pax l      ) -> replayPartEvs pax l
    CLI.CmdBug (CLI.CheckDawn provider pax  ) -> checkDawn provider pax
    CLI.CmdBug CLI.CheckComet                 -> checkComet
    CLI.CmdCon pier                           -> connTerm pier

 where
  runKingEnv args log =
    let
      verb = verboseLogging args
      runStderr = case args of
        CLI.CmdRun {} -> runKingEnvStderrRaw
        _             -> runKingEnvStderr
      CLI.Log {..} = log
    in case logTarget lTarget args of
       CLI.LogFile f -> runKingEnvLogFile verb lLevel f
       CLI.LogStderr -> runStderr         verb lLevel
       CLI.LogOff    -> runKingEnvNoLog

  setupSignalHandlers = do
    mainTid <- myThreadId
    let onKillSig = throwTo mainTid UserInterrupt
    for_ [Sys.sigTERM, Sys.sigINT] $ \sig -> do
      Sys.installHandler sig (Sys.Catch onKillSig) Nothing

  verboseLogging :: CLI.Cmd -> Bool
  verboseLogging = \case
    CLI.CmdRun ko ships -> any CLI.oVerbose (ships <&> \(_, o, _) -> o)
    _                   -> False

  -- If the user hasn't specified where to log, what we do depends on what
  -- command she has issued. Notably, the LogFile Nothing outcome means that
  -- runKingEnvLogFile should run an IO action to get the official app data
  -- directory and open a canonically named log file there.
  logTarget :: Maybe (CLI.LogTarget FilePath)
            -> CLI.Cmd
            -> CLI.LogTarget (Maybe FilePath)
  logTarget = \case
    Just (CLI.LogFile f) -> const $ CLI.LogFile (Just f)
    Just CLI.LogStderr   -> const $ CLI.LogStderr
    Just CLI.LogOff      -> const $ CLI.LogOff
    Nothing              -> \case
      CLI.CmdCon _                             -> CLI.LogFile Nothing
      CLI.CmdRun ko [(_,_,daemon)] | daemon    -> CLI.LogStderr
                                   | otherwise -> CLI.LogFile Nothing
      CLI.CmdRun ko _                          -> CLI.LogStderr
      _                                        -> CLI.LogStderr


{-
  Runs a ship but restarts it if it crashes or shuts down on it's own.

  Once `waitForKillRequ` returns, the ship will be terminated and this
  routine will exit.
-}
runShipRestarting
  :: Maybe Text -> CLI.Run -> CLI.Opts -> RIO HostEnv ()
runShipRestarting serfExe r o = do
  let pier = pack (CLI.rPierPath r)
      loop = runShipRestarting serfExe r o

  onKill    <- view onKillKingSigL
  vKillPier <- newEmptyTMVarIO

  tid <- asyncBound $ runShipEnv serfExe r o vKillPier $ runShip r o True

  let onShipExit = Left <$> waitCatchSTM tid
      onKillRequ = Right <$> onKill

  atomically (onShipExit <|> onKillRequ) >>= \case
    Left exit -> do
      case exit of
        Left err -> logError $ display (tshow err <> ": " <> pier)
        Right () ->
          logError $ display ("Ship exited on it's own. Why? " <> pier)
      threadDelay 250_000
      loop
    Right () -> do
      logTrace $ display (pier <> " shutdown requested")
      atomically $ putTMVar vKillPier ()
      race_ (wait tid) $ do
        threadDelay 5_000_000
        logInfo $ display (pier <> " not down after 5s, killing with fire.")
        cancel tid
      logTrace $ display ("Ship terminated: " <> pier)

{-
  TODO This is messy and shared a lot of logic with `runShipRestarting`.
-}
runShipNoRestart
  :: Maybe Text -> CLI.Run -> CLI.Opts -> Bool -> RIO HostEnv ()
runShipNoRestart serfExe r o d = do
  -- killing ship same as killing king
  vKill  <- view (kingEnvL . kingEnvKillSignal)
  tid    <- asyncBound (runShipEnv serfExe r o vKill $ runShip r o d)
  onKill <- view onKillKingSigL

  let pier = pack (CLI.rPierPath r)

  let onShipExit = Left <$> waitCatchSTM tid
      onKillRequ = Right <$> onKill

  atomically (onShipExit <|> onKillRequ) >>= \case
    Left (Left err) -> do
      logError $ display (tshow err <> ": " <> pier)
    Left (Right ()) -> do
      logError $ display (pier <> " exited on it's own. Why?")
    Right () -> do
      logTrace $ display (pier <> " shutdown requested")
      race_ (wait tid) $ do
        threadDelay 5_000_000
        logTrace $ display (pier <> " not down after 5s, killing with fire.")
        cancel tid
      logTrace $ display (pier <> " terminated.")

runShips :: CLI.Host -> [(CLI.Run, CLI.Opts, Bool)] -> RIO KingEnv ()
runShips CLI.Host {..} ships = do
  let meConf = MultiEyreConf
        { mecHttpPort      = fromIntegral <$> hSharedHttpPort
        , mecHttpsPort     = fromIntegral <$> hSharedHttpsPort
        , mecLocalhostOnly = False -- TODO Localhost-only needs to be
                                   -- a king-wide option.
        }

  multi <- multiEyre meConf

  ports <- buildPortHandler hUseNatPmp

  runHostEnv multi ports (go ships)
 where
  go :: [(CLI.Run, CLI.Opts, Bool)] ->  RIO HostEnv ()
  go = \case
    []    -> pure ()
    [rod] -> runSingleShip hSerfExe rod
    ships -> runMultipleShips hSerfExe (ships <&> \(r, o, _) -> (r, o))


-- TODO Duplicated logic.
runSingleShip :: Maybe Text -> (CLI.Run, CLI.Opts, Bool) -> RIO HostEnv ()
runSingleShip serfExe (r, o, d) = do
  shipThread <- async (runShipNoRestart serfExe r o d)

  {-
    Wait for the ship to go down.

    Since `waitCatch` will never throw an exception, the `onException`
    block will only happen if this thread is killed with an async
    exception.  The one we expect is `UserInterrupt` which will be raised
    on this thread upon SIGKILL or SIGTERM.

    If this thread is killed, we first ask the ship to go down, wait
    for the ship to actually go down, and then go down ourselves.
  -}
  onException (void $ waitCatch shipThread) $ do
    logTrace "KING IS GOING DOWN"
    atomically =<< view killKingActionL
    waitCatch shipThread
    pure ()


runMultipleShips :: Maybe Text -> [(CLI.Run, CLI.Opts)] -> RIO HostEnv ()
runMultipleShips serfExe ships = do
  shipThreads <- for ships $ \(r, o) -> do
    async (runShipRestarting serfExe r o)

  {-
    Since `spin` never returns, this will run until the main
    thread is killed with an async exception.  The one we expect is
    `UserInterrupt` which will be raised on this thread upon SIGKILL
    or SIGTERM.

    Once that happens, we send a shutdown signal which will cause all
    ships to be shut down, and then we `wait` for them to finish before
    returning.

    This is different than the single-ship flow, because ships never
    go down on their own in this flow. If they go down, they just bring
    themselves back up.
  -}
  let spin = forever (threadDelay maxBound)
  finally spin $ do
    logTrace "KING IS GOING DOWN"
    view killKingActionL >>= atomically
    for_ shipThreads waitCatch


--------------------------------------------------------------------------------

connTerm :: forall e. HasLogFunc e => FilePath -> RIO e ()
connTerm = Term.runTerminalClient


--------------------------------------------------------------------------------

checkFx :: HasLogFunc e
        => FilePath -> Word64 -> Word64 -> RIO e ()
checkFx pierPath first last =
    rwith (Log.existing logPath) $ \log ->
        runConduit $ streamFX log first last
                  .| tryParseFXStream
  where
    logPath = pierPath <> "/.urb/log"

streamFX :: HasLogFunc e
         => Log.EventLog -> Word64 -> Word64
         -> ConduitT () ByteString (RIO e) ()
streamFX log first last = do
    Log.streamEffectsRows log first .| loop
  where
    loop = await >>= \case Nothing                     -> pure ()
                           Just (eId, bs) | eId > last -> pure ()
                           Just (eId, bs)              -> yield bs >> loop

tryParseFXStream :: HasLogFunc e => ConduitT ByteString Void (RIO e) ()
tryParseFXStream = loop
  where
    loop = await >>= \case
        Nothing -> pure ()
        Just bs -> do
            n <- liftIO (cueBSExn bs)
            fromNounErr n & either (logError . displayShow) pure
            loop


{-
tryCopyLog :: IO ()
tryCopyLog = do
  let logPath      = "/Users/erg/src/urbit/zod/.urb/falselog/"
      falselogPath = "/Users/erg/src/urbit/zod/.urb/falselog2/"

  persistQ <- newTQueueIO
  releaseQ <- newTQueueIO
  (ident, nextEv, events) <-
      with (do { log <- Log.existing logPath
               ; Pier.runPersist log persistQ (writeTQueue releaseQ)
               ; pure log
               })
        \log -> do
          ident  <- pure $ Log.identity log
          events <- runConduit (Log.streamEvents log 1 .| consume)
          nextEv <- Log.nextEv log
          pure (ident, nextEv, events)

  print ident
  print nextEv
  print (length events)

  persistQ2 <- newTQueueIO
  releaseQ2 <- newTQueueIO
  with (do { log <- Log.new falselogPath ident
           ; Pier.runPersist log persistQ2 (writeTQueue releaseQ2)
           ; pure log
           })
    $ \log2 -> do
      let writs = zip [1..] events <&> \(id, a) ->
                      (Writ id Nothing a, [])

      print "About to write"

      for_ writs $ \w ->
        atomically (writeTQueue persistQ2 w)

      print "About to wait"

      replicateM_ 100 $ do
        atomically $ readTQueue releaseQ2

      print "Done"
-}