diff --git a/flake.nix b/flake.nix index b52d5a0..14e66eb 100644 --- a/flake.nix +++ b/flake.nix @@ -94,6 +94,7 @@ runtimeInputs = [ pkgs.cabal-install pkgs.coreutils + pkgs.socat ghcWithDeps ] ++ runtimeDeps; @@ -103,7 +104,7 @@ cd "$dir" cp -r ${devSrc}/. . chmod -R a+w . - cabal run spec --ghc-option=-Werror -- --strict + socat - EXEC:"cabal run spec --ghc-option=-Werror -- --strict",pty,setsid,ctty ''; }); }; diff --git a/package.yaml b/package.yaml index b1440ce..cc0b02a 100644 --- a/package.yaml +++ b/package.yaml @@ -66,6 +66,7 @@ dependencies: - process - safe-exceptions - string-conversions + - strip-ansi-escape - text - unix - xdg-basedir diff --git a/spec/IntegrationSpec.hs b/spec/IntegrationSpec.hs index 94211ef..475ffa9 100644 --- a/spec/IntegrationSpec.hs +++ b/spec/IntegrationSpec.hs @@ -6,6 +6,7 @@ module IntegrationSpec where import Context import Control.Concurrent (readMVar) import Control.Concurrent.MVar (newEmptyMVar, putMVar) +import Cradle qualified import Data.ByteString qualified as B import Data.Maybe (fromMaybe) import Data.String.Conversions @@ -13,6 +14,7 @@ import Data.String.Interpolate (i) import Data.Text qualified as T import Data.Text.IO qualified as T import NixVms qualified +import Options (VmName (..)) import State (readState) import StdLib import System.Directory (doesDirectoryExist, listDirectory) @@ -105,6 +107,14 @@ spec = around_ inTempDirectory $ do files <- listDirectory "." files `shouldBe` [] + it "`vmcli start` doesn't mess up the terminal" $ do + withContext $ \ctx -> do + writeStandardFlake ctx Nothing + Cradle.StdoutRaw before <- Cradle.run $ Cradle.cmd "stty" & Cradle.addArgs ["-a" :: Text] + _ <- assertSuccess $ test ctx ["start", "server"] + Cradle.StdoutRaw after <- Cradle.run $ Cradle.cmd "stty" & Cradle.addArgs ["-a" :: Text] + after `shouldBe` before + it "starts vms with arbitrary hostnames" $ do withContext $ \ctx -> do writeStandardFlake ctx (Just "{ lib, ...} : { networking.hostName = lib.mkForce \"other-hostname\"; }") diff --git a/spec/TestUtils.hs b/spec/TestUtils.hs index 3bd6282..867f1c6 100644 --- a/spec/TestUtils.hs +++ b/spec/TestUtils.hs @@ -10,6 +10,7 @@ import Data.String (IsString) import Data.String.Conversions import GHC.Exts (IsString (..)) import Network.Socket.Free (getFreePort) +import Options (VmName (..)) import Run (run) import State import StdLib @@ -80,7 +81,7 @@ withMockContext vmNames action = do NixVms { listVms = \_ctx -> pure vmNames, buildAndRun = - \ctx vmName -> do + \ctx _verbosity vmName -> do unless (vmName `elem` vmNames) $ do error $ cs $ "nix vm mock: vm not found: " <> vmNameToText vmName (_, _, _, ph) <- do diff --git a/src/Commands.hs b/src/Commands.hs index d5f6c53..5cd49e5 100644 --- a/src/Commands.hs +++ b/src/Commands.hs @@ -15,7 +15,7 @@ import Data.List.NonEmpty qualified as NonEmpty import Data.Maybe (fromMaybe) import Data.Text qualified as T import Data.Text.IO qualified as T -import Options (StartOptions (..)) +import Options (StartOptions (..), Verbosity, VmName (..)) import State import StdLib import System.Directory (doesFileExist) @@ -32,8 +32,8 @@ list ctx = do [] -> "no vms configured" vms -> "configured vms: " <> T.intercalate ", " (map vmNameToText vms) -start :: Context -> StartOptions -> IO () -start ctx startOptions = do +start :: Context -> Verbosity -> StartOptions -> IO () +start ctx verbosity startOptions = do vmNames <- case startOptions of StartAll -> do vmNames <- listVms (nixVms ctx) ctx @@ -57,7 +57,7 @@ start ctx startOptions = do -- todo: make runtime dep Cradle.cmd "ssh-keygen" & Cradle.addArgs ["-f", vmKeyPath, "-N", ""] - ph <- buildAndRun (nixVms ctx) ctx vmName + ph <- buildAndRun (nixVms ctx) ctx verbosity vmName registerProcess ctx ph pid <- getPid ph <&> fromMaybe (error "no pid") state <- readState ctx vmName diff --git a/src/Context.hs b/src/Context.hs index 67a3588..a0ff0c9 100644 --- a/src/Context.hs +++ b/src/Context.hs @@ -1,6 +1,7 @@ module Context where import Cradle qualified +import Options (Verbosity, VmName) import StdLib import System.IO import System.Process @@ -16,9 +17,6 @@ data Context = Context data NixVms = NixVms { listVms :: Context -> IO [VmName], - buildAndRun :: Context -> VmName -> IO ProcessHandle, + buildAndRun :: Context -> Verbosity -> VmName -> IO ProcessHandle, sshIntoHost :: forall o. (Cradle.Output o) => Context -> VmName -> [Text] -> IO o } - -newtype VmName = VmName {vmNameToText :: Text} - deriving stock (Eq, Show, Ord) diff --git a/src/NixVms.hs b/src/NixVms.hs index 38dc269..1b711b1 100644 --- a/src/NixVms.hs +++ b/src/NixVms.hs @@ -1,20 +1,23 @@ module NixVms (NixVms (..), production) where import Context +import Control.Concurrent (forkIO) import Cradle import Data.Aeson qualified as Aeson import Data.Map.Strict qualified as Map +import Data.String.AnsiEscapeCodes.Strip.Text (stripAnsiEscapeCodes) import Data.String.Conversions (cs) import Data.String.Interpolate (i) import Data.Text qualified as T import Data.Text.IO qualified as T import Network.Socket.Free (getFreePort) +import Options (Verbosity (..), VmName (..)) import State import StdLib import System.Directory (createDirectoryIfMissing, listDirectory) import System.Environment (getEnvironment) import System.FilePath (takeDirectory, ()) -import System.IO (IOMode (..), openFile) +import System.IO (Handle, IOMode (..), openFile) import System.IO qualified import System.Process (CreateProcess (..), ProcessHandle, StdStream (..), createProcess, proc) import Utils @@ -47,8 +50,8 @@ listVmsImpl ctx = do Left err -> error err Right (parsed :: [Text]) -> pure $ map VmName parsed -buildAndRunImpl :: Context -> VmName -> IO ProcessHandle -buildAndRunImpl ctx vmName = do +buildAndRunImpl :: Context -> Verbosity -> VmName -> IO ProcessHandle +buildAndRunImpl ctx verbosity vmName = do vmExecutable <- logStep "Building NixOS config..." $ do moduleExtensions <- getModuleExtensions ctx vmName (Cradle.StdoutTrimmed drvPathJson) <- @@ -85,24 +88,7 @@ buildAndRunImpl ctx vmName = do case files of [file] -> pure $ cs outPath "bin" file files -> error $ "expected one vm script: " <> show files - - logStep "Starting VM..." $ do - storageDir <- getStateDir ctx vmName - let nixDiskImage = storageDir cs (vmNameToText vmName) "image.qcow2" - createDirectoryIfMissing True (takeDirectory nixDiskImage) - stdoutHandle <- openFile (storageDir "./stdout.log") WriteMode - stderrHandle <- openFile (storageDir "./stderr.log") WriteMode - (_, _, _, ph) <- do - parentEnvironment <- - getEnvironment - <&> Map.fromList - createProcess - (proc vmExecutable []) - { env = Just $ Map.toList $ Map.insert "NIX_DISK_IMAGE" nixDiskImage parentEnvironment, - std_out = UseHandle stdoutHandle, - std_err = UseHandle stderrHandle - } - pure ph + logStep "Starting VM..." $ runVm ctx verbosity vmName vmExecutable nixStandardFlags :: [Text] nixStandardFlags = @@ -148,6 +134,41 @@ toNixString s = "\"" <> T.concatMap escapeChar (cs s) <> "\"" '\\' -> "\\\\" c -> T.singleton c +runVm :: Context -> Verbosity -> VmName -> FilePath -> IO ProcessHandle +runVm ctx verbosity vmName vmExecutable = do + storageDir <- getStateDir ctx vmName + let nixDiskImage = storageDir cs (vmNameToText vmName) "image.qcow2" + createDirectoryIfMissing True (takeDirectory nixDiskImage) + parentEnvironment <- getEnvironment <&> Map.fromList + let mkProc stdout stdin = + (System.Process.proc vmExecutable []) + { env = Just $ Map.toList $ Map.insert "NIX_DISK_IMAGE" nixDiskImage parentEnvironment, + std_in = CreatePipe, + std_out = stdout, + std_err = stdin + } + proc <- case verbosity of + DefaultVerbosity -> do + stdoutHandle <- openFile (storageDir "./stdout.log") WriteMode + stderrHandle <- openFile (storageDir "./stderr.log") WriteMode + pure $ mkProc (UseHandle stdoutHandle) (UseHandle stderrHandle) + Verbose -> pure $ mkProc CreatePipe CreatePipe + (_, stdout, stderr, ph) <- createProcess proc + case verbosity of + DefaultVerbosity -> pure () + Verbose -> do + (Just stdout, Just stderr) <- pure (stdout, stderr) + _ <- forkIO $ streamHandles "qemu" stdout System.IO.stdout + _ <- forkIO $ streamHandles "qemu" stderr System.IO.stderr + pure () + pure ph + +streamHandles :: Text -> Handle -> Handle -> IO () +streamHandles prefix input output = do + chunk <- T.hGetLine input + T.hPutStrLn output $ prefix <> "> " <> stripAnsiEscapeCodes chunk + streamHandles prefix input output + sshIntoHostImpl :: (Cradle.Output o) => Context -> VmName -> [Text] -> IO o sshIntoHostImpl ctx vmName command = do vmKeyPath <- getStateFile ctx vmName "vmkey" diff --git a/src/Options.hs b/src/Options.hs index 24581cc..b6d2278 100644 --- a/src/Options.hs +++ b/src/Options.hs @@ -1,12 +1,13 @@ module Options - ( Options (..), + ( parser, + Options (..), + Verbosity (..), Command (..), StartOptions (..), - parser, + VmName (..), ) where -import Context import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NonEmpty import Data.Text @@ -18,14 +19,26 @@ newtype Options = Options Command data Command = List - | Start StartOptions + | Start {verbosity :: Verbosity, options :: StartOptions} | Ssh {vmName :: VmName, sshCommand :: [Text]} | Status {vmNames :: [VmName]} | Stop {vmName :: VmName} deriving stock (Show, Generic) -parseVmName :: Parser VmName -parseVmName = VmName <$> argument str (metavar "VM_NAME") +data Verbosity + = DefaultVerbosity + | Verbose + deriving stock (Show) + +parseVerbosity :: Parser Verbosity +parseVerbosity = + flag + DefaultVerbosity + Verbose + ( long "verbose" + <> short 'v' + <> help "increase verbosity" + ) data StartOptions = StartAll @@ -53,7 +66,7 @@ parser = <> command "start" ( info - (Start <$> parseStartOptions) + (Start <$> parseVerbosity <*> parseStartOptions) (fullDesc <> progDesc "Start a development vm") ) <> command @@ -75,3 +88,9 @@ parser = (progDesc "Stop a running vm") ) ) + +newtype VmName = VmName {vmNameToText :: Text} + deriving stock (Eq, Show, Ord) + +parseVmName :: Parser VmName +parseVmName = VmName <$> argument str (metavar "VM_NAME") diff --git a/src/Run.hs b/src/Run.hs index d666cfa..c7a67d9 100644 --- a/src/Run.hs +++ b/src/Run.hs @@ -26,7 +26,7 @@ run ctx args = (Options opts) <- handleParseResult $ execParserPure (prefs showHelpOnError) parser (cs <$> args) case opts of List -> list ctx - Start vmNames -> start ctx vmNames + Start verbosity vmNames -> start ctx verbosity vmNames Stop vmName -> stop ctx vmName Ssh vmName command -> ssh ctx vmName command Status vmNames -> status ctx vmNames diff --git a/src/State.hs b/src/State.hs index a0ea3ff..ec890f5 100644 --- a/src/State.hs +++ b/src/State.hs @@ -5,6 +5,7 @@ import Control.Monad (filterM) import Data.Aeson import Data.String.Conversions (cs) import Data.Text.IO qualified as T +import Options (VmName (..)) import StdLib import System.Directory ( createDirectoryIfMissing, diff --git a/vmcli.cabal b/vmcli.cabal index 5560f7a..e698088 100644 --- a/vmcli.cabal +++ b/vmcli.cabal @@ -55,6 +55,7 @@ executable vmcli , process , safe-exceptions , string-conversions + , strip-ansi-escape , text , unix , xdg-basedir @@ -120,6 +121,7 @@ test-suite spec , safe-exceptions , silently , string-conversions + , strip-ansi-escape , temporary , text , unix