Prevent vmcli start from messing up Ctrl+C

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
               '';
             });
           };

package.yaml

@@ -66,6 +66,7 @@ dependencies:
   - process
   - safe-exceptions
   - string-conversions
+  - strip-ansi-escape
   - text
   - unix
   - xdg-basedir

spec/IntegrationSpec.hs

@@ -6,13 +6,15 @@ 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
 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\"; }")

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

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

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)

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"

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")

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

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,

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