urbit/shrub
1
1
Fork 0
mirror of https://github.com/urbit/shrub.git synced 2024-11-28 05:22:27 +03:00
Code Issues Packages Projects Releases Wiki Activity

Hacky code to get king con to connect to King API server.

Browse Source
This commit is contained in:
Benjamin Summers 2019-12-17 08:55:10 -08:00
parent caa3d7f33c
commit c579335288
6 changed files with 57 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
pkg/king/app/CLI.hs
View File

@ -85,7 +85,7 @@ data Cmd
= CmdNew New Opts
| CmdRun Run Opts
| CmdBug Bug
| CmdCon Word16
| CmdCon FilePath
deriving (Show)
--------------------------------------------------------------------------------
@ -172,12 +172,12 @@ pillFromURL = PillSourceURL <$> strOption
<> value defaultPillURL
<> help "URL to pill file")
pierPath :: Parser FilePath
pierPath = strArgument (metavar "PIER" <> help "Path to pier")
new :: Parser New
new = do
nPierPath <- optional
$ strArgument
$ metavar "PIER"
<> help "Path to pier"
nPierPath <- optional pierPath
nBootType <- newComet <|> newFakeship <|> newFromKeyfile
@ -265,7 +265,7 @@ newShip = CmdNew <$> new <*> opts
runShip :: Parser Cmd
runShip = do
rPierPath <- strArgument (metavar "PIER" <> help "Path to pier")
rPierPath <- pierPath
o <- opts
pure (CmdRun (Run{..}) o)
@ -281,9 +281,6 @@ valPill = do
pure ValidatePill{..}
pierPath :: Parser FilePath
pierPath = strArgument (metavar "PIER" <> help "Path to pier")
keyfilePath :: Parser FilePath
keyfilePath = strArgument (metavar "KEYFILE" <> help "Path to key file")
@ -344,11 +341,7 @@ bugCmd = fmap CmdBug
)
conCmd :: Parser Cmd
conCmd = do
port <- argument auto ( metavar "PORT"
<> help "Port of terminal server"
)
pure (CmdCon port)
conCmd = CmdCon <$> pierPath
allFx :: Parser Bug
allFx = do

41
pkg/king/app/Main.hs
View File

@ -72,8 +72,9 @@ import Control.Concurrent (myThreadId, runInBoundThread)
import Control.Exception (AsyncException(UserInterrupt))
import Control.Lens ((&))
import Data.Default (def)
import King.App (runApp, runPierApp)
import King.App (runApp, runPierApp, HasConfigDir(..))
import System.Environment (getProgName)
import System.Exit (exitSuccess)
import System.Posix.Signals (Handler(Catch), installHandler, sigTERM)
import System.Random (randomIO)
import Text.Show.Pretty (pPrint)
@ -138,7 +139,9 @@ toNetworkConfig CLI.Opts{..} = NetworkConfig
, ncAmesPort = oAmesPort
}
tryBootFromPill :: (HasLogFunc e, HasNetworkConfig e, HasPierConfig e)
tryBootFromPill :: ( HasLogFunc e, HasNetworkConfig e, HasPierConfig e
, HasConfigDir e
)
=> Bool -> Pill -> Bool -> Serf.Flags -> Ship
-> LegacyBootEvent
-> RIO e ()
@ -152,7 +155,9 @@ tryBootFromPill oExit pill lite flags ship boot =
rio $ logTrace "Completed boot"
pure sls
runOrExitImmediately :: (HasLogFunc e, HasNetworkConfig e, HasPierConfig e)
runOrExitImmediately :: ( HasLogFunc e, HasNetworkConfig e, HasPierConfig e
, HasConfigDir e
)
=> RAcquire e (Serf e, Log.EventLog, SerfState)
-> Bool
-> RIO e ()
@ -170,7 +175,9 @@ runOrExitImmediately getPier oExit =
runPier sls = do
runRAcquire $ Pier.pier sls
tryPlayShip :: (HasLogFunc e, HasNetworkConfig e, HasPierConfig e)
tryPlayShip :: ( HasLogFunc e, HasNetworkConfig e, HasPierConfig e
, HasConfigDir e
)
=> Bool -> Bool -> Serf.Flags -> RIO e ()
tryPlayShip exitImmediately fullReplay flags = do
when fullReplay wipeSnapshot
@ -471,23 +478,23 @@ main = do
installHandler sigTERM (Catch onTermSig) Nothing
CLI.parseArgs >>= \case
CLI.CmdRun r o -> runShip r o
CLI.CmdNew n o -> runApp $ newShip n o
CLI.CmdBug (CLI.CollectAllFX pax) -> runApp $ collectAllFx pax
CLI.CmdBug (CLI.EventBrowser pax) -> runApp $ startBrowser pax
CLI.CmdBug (CLI.ValidatePill pax pil seq) -> runApp $ testPill pax pil seq
CLI.CmdBug (CLI.ValidateEvents pax f l) -> runApp $ checkEvs pax f l
CLI.CmdBug (CLI.ValidateFX pax f l) -> runApp $ checkFx pax f l
CLI.CmdBug (CLI.CheckDawn pax) -> runApp $ checkDawn pax
CLI.CmdBug CLI.CheckComet -> runApp $ checkComet
CLI.CmdCon port -> runApp $ connTerm port
CLI.CmdRun r o -> runShip r o
CLI.CmdNew n o -> runApp $ newShip n o
CLI.CmdBug (CLI.CollectAllFX pax) -> runApp $ collectAllFx pax
CLI.CmdBug (CLI.EventBrowser pax) -> runApp $ startBrowser pax
CLI.CmdBug (CLI.ValidatePill pax pil s) -> runApp $ testPill pax pil s
CLI.CmdBug (CLI.ValidateEvents pax f l) -> runApp $ checkEvs pax f l
CLI.CmdBug (CLI.ValidateFX pax f l) -> runApp $ checkFx pax f l
CLI.CmdBug (CLI.CheckDawn pax) -> runApp $ checkDawn pax
CLI.CmdBug CLI.CheckComet -> runApp $ checkComet
CLI.CmdCon pier -> runApp $ connTerm pier
--------------------------------------------------------------------------------
connTerm :: ∀e. HasLogFunc e => Word16 -> RIO e ()
connTerm port =
Term.runTerminalClient (fromIntegral port)
connTerm :: ∀e. HasLogFunc e => FilePath -> RIO e ()
connTerm pier =
Term.runTerminalClient pier
--------------------------------------------------------------------------------

12
pkg/king/lib/King/API.hs
View File

@ -1,3 +1,9 @@
{-
TODO This has a bunch of stub logic that was intended for an
architecture with a single Urbit daemon running multiple
ships. Do it or strip it out.
-}
module King.API (kingAPI, readPortsFile) where
import UrbitPrelude
@ -7,7 +13,7 @@ import RIO.Directory
import King.App (HasConfigDir(..))
import Network.Socket (Socket)
import Prelude (read)
import Vere.LockFile (lockFile)
-- rt Vere.LockFile (lockFile)
import qualified Network.HTTP.Types as H
import qualified Network.Wai as W
@ -70,7 +76,7 @@ readPortsFile :: HasConfigDir e => RIO e (Maybe Word)
readPortsFile = do
(_, fil) <- portsFilePath
bs <- readFile fil
evaluate (read $ unpack $ decodeUtf8 bs)
evaluate (readMay $ unpack $ decodeUtf8 bs)
kingServer :: HasLogFunc e => (Int, Socket) -> RAcquire e King
kingServer is =
@ -90,7 +96,7 @@ kingAPI :: (HasConfigDir e, HasLogFunc e)
kingAPI = do
(port, sock) <- io $ W.openFreePort
(dir, fil) <- portsFile (fromIntegral port)
lockFile dir
-- lockFile dir
kingServer (port, sock)
stubStatus :: StatusResp

2
pkg/king/lib/Vere/NounServ.hs
View File

@ -87,7 +87,7 @@ wsClient por = do
-- logDebug "NOUNSERV (wsClie) Trying to connect"
tid <- io $ async
$ WS.runClient "127.0.0.1" por "/"
$ WS.runClient "127.0.0.1" por "/terminal/~zod/1"
$ runRIO env . wsConn "NOUNSERV (wsClie) " inp out
pure $ Client con tid

6
pkg/king/lib/Vere/Pier.hs
View File

@ -12,6 +12,7 @@ import System.Random
import Vere.Pier.Types
import Data.Text (append)
import King.App (HasConfigDir(..))
import System.Posix.Files (ownerModes, setFileMode)
import Vere.Ames (ames)
import Vere.Behn (behn)
@ -23,6 +24,7 @@ import Vere.Serf (Serf, SerfState(..), doJob, sStderr)
import RIO.Directory
import qualified King.API as King
import qualified System.Console.Terminal.Size as TSize
import qualified System.Entropy as Ent
import qualified Urbit.Time as Time
@ -140,7 +142,7 @@ resumed flags = do
acquireWorker :: RIO e () -> RAcquire e (Async ())
acquireWorker act = mkRAcquire (async act) cancel
pier :: ∀e. (HasLogFunc e, HasNetworkConfig e, HasPierConfig e)
pier :: ∀e. (HasConfigDir e, HasLogFunc e, HasNetworkConfig e, HasPierConfig e)
=> (Serf e, EventLog, SerfState)
-> RAcquire e ()
pier (serf, log, ss) = do
@ -150,6 +152,8 @@ pier (serf, log, ss) = do
saveM <- newEmptyTMVarIO
shutdownM <- newEmptyTMVarIO
_api ← King.kingAPI
let shutdownEvent = putTMVar shutdownM ()
inst <- io (KingId . UV . fromIntegral <$> randomIO @Word16)

14
pkg/king/lib/Vere/Term.hs
View File

@ -21,6 +21,8 @@ import UrbitPrelude hiding (getCurrentTime)
import Vere.Pier.Types
import Data.List ((!!))
import King.API (readPortsFile)
import King.App (HasConfigDir(..))
import RIO.Directory (createDirectoryIfMissing)
import Vere.Term.API (Client(Client))
@ -156,10 +158,16 @@ connectToRemote port local = mkRAcquire start stop
pure (ferry, cAsync)
runTerminalClient :: ∀e. HasLogFunc e => Port -> RIO e ()
runTerminalClient port = runRAcquire $ do
data HackConfigDir = HCD { _hcdPax :: FilePath }
makeLenses ''HackConfigDir
instance HasConfigDir HackConfigDir where configDirL = hcdPax
runTerminalClient :: ∀e. HasLogFunc e => FilePath -> RIO e ()
runTerminalClient pier = runRAcquire $ do
mPort <- runRIO (HCD pier) readPortsFile
port <- maybe (error "Can't connect") pure mPort
(tsize, local) <- localClient
(tid1, tid2) <- connectToRemote port local
(tid1, tid2) <- connectToRemote (Port $ fromIntegral port) local
atomically $ waitSTM tid1 <|> waitSTM tid2
where
runRAcquire :: RAcquire e () -> RIO e ()