├── .golden ├── table-4 │ └── golden ├── table-1 │ └── golden ├── table-5 │ └── golden ├── table-6 │ └── golden ├── table-8 │ └── golden ├── table-7 │ └── golden ├── table-2 │ └── golden ├── table-3 │ └── golden ├── table-colors │ └── golden ├── storage-tree │ └── golden ├── impossible-message │ └── golden ├── stderr │ └── golden └── ansi-logger │ └── golden ├── garnix.yaml ├── spec ├── Spec.hs ├── SpecHook.hs ├── static-ips │ ├── flake.nix │ └── flake.lock ├── domains │ ├── flake.lock │ └── flake.nix ├── LoggingSpec.hs ├── UtilsSpec.hs ├── TableSpec.hs ├── LoggerSpec.hs ├── TestUtils.hs ├── NetworkingSpec.hs ├── CliSpec.hs ├── TapSpec.hs ├── IntegrationSpec.hs └── UpSpec.hs ├── .hlint.yaml ├── hie.yaml ├── .gitignore ├── src ├── Main.hs ├── Version.hs ├── Context │ ├── Production.hs │ └── Utils.hs ├── Logging.hs ├── StdLib.hs ├── Utils.hs ├── Run.hs ├── SafeCreatePipe.hs ├── Context.hs ├── Table.hs ├── Options.hs ├── Logger.hs ├── Commands.hs ├── Vde.hs ├── State.hs ├── NixVms.hs └── Commands │ └── Up.hs ├── LICENSE ├── package.yaml ├── README.md ├── flake.lock ├── nixos-compose.cabal └── flake.nix /.golden/table-4/golden: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /garnix.yaml: -------------------------------------------------------------------------------- 1 | actions: 2 | - on: push 3 | run: spec 4 | -------------------------------------------------------------------------------- /spec/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | - ignore: { name: Functor law } 2 | - ignore: { name: Use <$> } 3 | -------------------------------------------------------------------------------- /hie.yaml: -------------------------------------------------------------------------------- 1 | cradle: 2 | cabal: 3 | - path: "." 4 | component: "spec" 5 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | actual 2 | /dist-newstyle 3 | result 4 | *.qcow2 5 | cabal.project.local 6 | -------------------------------------------------------------------------------- /.golden/table-1/golden: -------------------------------------------------------------------------------- 1 | ┌───┬─────┐ 2 | │ h │ g │ 3 | ├───┼─────┤ 4 | │ a │ foo │ 5 | │ b │ bar │ 6 | └───┴─────┘ 7 | -------------------------------------------------------------------------------- /.golden/table-5/golden: -------------------------------------------------------------------------------- 1 | ┌────┬────┐ 2 | │ h │ g │ 3 | ├────┼────┤ 4 | │ h1 │ g1 │ 5 | │ h2 │ │ 6 | └────┴────┘ 7 | -------------------------------------------------------------------------------- /.golden/table-6/golden: -------------------------------------------------------------------------------- 1 | ┌────┬────┐ 2 | │ h │ g │ 3 | ├────┼────┤ 4 | │ h1 │ g1 │ 5 | │ │ g2 │ 6 | └────┴────┘ 7 | -------------------------------------------------------------------------------- /.golden/table-8/golden: -------------------------------------------------------------------------------- 1 | ┌────┬────┐ 2 | │ h │ g │ 3 | ├────┼────┤ 4 | │ h1 │ │ 5 | │ h2 │ g2 │ 6 | └────┴────┘ 7 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Run (runInProduction) 4 | 5 | main :: IO () 6 | main = runInProduction 7 | -------------------------------------------------------------------------------- /.golden/table-7/golden: -------------------------------------------------------------------------------- 1 | ┌────┬────┬────┐ 2 | │ h │ g │ i │ 3 | ├────┼────┼────┤ 4 | │ h1 │ g1 │ i1 │ 5 | │ h2 │ │ i2 │ 6 | │ h3 │ g3 │ i3 │ 7 | └────┴────┴────┘ 8 | -------------------------------------------------------------------------------- /spec/SpecHook.hs: -------------------------------------------------------------------------------- 1 | module SpecHook where 2 | 3 | import System.Environment 4 | import Test.Hspec 5 | 6 | hook :: Spec -> Spec 7 | hook = aroundAll_ (withProgName "nixos-compose") 8 | -------------------------------------------------------------------------------- /.golden/table-2/golden: -------------------------------------------------------------------------------- 1 | ┌──────────┬──────────┐ 2 | │ longer-1 │ longer-2 │ 3 | ├──────────┼──────────┤ 4 | │ a │ foo │ 5 | │ b │ bar │ 6 | └──────────┴──────────┘ 7 | -------------------------------------------------------------------------------- /.golden/table-3/golden: -------------------------------------------------------------------------------- 1 | ┌──────────────┬────────────────┐ 2 | │ h │ g │ 3 | ├──────────────┼────────────────┤ 4 | │ longer-value │ a │ 5 | │ b │ also-very-long │ 6 | └──────────────┴────────────────┘ 7 | -------------------------------------------------------------------------------- /.golden/table-colors/golden: -------------------------------------------------------------------------------- 1 | ┌───┬────────┐ 2 | │ h │ g  │ 3 | ├───┼────────┤ 4 | │ a │ foo  │ 5 | │ b │ longer │ 6 | └───┴────────┘ 7 | -------------------------------------------------------------------------------- /.golden/storage-tree/golden: -------------------------------------------------------------------------------- 1 | . 2 | ├── state.json 3 | ├── vde_switch.ctl 4 | │   ├── 001.9 5 | │   └── ctl 6 | └── vms 7 | └── server 8 | ├── image.qcow2 9 | ├── log.txt 10 | ├── vmkey 11 | └── vmkey.pub 12 | 13 | 4 directories, 7 files 14 | -------------------------------------------------------------------------------- /src/Version.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module Version (version) where 4 | 5 | import Data.String.Interpolate (i) 6 | import StdLib 7 | 8 | {-# NOINLINE version #-} 9 | version :: Text 10 | version = case cs [i|__NIXOS_COMPOSE_VERSION__|] of 11 | "__NIXOS_COMPOSE_VERSION__" -> "unknown" 12 | version -> version 13 | -------------------------------------------------------------------------------- /.golden/impossible-message/golden: -------------------------------------------------------------------------------- 1 | nixos-compose encountered an unexpected error: test message 2 | Please, consider reporting this as a bug here: https://github.com/garnix-io/nixos-compose/issues 3 | 4 | callstack: 5 | CallStack (from HasCallStack): 6 | impossible, called at spec/LoggingSpec.hs:20:90 in nixos-compose-0.0.0-inplace-spec:LoggingSpec 7 | -------------------------------------------------------------------------------- /spec/static-ips/flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | inputs.nixpkgs.url = "github:nixos/nixpkgs/3ff0e34b1383648053bba8ed03f201d3466f90c9"; 3 | outputs = { nixpkgs, ... }: 4 | let 5 | common = { 6 | nixpkgs.hostPlatform = "x86_64-linux"; 7 | system.stateVersion = "25.05"; 8 | }; 9 | in 10 | { 11 | nixosConfigurations.a = (nixpkgs.lib.nixosSystem { 12 | modules = [ 13 | { networking.hostName = "a"; } 14 | common 15 | ]; 16 | }); 17 | nixosConfigurations.b = (nixpkgs.lib.nixosSystem { 18 | modules = [ 19 | { networking.hostName = "b"; } 20 | common 21 | ]; 22 | }); 23 | }; 24 | } 25 | -------------------------------------------------------------------------------- /src/Context/Production.hs: -------------------------------------------------------------------------------- 1 | module Context.Production where 2 | 3 | import Context 4 | import Logger (withAutoLogger) 5 | import NixVms qualified 6 | import System.Directory (XdgDirectory (..), getCurrentDirectory, getXdgDirectory) 7 | import System.IO 8 | 9 | withContext :: (Context -> IO ()) -> IO () 10 | withContext action = do 11 | workingDir <- getCurrentDirectory 12 | storageDir <- getXdgDirectory XdgState "nixos-compose" 13 | withAutoLogger $ \logger -> do 14 | action $ 15 | Context 16 | { testState = Nothing, 17 | Context.stdin = System.IO.stdin, 18 | workingDir, 19 | storageDir, 20 | nixVms = NixVms.production, 21 | logger 22 | } 23 | -------------------------------------------------------------------------------- /spec/domains/flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "nixpkgs": { 4 | "locked": { 5 | "lastModified": 1753345091, 6 | "narHash": "sha256-CdX2Rtvp5I8HGu9swBmYuq+ILwRxpXdJwlpg8jvN4tU=", 7 | "owner": "nixos", 8 | "repo": "nixpkgs", 9 | "rev": "3ff0e34b1383648053bba8ed03f201d3466f90c9", 10 | "type": "github" 11 | }, 12 | "original": { 13 | "owner": "nixos", 14 | "repo": "nixpkgs", 15 | "rev": "3ff0e34b1383648053bba8ed03f201d3466f90c9", 16 | "type": "github" 17 | } 18 | }, 19 | "root": { 20 | "inputs": { 21 | "nixpkgs": "nixpkgs" 22 | } 23 | } 24 | }, 25 | "root": "root", 26 | "version": 7 27 | } 28 | -------------------------------------------------------------------------------- /spec/static-ips/flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "nixpkgs": { 4 | "locked": { 5 | "lastModified": 1753345091, 6 | "narHash": "sha256-CdX2Rtvp5I8HGu9swBmYuq+ILwRxpXdJwlpg8jvN4tU=", 7 | "owner": "nixos", 8 | "repo": "nixpkgs", 9 | "rev": "3ff0e34b1383648053bba8ed03f201d3466f90c9", 10 | "type": "github" 11 | }, 12 | "original": { 13 | "owner": "nixos", 14 | "repo": "nixpkgs", 15 | "rev": "3ff0e34b1383648053bba8ed03f201d3466f90c9", 16 | "type": "github" 17 | } 18 | }, 19 | "root": { 20 | "inputs": { 21 | "nixpkgs": "nixpkgs" 22 | } 23 | } 24 | }, 25 | "root": "root", 26 | "version": 7 27 | } 28 | -------------------------------------------------------------------------------- /.golden/stderr/golden: -------------------------------------------------------------------------------- 1 | Missing: COMMAND 2 | 3 | Usage: nixos-compose COMMAND 4 | 5 | Available options: 6 | -h,--help Show this help text 7 | --version Show version (unknown) and exit 8 | 9 | Available commands: 10 | up Start development vms 11 | down Stop running vms 12 | ssh `ssh` into a running vm 13 | status Show the status of running vms 14 | list List all configured vms 15 | ip Print the ip address of a vm (in the virtual network) 16 | tap Set up a tap device, to allow network access to vms 17 | from the host (uses `sudo`) 18 | -------------------------------------------------------------------------------- /spec/LoggingSpec.hs: -------------------------------------------------------------------------------- 1 | module LoggingSpec where 2 | 3 | import Control.Exception.Safe (try) 4 | import Logging 5 | import StdLib 6 | import System.IO qualified 7 | import System.IO.Silently (hCapture, hSilence) 8 | import Test.Hspec 9 | import Test.Hspec.Golden (defaultGolden) 10 | import TestUtils (withMockContext) 11 | 12 | spec :: Spec 13 | spec = do 14 | describe "impossible" $ around (withMockContext []) $ do 15 | it "throws" $ \ctx -> do 16 | hSilence [System.IO.stderr] $ do 17 | impossible ctx "foo" `shouldThrow` (== ExitFailure 1) 18 | 19 | it "produces a nice error message" $ \ctx -> do 20 | (output, _) :: (String, Either ExitCode ()) <- hCapture [System.IO.stderr] $ try $ impossible ctx "test message" 21 | pure $ defaultGolden "impossible-message" output 22 | -------------------------------------------------------------------------------- /src/Logging.hs: -------------------------------------------------------------------------------- 1 | module Logging where 2 | 3 | import Context (Context) 4 | import Data.Text qualified as T 5 | import GHC.Stack (HasCallStack, callStack, prettyCallStack) 6 | import StdLib 7 | import Context.Utils 8 | 9 | -- | Prints the message to `stderr` and exits with exit code 1. 10 | -- This is our standard way of aborting the program on error conditions. 11 | abort :: Context -> Text -> IO a 12 | abort ctx message = do 13 | info ctx $ T.stripEnd message 14 | exitWith $ ExitFailure 1 15 | 16 | impossible :: (HasCallStack) => Context -> Text -> IO a 17 | impossible ctx message = do 18 | abort 19 | ctx 20 | ( T.unlines 21 | [ "nixos-compose encountered an unexpected error: " <> message, 22 | "Please, consider reporting this as a bug here: https://github.com/garnix-io/nixos-compose/issues", 23 | "", 24 | "callstack:", 25 | cs (prettyCallStack callStack) 26 | ] 27 | ) 28 | -------------------------------------------------------------------------------- /src/Context/Utils.hs: -------------------------------------------------------------------------------- 1 | module Context.Utils (runWithErrorHandling, info, output) where 2 | 3 | import Context 4 | import Cradle 5 | import Cradle.ProcessConfiguration qualified 6 | import Data.Text qualified as T 7 | import StdLib 8 | import System.IO qualified 9 | 10 | runWithErrorHandling :: (Cradle.Output o) => Context -> ProcessConfiguration -> IO o 11 | runWithErrorHandling ctx pc = do 12 | (exitCode, StdoutRaw stdout, StderrRaw stderr, o) <- run pc 13 | case exitCode of 14 | ExitSuccess -> pure o 15 | ExitFailure code -> do 16 | info 17 | ctx 18 | ( "Command exited with code " 19 | <> cs (show code) 20 | <> ": " 21 | <> cs (Cradle.ProcessConfiguration.executable pc) 22 | <> " " 23 | <> T.unwords (cs <$> Cradle.ProcessConfiguration.arguments pc) 24 | <> "\n" 25 | <> cs stdout 26 | <> "\n" 27 | <> cs stderr 28 | ) 29 | exitWith exitCode 30 | 31 | info :: Context -> Text -> IO () 32 | info ctx = (ctx ^. #logger . #pushLog) System.IO.stderr 33 | 34 | output :: Context -> Text -> IO () 35 | output ctx = (ctx ^. #logger . #pushLog) System.IO.stdout 36 | -------------------------------------------------------------------------------- /.golden/ansi-logger/golden: -------------------------------------------------------------------------------- 1 | This asserts stdout and stderr of the ansi logger 2 | If these change it's best that you manually confirm that the logger still works well in a real terminal 3 | 4 | a: building 5 | a: building 6 | b: building 7 | a: building 8 | b: building 9 | c: building 10 | log line 11 | a: building 12 | b: building 13 | c: building 14 | a: building 15 | b: starting 16 | c: building 17 | log line 18 | a: building 19 | b: starting 20 | c: building 21 | a: starting 22 | b: starting 23 | c: building 24 | this is a very long log line 25 | a: starting 26 | b: starting 27 | c: building 28 | b: starting 29 | c: building 30 | b: starting 31 | c: building 32 | log line 33 | b: starting 34 | c: building 35 | c: building 36 | log line 37 | c: building 38 |  39 | -------------------------------------------------------------------------------- /spec/domains/flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | inputs.nixpkgs.url = "github:nixos/nixpkgs/3ff0e34b1383648053bba8ed03f201d3466f90c9"; 3 | outputs = { self, nixpkgs, ... }: 4 | let 5 | common = { 6 | nixpkgs.hostPlatform = "x86_64-linux"; 7 | system.stateVersion = "25.05"; 8 | }; 9 | in 10 | { 11 | nixosConfigurations.server = (nixpkgs.lib.nixosSystem { 12 | modules = [ 13 | { 14 | networking.hostName = "server"; 15 | services.nginx = { 16 | enable = true; 17 | virtualHosts.default.locations."/".return = "200 'hello from nginx'"; 18 | }; 19 | networking.firewall.allowedTCPPorts = [ 80 ]; 20 | } 21 | common 22 | ]; 23 | }); 24 | nixosConfigurations.client = (nixpkgs.lib.nixosSystem { 25 | modules = [ 26 | ({ pkgs, ... }: { 27 | networking.hostName = "client"; 28 | environment.systemPackages = [ 29 | (pkgs.writeShellApplication { 30 | name = "fetch-from-server"; 31 | runtimeInputs = [ pkgs.curl ]; 32 | text = "curl http://server/"; 33 | }) 34 | ]; 35 | }) 36 | common 37 | ]; 38 | }); 39 | }; 40 | } 41 | -------------------------------------------------------------------------------- /src/StdLib.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | module StdLib 4 | ( (%~), 5 | (&), 6 | (.~), 7 | (<&>), 8 | (), 9 | (?~), 10 | (^.), 11 | (^?), 12 | (~>), 13 | cs, 14 | ExitCode (..), 15 | exitSuccess, 16 | exitWith, 17 | forM, 18 | forM_, 19 | fromMaybe, 20 | Generic, 21 | mapMaybe, 22 | ProcessID, 23 | sort, 24 | Text, 25 | to, 26 | unless, 27 | when, 28 | ) 29 | where 30 | 31 | import Control.Lens (to, (%~), (&), (.~), (<&>), (?~), (^.), (^?)) 32 | import Control.Monad (forM, forM_, unless, when) 33 | import Data.Aeson (FromJSON (..), ToJSON (..)) 34 | import Data.Generics.Labels () 35 | import Data.Int (Int64) 36 | import Data.List (sort) 37 | import Data.Map qualified as Map 38 | import Data.Maybe (fromMaybe, mapMaybe) 39 | import Data.String.Conversions (cs) 40 | import Data.Text (Text) 41 | import GHC.Generics (Generic) 42 | import System.Exit (ExitCode (..), exitSuccess, exitWith) 43 | import System.FilePath (()) 44 | import System.Posix (ProcessID) 45 | 46 | instance ToJSON ProcessID where 47 | toJSON pid = toJSON (fromIntegral pid :: Int64) 48 | 49 | instance FromJSON ProcessID where 50 | parseJSON value = do 51 | pid :: Int64 <- parseJSON value 52 | pure $ fromIntegral pid 53 | 54 | (~>) :: k -> v -> Map.Map k v 55 | (~>) = Map.singleton 56 | -------------------------------------------------------------------------------- /spec/UtilsSpec.hs: -------------------------------------------------------------------------------- 1 | module UtilsSpec where 2 | 3 | import StdLib 4 | import Test.Hspec 5 | import Utils (hostnameToText, parseHostname) 6 | 7 | spec :: Spec 8 | spec = do 9 | describe "parseHostname" $ do 10 | let validHostnames = 11 | [ "valid", 12 | "WITH-CAPS", 13 | "ending-with-digits-123", 14 | "with-123-digits", 15 | "with-hyphen", 16 | "with.dot" 17 | ] 18 | 19 | let invalidHostnames = 20 | [ "", 21 | "123-starting-with-digits", 22 | "-starting-with-hyphen", 23 | ".starting-with-dot", 24 | "ending-with-dot.", 25 | "ending-with-hyphen-", 26 | "with spaces", 27 | "with--double-hyphen", 28 | "with'symbols", 29 | "with?symbols", 30 | "with_underscore" 31 | ] 32 | 33 | describe "returns Just Hostname for valid hostnames" $ forM_ validHostnames $ \valid -> 34 | it ("\"" <> cs valid <> "\"") $ do 35 | case parseHostname valid of 36 | Nothing -> error "expected Just Hostname" 37 | Just hostname -> hostnameToText hostname `shouldBe` valid 38 | 39 | describe "returns Nothing for invalid hostnames" $ forM_ invalidHostnames $ \invalid -> 40 | it ("\"" <> cs invalid <> "\"") $ parseHostname invalid `shouldBe` Nothing 41 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2025 garnix, Co. 2 | 3 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 4 | 5 | 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 6 | 7 | 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 8 | 9 | 3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. 10 | 11 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS “AS IS” AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 12 | -------------------------------------------------------------------------------- /spec/TableSpec.hs: -------------------------------------------------------------------------------- 1 | module TableSpec where 2 | 3 | import StdLib 4 | import System.Console.ANSI (Color (..)) 5 | import Table 6 | import Test.Hspec 7 | import Test.Hspec.Golden (defaultGolden) 8 | 9 | spec :: Spec 10 | spec = do 11 | let testCases = 12 | [ [ [("h", "a"), ("g", "foo")], 13 | [("h", "b"), ("g", "bar")] 14 | ], 15 | [ [("longer-1", "a"), ("longer-2", "foo")], 16 | [("longer-1", "b"), ("longer-2", "bar")] 17 | ], 18 | [ [("h", "longer-value"), ("g", "a")], 19 | [("h", "b"), ("g", "also-very-long")] 20 | ], 21 | [], 22 | [ [("h", "h1"), ("g", "g1")], 23 | [("h", "h2")] 24 | ], 25 | [ [("h", "h1"), ("g", "g1")], 26 | [("g", "g2")] 27 | ], 28 | [ [("h", "h1"), ("g", "g1"), ("i", "i1")], 29 | [("h", "h2"), ("i", "i2")], 30 | [("g", "g3"), ("h", "h3"), ("i", "i3")] 31 | ], 32 | [ [("h", "h1")], 33 | [("h", "h2"), ("g", "g2")] 34 | ] 35 | ] 36 | forM_ (zip [1 :: Int ..] testCases) $ \(i, testCase) -> do 37 | it ("renders table-" <> show i) $ do 38 | defaultGolden ("table-" <> show i) (cs $ renderTable False testCase) 39 | 40 | it "uses colors" $ do 41 | defaultGolden 42 | "table-colors" 43 | ( cs $ 44 | renderTable 45 | True 46 | [ [("h", "a"), ("g", withColor Green "foo")], 47 | [("h", "b"), ("g", withColor Yellow "longer")] 48 | ] 49 | ) 50 | -------------------------------------------------------------------------------- /src/Utils.hs: -------------------------------------------------------------------------------- 1 | module Utils 2 | ( dbg, 3 | trace, 4 | filterMapM, 5 | Port, 6 | Hostname, 7 | parseHostname, 8 | hostnameToText, 9 | which, 10 | ) 11 | where 12 | 13 | import Control.Monad (filterM) 14 | import Cradle 15 | import Data.Map (Map) 16 | import Data.Map qualified as Map 17 | import Data.Text qualified as T 18 | import Debug.Trace qualified 19 | import StdLib 20 | import System.IO (hPrint, stderr) 21 | 22 | dbg :: (Show a) => a -> IO () 23 | dbg = hPrint stderr 24 | 25 | trace :: (Show a) => a -> a 26 | trace = Debug.Trace.traceShowId 27 | 28 | filterMapM :: (Monad m, Ord k) => (k -> v -> m Bool) -> Map k v -> m (Map k v) 29 | filterMapM pred map = do 30 | new <- filterM (uncurry pred) $ Map.toList map 31 | pure $ Map.fromList new 32 | 33 | type Port = Int 34 | 35 | newtype Hostname = Hostname {hostnameToText :: Text} 36 | deriving newtype (Show, Eq, Ord) 37 | 38 | parseHostname :: Text -> Maybe Hostname 39 | parseHostname t = 40 | if t /= "" 41 | && T.all (`elem` allValid) t 42 | && (`elem` alpha) (T.head t) 43 | && (`elem` alphaNumeric) (T.last t) 44 | && not ("--" `T.isInfixOf` t) 45 | then Just $ Hostname t 46 | else Nothing 47 | where 48 | alpha = ['a' .. 'z'] <> ['A' .. 'Z'] 49 | numeric = ['0' .. '9'] 50 | alphaNumeric = alpha <> numeric 51 | allValid = alphaNumeric <> ['.', '-'] 52 | 53 | which :: FilePath -> IO (Maybe FilePath) 54 | which executable = do 55 | (exitCode, StdoutTrimmed path) <- 56 | run $ 57 | cmd "which" 58 | & addArgs [executable] 59 | & silenceStderr 60 | pure $ case exitCode of 61 | ExitSuccess -> Just $ cs path 62 | ExitFailure _ -> Nothing 63 | -------------------------------------------------------------------------------- /src/Run.hs: -------------------------------------------------------------------------------- 1 | module Run where 2 | 3 | import Commands 4 | import Commands.Up (up) 5 | import Context (Context) 6 | import Context.Production qualified 7 | import Context.Utils (info) 8 | import Control.Exception qualified 9 | import Control.Exception.Safe (SomeException, fromException) 10 | import Data.Text hiding (elem) 11 | import Options 12 | import Options.Applicative (execParserPure, handleParseResult, prefs, showHelpOnError) 13 | import StdLib 14 | import System.Environment (getArgs) 15 | 16 | runInProduction :: IO () 17 | runInProduction = do 18 | args <- getArgs <&> fmap cs 19 | Context.Production.withContext $ \ctx -> do 20 | run ctx args >>= exitWith 21 | 22 | run :: Context -> [Text] -> IO ExitCode 23 | run ctx args = 24 | handleExceptions ctx $ do 25 | (Options opts) <- handleParseResult $ execParserPure (prefs showHelpOnError) parserInfo (cs <$> args) 26 | case opts of 27 | List -> list ctx 28 | Up verbosity vmNames -> up ctx verbosity vmNames 29 | Down vmNames -> down ctx vmNames 30 | Ssh vmName command -> ssh ctx vmName (Data.Text.unwords command) 31 | Status vmNames -> status ctx vmNames 32 | Ip vmName -> ip ctx vmName 33 | Tap removeFlag dryRunFlag -> tap ctx removeFlag dryRunFlag 34 | pure ExitSuccess 35 | 36 | handleExceptions :: Context -> IO ExitCode -> IO ExitCode 37 | handleExceptions ctx action = do 38 | -- handle all -- including async -- exceptions 39 | result <- Control.Exception.try action 40 | case result of 41 | Right exitCode -> pure exitCode 42 | Left (e :: SomeException) -> do 43 | case fromException e of 44 | Just (e :: ExitCode) -> pure e 45 | Nothing -> do 46 | info ctx (cs $ show e) 47 | pure (ExitFailure 1) 48 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: nixos-compose 2 | executables: 3 | nixos-compose: 4 | source-dirs: src 5 | main: Main.hs 6 | 7 | tests: 8 | spec: 9 | source-dirs: [spec, src] 10 | main: Spec.hs 11 | dependencies: 12 | - hspec 13 | - hspec-discover 14 | - hspec-golden 15 | - mockery 16 | - silently 17 | - temporary 18 | 19 | ghc-options: 20 | - -O0 21 | - -threaded 22 | - -Weverything 23 | - -Wno-implicit-prelude 24 | - -Wno-missing-export-lists 25 | - -Wno-missing-import-lists 26 | - -Wno-missing-kind-signatures 27 | - -Wno-missing-local-signatures 28 | - -Wno-missing-safe-haskell-mode 29 | - -Wno-monomorphism-restriction 30 | - -Wno-name-shadowing 31 | - -Wno-partial-fields 32 | - -Wno-prepositive-qualified-module 33 | - -Wno-unsafe 34 | - -Wno-unused-packages 35 | 36 | default-extensions: 37 | - DeriveAnyClass 38 | - DeriveGeneric 39 | - DerivingStrategies 40 | - DuplicateRecordFields 41 | - GeneralizedNewtypeDeriving 42 | - ImportQualifiedPost 43 | - InstanceSigs 44 | - LambdaCase 45 | - NamedFieldPuns 46 | - NumericUnderscores 47 | - OverloadedLabels 48 | - OverloadedStrings 49 | - PackageImports 50 | - QuasiQuotes 51 | - RankNTypes 52 | - ScopedTypeVariables 53 | - TupleSections 54 | - TypeSynonymInstances 55 | - ViewPatterns 56 | 57 | dependencies: 58 | - aeson 59 | - ansi-terminal 60 | - base 61 | - bytestring 62 | - containers 63 | - cradle 64 | - directory 65 | - filelock 66 | - filepath 67 | - generic-lens 68 | - interpolate 69 | - ip 70 | - ki 71 | - lens 72 | - optparse-applicative 73 | - port-utils 74 | - process 75 | - safe-exceptions 76 | - string-conversions 77 | - strip-ansi-escape 78 | - text 79 | - unix 80 | -------------------------------------------------------------------------------- /src/SafeCreatePipe.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# OPTIONS_GHC -Wno-unused-imports #-} 3 | 4 | module SafeCreatePipe (safeCreatePipe) where 5 | 6 | import Foreign (Ptr, Storable (..), allocaArray) 7 | import Foreign.C (CInt (..), throwErrnoIfMinus1_) 8 | import System.IO (Handle) 9 | import System.Posix.IO (FdOption (CloseOnExec), createPipe, fdToHandle, setFdOption) 10 | import System.Posix.Types (Fd (..)) 11 | import Prelude hiding (getContents, length) 12 | 13 | -- | Creates a pipe, while preventing child processes from inheriting the file descriptors. 14 | -- (At least trying to, see the darwin comment below.) 15 | safeCreatePipe :: IO (Handle, Handle) 16 | 17 | #ifdef linux_HOST_OSbomm 18 | 19 | safeCreatePipe = do 20 | (readfd, writefd) <- safeCreatePipeFd 21 | readh <- fdToHandle readfd 22 | writeh <- fdToHandle writefd 23 | return (readh, writeh) 24 | 25 | -- O_CLOEXEC from fcntl.h. See `man 2 open` and `man 2 pipe`. 26 | oCLOEXEC :: CInt 27 | oCLOEXEC = 524288 28 | 29 | safeCreatePipeFd :: IO (Fd, Fd) 30 | safeCreatePipeFd = 31 | allocaArray 2 $ \p_fd -> do 32 | throwErrnoIfMinus1_ "safeCreatePipe" (c_pipe2 p_fd oCLOEXEC) 33 | rfd <- Fd <$> peekElemOff p_fd 0 34 | wfd <- Fd <$> peekElemOff p_fd 1 35 | return (rfd, wfd) 36 | 37 | foreign import ccall unsafe "pipe2" 38 | c_pipe2 :: Ptr CInt -> CInt -> IO CInt 39 | 40 | #else 41 | 42 | -- On darwin there is no `pipe2`, so we use `fcntl` to set `CLOEXEC` after 43 | -- creating the file descriptors. This is not thread-safe though, but it's the 44 | -- best we can do AFAIK. 45 | 46 | safeCreatePipe = do 47 | (readEnd, writeEnd) <- System.Posix.IO.createPipe 48 | setFdOption readEnd CloseOnExec True 49 | setFdOption writeEnd CloseOnExec True 50 | readEnd <- fdToHandle readEnd 51 | writeEnd <- fdToHandle writeEnd 52 | pure (readEnd, writeEnd) 53 | 54 | #endif 55 | -------------------------------------------------------------------------------- /src/Context.hs: -------------------------------------------------------------------------------- 1 | module Context where 2 | 3 | import Control.Concurrent (MVar, modifyMVar_) 4 | import Cradle qualified 5 | import Data.Map (Map) 6 | import Data.Map qualified as Map 7 | import Logger 8 | import Net.IPv4 (IPv4) 9 | import Options (VmName) 10 | import StdLib 11 | import System.IO 12 | import System.Process 13 | import Utils (Hostname, Port) 14 | 15 | data TestState = TestState 16 | { registeredProcesses :: Map ProcessType ProcessHandle, 17 | vmHostEntries :: Map (VmName, Hostname) IPv4 18 | } 19 | deriving stock (Generic) 20 | 21 | data Context = Context 22 | { testState :: Maybe (MVar TestState), 23 | stdin :: Handle, 24 | workingDir :: FilePath, 25 | storageDir :: FilePath, 26 | nixVms :: NixVms, 27 | logger :: Logger 28 | } 29 | deriving stock (Generic) 30 | 31 | data ProcessType 32 | = VdeSwitch 33 | | Vm VmName 34 | deriving stock (Show, Eq, Ord) 35 | 36 | updateTestState :: Context -> (TestState -> IO TestState) -> IO () 37 | updateTestState ctx update = case ctx ^. #testState of 38 | Nothing -> pure () 39 | Just testState -> modifyMVar_ testState update 40 | 41 | registerProcess :: Context -> ProcessType -> ProcessHandle -> IO () 42 | registerProcess ctx typ handle = 43 | updateTestState ctx $ pure . (#registeredProcesses %~ Map.insert typ handle) 44 | 45 | data NixVms = NixVms 46 | { listVms :: Context -> IO [VmName], 47 | buildVmScript :: Context -> Maybe Handle -> VmName -> IPv4 -> IO (FilePath, Port), 48 | runVm :: Context -> Handle -> VmName -> FilePath -> IO ProcessHandle, 49 | sshIntoVm :: SshIntoVm, 50 | updateVmHostsEntry :: Context -> VmName -> Port -> Hostname -> IPv4 -> IO () 51 | } 52 | deriving stock (Generic) 53 | 54 | -- wrapper type to make `generic-lens` work 55 | newtype SshIntoVm = SshIntoVm 56 | { runSshIntoVm :: forall o. (Cradle.Output o) => Context -> VmName -> Port -> Text -> IO o 57 | } 58 | -------------------------------------------------------------------------------- /spec/LoggerSpec.hs: -------------------------------------------------------------------------------- 1 | module LoggerSpec where 2 | 3 | import Control.Concurrent (threadDelay) 4 | import Control.Monad (replicateM_) 5 | import Data.Text.IO qualified as T 6 | import Logger 7 | import System.IO qualified 8 | import System.IO.Silently (hCapture) 9 | import Test.Hspec 10 | import Test.Hspec.Golden (defaultGolden) 11 | import TestUtils () 12 | 13 | spec :: Spec 14 | spec = do 15 | describe "ANSILogger" $ do 16 | it "allows pushing log lines to stdout" $ do 17 | -- If the golden test fails, verify manually that the output looks good 18 | -- by changing this to True and running this test *outside* of ghcid 19 | let manualTesting = False 20 | let runTest :: IO () -> IO () 21 | runTest delay = do 22 | withANSILogger $ \logger -> do 23 | mapM_ 24 | (>> delay) 25 | [ setPhase logger "a" "building", 26 | setPhase logger "b" "building", 27 | setPhase logger "c" "building", 28 | pushLog logger System.IO.stderr "log line", 29 | setPhase logger "b" "starting", 30 | pushLog logger System.IO.stderr "log line", 31 | setPhase logger "a" "starting", 32 | pushLog logger System.IO.stderr "this is a very long log line", 33 | clearPhase logger "a", 34 | setPhase logger "b" "starting", 35 | pushLog logger System.IO.stderr "log line", 36 | clearPhase logger "b", 37 | pushLog logger System.IO.stderr "log line" 38 | ] 39 | if manualTesting 40 | then do 41 | replicateM_ 3 $ T.putStrLn "" 42 | runTest $ threadDelay 1_000_000 43 | replicateM_ 3 $ T.putStrLn "" 44 | pendingWith "Running ANSI logger tests manually" 45 | error "unreachable" 46 | else do 47 | (output, _) <- hCapture [System.IO.stdout, System.IO.stderr] $ do 48 | runTest $ pure () 49 | pure $ 50 | defaultGolden "ansi-logger" $ 51 | unlines 52 | [ "This asserts stdout and stderr of the ansi logger", 53 | "If these change it's best that you manually confirm that the logger still works well in a real terminal", 54 | "", 55 | output 56 | ] 57 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # `nixos-compose` 2 | 3 | `nixos-compose` makes it easy to spin up vms locally based on nixos configurations from flake files. 4 | 5 | ## simple example 6 | 7 | In a directory with a flake file that contains a nixos configuration `server`, you can do: 8 | 9 | ``` bash 10 | $ nix flake show 11 | git+file:///home/shahn/garnix/nixos-compose 12 | └───nixosConfigurations 13 | └───server: NixOS configuration 14 | $ nixos-compose up server 15 | # wait for vm to boot up 16 | $ nixos-compose ssh server 17 | [vmuser@server:~]$ journalctl 18 | [vmuser@server:~]$ exit 19 | $ nixos-compose down 20 | ``` 21 | 22 | ## installation 23 | 24 | `nixos-compose` is available through the flake at `github:garnix-io/nixos-compose`. 25 | 26 | ## features 27 | 28 | ### ssh access 29 | 30 | `nixos-compose` injects some configuration into the nixos configs to enable ssh and add a `vmuser`. 31 | This allows you to ssh into vms without any manual configuration. 32 | 33 | ### cross-vm networking 34 | 35 | `nixos-compose` creates a virtual network switch and connects the vms to it. 36 | It also injects entries into the `/etc/hosts` file in the vms so that they can access each other by the names of the nixos configurations in the flake file. 37 | So for example, if you spin up two machines `a` and `b`, they can talk to each other by the domain names `a` and `b`. 38 | Without any manual configuration on your part. 39 | 40 | ### tap 41 | 42 | `nixos-compose tap` sets up a virtual network device on the host system that allows you to connect to the vms through their ip addresses. 43 | (`nixos-compose ip $SERVER` will show you the vm's ip address.) 44 | 45 | 46 | ## `nixos-compose --help` 47 | 48 | ``` 49 | Usage: nixos-compose COMMAND 50 | 51 | Available options: 52 | -h,--help Show this help text 53 | --version Show version (405f14a) and exit 54 | 55 | Available commands: 56 | up Start development vms 57 | down Stop running vms 58 | ssh `ssh` into a running vm 59 | status Show the status of running vms 60 | list List all configured vms 61 | ip Print the ip address of a vm (in the virtual network) 62 | tap Set up a tap device, to allow network access to vms 63 | from the host (uses `sudo`) 64 | ``` 65 | 66 | ## feedback 67 | 68 | Feedback (bug reports, feature requests, etc.) very much appreciated at [https://github.com/garnix-io/nixos-compose/issues](https://github.com/garnix-io/nixos-compose/issues). 69 | -------------------------------------------------------------------------------- /src/Table.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | 3 | module Table (StyledText (..), withColor, renderTable) where 4 | 5 | import Control.Monad (join) 6 | import Data.Containers.ListUtils (nubOrd) 7 | import Data.String (IsString (..)) 8 | import Data.String.Conversions (ConvertibleStrings (..)) 9 | import Data.Text qualified as T 10 | import StdLib 11 | import System.Console.ANSI 12 | 13 | data StyledText = StyledText 14 | { color :: Maybe Color, 15 | unstyledText :: Text 16 | } 17 | deriving stock (Generic) 18 | 19 | instance ConvertibleStrings Text StyledText where 20 | convertString = StyledText Nothing 21 | 22 | instance IsString StyledText where 23 | fromString = StyledText Nothing . cs 24 | 25 | withColor :: Color -> Text -> StyledText 26 | withColor color = StyledText (Just color) 27 | 28 | renderStyledText :: Bool -> StyledText -> Text 29 | renderStyledText useColor t = case (useColor, color t) of 30 | (True, Just color) -> 31 | cs (setSGRCode [SetColor Foreground Vivid color]) 32 | <> unstyledText t 33 | <> cs (setSGRCode [Reset]) 34 | _ -> unstyledText t 35 | 36 | renderTable :: Bool -> [[(Text, StyledText)]] -> Text 37 | renderTable useColors = \case 38 | [] -> "" 39 | rows -> 40 | let ansi codes t = if useColors then codes <> t <> reset else t 41 | headers = nubOrd $ join $ map (map fst) rows 42 | columnWidths = flip map headers $ \header -> 43 | max (T.length header) (maximum (map (maybe 0 (T.length . unstyledText) . lookup header) rows)) 44 | renderLines start char sep end = 45 | ansi 46 | lineColor 47 | ( start 48 | <> T.intercalate sep (map (\n -> T.replicate (n + 2) char) columnWidths) 49 | <> end 50 | ) 51 | renderRow (zip columnWidths -> row) = 52 | ansi lineColor "│" 53 | <> " " 54 | <> T.intercalate 55 | (" " <> ansi lineColor "│" <> " ") 56 | ( map 57 | ( \(width, t) -> 58 | renderStyledText useColors (t & #unstyledText %~ pad width) 59 | ) 60 | row 61 | ) 62 | <> ansi lineColor " │" 63 | topLine = [renderLines "┌" "─" "┬" "┐"] 64 | header = [renderRow $ map cs headers] 65 | divider = [renderLines "├" "─" "┼" "┤"] 66 | body = 67 | flip map rows $ \row -> 68 | renderRow $ flip map headers $ \header -> 69 | fromMaybe "" (lookup header row) 70 | bottomLine = [renderLines "└" "─" "┴" "┘"] 71 | in T.unlines $ 72 | topLine 73 | <> header 74 | <> divider 75 | <> body 76 | <> bottomLine 77 | 78 | lineColor :: Text 79 | lineColor = cs (setSGRCode [SetColor Foreground Dull Blue]) 80 | 81 | reset :: Text 82 | reset = cs $ setSGRCode [Reset] 83 | 84 | pad :: Int -> Text -> Text 85 | pad n t = t <> T.replicate (n - T.length t) " " 86 | -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "cradle": { 4 | "inputs": { 5 | "flake-utils": [ 6 | "flake-utils" 7 | ], 8 | "nixpkgs": [ 9 | "nixpkgs" 10 | ] 11 | }, 12 | "locked": { 13 | "lastModified": 1717164253, 14 | "narHash": "sha256-OiQnrWO78bsM23Gt7rWEoGh0Zeg5CDv+OiraKskjgd8=", 15 | "owner": "garnix-io", 16 | "repo": "cradle", 17 | "rev": "dbad639f4ba132f336588b85089cd1dc0acad4ea", 18 | "type": "github" 19 | }, 20 | "original": { 21 | "owner": "garnix-io", 22 | "repo": "cradle", 23 | "type": "github" 24 | } 25 | }, 26 | "flake-utils": { 27 | "inputs": { 28 | "systems": "systems" 29 | }, 30 | "locked": { 31 | "lastModified": 1731533236, 32 | "narHash": "sha256-l0KFg5HjrsfsO/JpG+r7fRrqm12kzFHyUHqHCVpMMbI=", 33 | "owner": "numtide", 34 | "repo": "flake-utils", 35 | "rev": "11707dc2f618dd54ca8739b309ec4fc024de578b", 36 | "type": "github" 37 | }, 38 | "original": { 39 | "owner": "numtide", 40 | "repo": "flake-utils", 41 | "type": "github" 42 | } 43 | }, 44 | "garnix-lib": { 45 | "inputs": { 46 | "nixpkgs": [ 47 | "nixpkgs" 48 | ] 49 | }, 50 | "locked": { 51 | "lastModified": 1746387091, 52 | "narHash": "sha256-YivN7BL4XkZIJpUTdDJRQpYX/JORVdbZTQbSnULgRnY=", 53 | "owner": "garnix-io", 54 | "repo": "garnix-lib", 55 | "rev": "4cc103317aef34dd99617ed9ff12c44d659d86d0", 56 | "type": "github" 57 | }, 58 | "original": { 59 | "owner": "garnix-io", 60 | "repo": "garnix-lib", 61 | "type": "github" 62 | } 63 | }, 64 | "nixpkgs": { 65 | "locked": { 66 | "lastModified": 1753345091, 67 | "narHash": "sha256-CdX2Rtvp5I8HGu9swBmYuq+ILwRxpXdJwlpg8jvN4tU=", 68 | "owner": "NixOS", 69 | "repo": "nixpkgs", 70 | "rev": "3ff0e34b1383648053bba8ed03f201d3466f90c9", 71 | "type": "github" 72 | }, 73 | "original": { 74 | "owner": "NixOS", 75 | "ref": "nixos-25.05", 76 | "repo": "nixpkgs", 77 | "type": "github" 78 | } 79 | }, 80 | "root": { 81 | "inputs": { 82 | "cradle": "cradle", 83 | "flake-utils": "flake-utils", 84 | "garnix-lib": "garnix-lib", 85 | "nixpkgs": "nixpkgs" 86 | } 87 | }, 88 | "systems": { 89 | "locked": { 90 | "lastModified": 1681028828, 91 | "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", 92 | "owner": "nix-systems", 93 | "repo": "default", 94 | "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", 95 | "type": "github" 96 | }, 97 | "original": { 98 | "owner": "nix-systems", 99 | "repo": "default", 100 | "type": "github" 101 | } 102 | } 103 | }, 104 | "root": "root", 105 | "version": 7 106 | } 107 | -------------------------------------------------------------------------------- /src/Options.hs: -------------------------------------------------------------------------------- 1 | module Options 2 | ( parserInfo, 3 | Options (..), 4 | Verbosity (..), 5 | RemoveFlag (..), 6 | DryRunFlag (..), 7 | Command (..), 8 | AllOrSomeVms (..), 9 | VmName (..), 10 | ) 11 | where 12 | 13 | import Data.Aeson (FromJSONKey, ToJSONKey) 14 | import Data.List.NonEmpty (NonEmpty (..)) 15 | import Data.Text 16 | import Options.Applicative 17 | import StdLib 18 | import Version qualified 19 | 20 | parserInfo :: ParserInfo Options 21 | parserInfo = 22 | info parser mempty 23 | 24 | class Parseable a where 25 | parser :: Parser a 26 | 27 | newtype Options = Options Command 28 | deriving stock (Show) 29 | 30 | instance Parseable Options where 31 | parser = 32 | (Options <$> parser) 33 | <**> helper 34 | <**> version 35 | 36 | version :: Parser (a -> a) 37 | version = 38 | infoOption 39 | (cs Version.version) 40 | ( long "version" 41 | <> help ("Show version (" <> cs Version.version <> ") and exit") 42 | <> hidden 43 | ) 44 | 45 | data Command 46 | = List 47 | | Up {verbosity :: Verbosity, vms :: AllOrSomeVms} 48 | | Ssh {vmName :: VmName, sshCommand :: [Text]} 49 | | Status {vmNames :: [VmName]} 50 | | Down {vms :: AllOrSomeVms} 51 | | Ip {vmName :: VmName} 52 | | Tap {remove :: RemoveFlag, dryRun :: DryRunFlag} 53 | deriving stock (Show, Generic) 54 | 55 | instance Parseable Command where 56 | parser = 57 | hsubparser 58 | ( command 59 | "up" 60 | ( info 61 | (Up <$> parser <*> parser) 62 | (fullDesc <> progDesc "Start development vms") 63 | ) 64 | <> command 65 | "down" 66 | ( info 67 | (Down <$> parser) 68 | (progDesc "Stop running vms") 69 | ) 70 | <> command 71 | "ssh" 72 | ( info 73 | (Ssh <$> parser <*> many (argument str (metavar "SSH_COMMAND"))) 74 | (fullDesc <> progDesc "`ssh` into a running vm") 75 | ) 76 | <> command 77 | "status" 78 | ( info 79 | (Status <$> many parser) 80 | (fullDesc <> progDesc "Show the status of running vms") 81 | ) 82 | <> command 83 | "list" 84 | ( info 85 | (pure List) 86 | (fullDesc <> progDesc "List all configured vms") 87 | ) 88 | <> command 89 | "ip" 90 | ( info 91 | (Ip <$> parser) 92 | (progDesc "Print the ip address of a vm (in the virtual network)") 93 | ) 94 | <> command 95 | "tap" 96 | ( info 97 | (Tap <$> parser <*> parser) 98 | (progDesc "Set up a tap device, to allow network access to vms from the host (uses `sudo`)") 99 | ) 100 | ) 101 | 102 | data Verbosity 103 | = DefaultVerbosity 104 | | Verbose 105 | deriving stock (Show) 106 | 107 | instance Parseable Verbosity where 108 | parser = 109 | flag 110 | DefaultVerbosity 111 | Verbose 112 | ( long "verbose" 113 | <> short 'v' 114 | <> help "increase verbosity" 115 | ) 116 | 117 | data RemoveFlag 118 | = NoRemove 119 | | Remove 120 | deriving stock (Show) 121 | 122 | instance Parseable RemoveFlag where 123 | parser = flag NoRemove Remove (long "remove" <> help "Remove the tap device") 124 | 125 | data DryRunFlag 126 | = NoDryRun 127 | | DryRun 128 | deriving stock (Show) 129 | 130 | instance Parseable DryRunFlag where 131 | parser = flag NoDryRun DryRun (long "dry-run" <> help "Just print what would be done") 132 | 133 | data AllOrSomeVms 134 | = All 135 | | Some (NonEmpty VmName) 136 | deriving stock (Show, Generic) 137 | 138 | instance Parseable AllOrSomeVms where 139 | parser = 140 | many (parser :: Parser VmName) 141 | <&> ( \case 142 | [] -> All 143 | a : r -> Some (a :| r) 144 | ) 145 | 146 | newtype VmName = VmName {vmNameToText :: Text} 147 | deriving stock (Eq, Show, Ord) 148 | deriving newtype (ToJSONKey, FromJSONKey) 149 | 150 | instance Parseable VmName where 151 | parser = VmName <$> argument str (metavar "VM_NAME") 152 | -------------------------------------------------------------------------------- /nixos-compose.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.37.0. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | 7 | name: nixos-compose 8 | version: 0.0.0 9 | build-type: Simple 10 | 11 | executable nixos-compose 12 | main-is: Main.hs 13 | other-modules: 14 | Commands 15 | Commands.Up 16 | Context 17 | Context.Production 18 | Context.Utils 19 | Logger 20 | Logging 21 | NixVms 22 | Options 23 | Run 24 | SafeCreatePipe 25 | State 26 | StdLib 27 | Table 28 | Utils 29 | Vde 30 | Version 31 | Paths_nixos_compose 32 | hs-source-dirs: 33 | src 34 | default-extensions: 35 | DeriveAnyClass 36 | DeriveGeneric 37 | DerivingStrategies 38 | DuplicateRecordFields 39 | GeneralizedNewtypeDeriving 40 | ImportQualifiedPost 41 | InstanceSigs 42 | LambdaCase 43 | NamedFieldPuns 44 | NumericUnderscores 45 | OverloadedLabels 46 | OverloadedStrings 47 | PackageImports 48 | QuasiQuotes 49 | RankNTypes 50 | ScopedTypeVariables 51 | TupleSections 52 | TypeSynonymInstances 53 | ViewPatterns 54 | ghc-options: -O0 -threaded -Weverything -Wno-implicit-prelude -Wno-missing-export-lists -Wno-missing-import-lists -Wno-missing-kind-signatures -Wno-missing-local-signatures -Wno-missing-safe-haskell-mode -Wno-monomorphism-restriction -Wno-name-shadowing -Wno-partial-fields -Wno-prepositive-qualified-module -Wno-unsafe -Wno-unused-packages 55 | build-depends: 56 | aeson 57 | , ansi-terminal 58 | , base 59 | , bytestring 60 | , containers 61 | , cradle 62 | , directory 63 | , filelock 64 | , filepath 65 | , generic-lens 66 | , interpolate 67 | , ip 68 | , ki 69 | , lens 70 | , optparse-applicative 71 | , port-utils 72 | , process 73 | , safe-exceptions 74 | , string-conversions 75 | , strip-ansi-escape 76 | , text 77 | , unix 78 | default-language: Haskell2010 79 | 80 | test-suite spec 81 | type: exitcode-stdio-1.0 82 | main-is: Spec.hs 83 | other-modules: 84 | CliSpec 85 | IntegrationSpec 86 | LoggerSpec 87 | LoggingSpec 88 | NetworkingSpec 89 | SpecHook 90 | TableSpec 91 | TapSpec 92 | TestUtils 93 | UpSpec 94 | UtilsSpec 95 | Commands 96 | Commands.Up 97 | Context 98 | Context.Production 99 | Context.Utils 100 | Logger 101 | Logging 102 | Main 103 | NixVms 104 | Options 105 | Run 106 | SafeCreatePipe 107 | State 108 | StdLib 109 | Table 110 | Utils 111 | Vde 112 | Version 113 | Paths_nixos_compose 114 | hs-source-dirs: 115 | spec 116 | src 117 | default-extensions: 118 | DeriveAnyClass 119 | DeriveGeneric 120 | DerivingStrategies 121 | DuplicateRecordFields 122 | GeneralizedNewtypeDeriving 123 | ImportQualifiedPost 124 | InstanceSigs 125 | LambdaCase 126 | NamedFieldPuns 127 | NumericUnderscores 128 | OverloadedLabels 129 | OverloadedStrings 130 | PackageImports 131 | QuasiQuotes 132 | RankNTypes 133 | ScopedTypeVariables 134 | TupleSections 135 | TypeSynonymInstances 136 | ViewPatterns 137 | ghc-options: -O0 -threaded -Weverything -Wno-implicit-prelude -Wno-missing-export-lists -Wno-missing-import-lists -Wno-missing-kind-signatures -Wno-missing-local-signatures -Wno-missing-safe-haskell-mode -Wno-monomorphism-restriction -Wno-name-shadowing -Wno-partial-fields -Wno-prepositive-qualified-module -Wno-unsafe -Wno-unused-packages 138 | build-depends: 139 | aeson 140 | , ansi-terminal 141 | , base 142 | , bytestring 143 | , containers 144 | , cradle 145 | , directory 146 | , filelock 147 | , filepath 148 | , generic-lens 149 | , hspec 150 | , hspec-discover 151 | , hspec-golden 152 | , interpolate 153 | , ip 154 | , ki 155 | , lens 156 | , mockery 157 | , optparse-applicative 158 | , port-utils 159 | , process 160 | , safe-exceptions 161 | , silently 162 | , string-conversions 163 | , strip-ansi-escape 164 | , temporary 165 | , text 166 | , unix 167 | default-language: Haskell2010 168 | -------------------------------------------------------------------------------- /src/Logger.hs: -------------------------------------------------------------------------------- 1 | module Logger where 2 | 3 | import Control.Concurrent 4 | import Control.Exception (bracket) 5 | import Control.Exception.Safe (finally) 6 | import Data.Map qualified as Map 7 | import Data.Text qualified as T 8 | import Data.Text.IO qualified as T 9 | import GHC.IO.Handle 10 | import Options 11 | import StdLib 12 | import System.Console.ANSI qualified as ANSI 13 | import System.IO qualified 14 | 15 | data Logger = Logger 16 | { pushLog :: Handle -> Text -> IO (), 17 | setPhase :: VmName -> Text -> IO (), 18 | clearPhase :: VmName -> IO () 19 | } 20 | deriving stock (Generic) 21 | 22 | withAutoLogger :: (Logger -> IO ()) -> IO () 23 | withAutoLogger action = do 24 | ansiSupport <- and <$> mapM ANSI.hNowSupportsANSI [System.IO.stdout, System.IO.stderr] 25 | if ansiSupport then withANSILogger action else action =<< mkSimpleLogger 26 | 27 | -- * ANSI logger 28 | 29 | withNoBuffering :: Handle -> IO a -> IO a 30 | withNoBuffering handle action = 31 | bracket 32 | (hGetBuffering handle <* hSetBuffering handle NoBuffering) 33 | (hSetBuffering handle) 34 | $ \_ -> do 35 | action 36 | 37 | withANSILogger :: (Logger -> IO a) -> IO a 38 | withANSILogger action = 39 | withNoBuffering System.IO.stdout $ do 40 | withNoBuffering System.IO.stderr $ do 41 | phases <- newMVar mempty 42 | let renderPhaseLine :: VmName -> Text -> Text 43 | renderPhaseLine vmName phase = 44 | cs (ANSI.setSGRCode [ANSI.SetConsoleIntensity ANSI.BoldIntensity]) 45 | <> vmNameToText vmName 46 | <> cs (ANSI.setSGRCode [ANSI.SetConsoleIntensity ANSI.NormalIntensity]) 47 | <> ": " 48 | <> phase 49 | <> cs ANSI.clearFromCursorToLineEndCode 50 | let renderPhases :: Map.Map VmName Text -> Text 51 | renderPhases phases = do 52 | phases 53 | & Map.toList 54 | & fmap (uncurry renderPhaseLine) 55 | & T.unlines 56 | let updatePhases :: (Map.Map VmName Text -> Map.Map VmName Text) -> IO () 57 | updatePhases updater = do 58 | modifyMVar_ phases $ \previousPhases -> do 59 | let newPhases = updater previousPhases 60 | let prevCount = length previousPhases 61 | let newCount = length newPhases 62 | if prevCount > newCount 63 | then do 64 | T.hPutStr System.IO.stderr $ 65 | cs (ANSI.scrollPageDownCode (prevCount - newCount)) 66 | <> cs (ANSI.cursorUpLineCode newCount) 67 | <> renderPhases newPhases 68 | <> cs ANSI.clearFromCursorToLineEndCode 69 | else do 70 | T.hPutStr System.IO.stderr $ 71 | cs (ANSI.cursorUpLineCode prevCount) 72 | <> renderPhases newPhases 73 | pure newPhases 74 | let logger = 75 | Logger 76 | { pushLog = \handle text -> do 77 | modifyMVar_ phases $ \p -> do 78 | ANSI.hCursorUpLine System.IO.stderr $ length p 79 | T.hPutStr handle text 80 | ANSI.hClearFromCursorToLineEnd System.IO.stderr 81 | T.hPutStrLn handle "" 82 | T.hPutStr System.IO.stderr $ renderPhases p 83 | pure p, 84 | setPhase = \vmName phase -> do 85 | updatePhases $ Map.insert vmName phase, 86 | clearPhase = \vmName -> do 87 | updatePhases $ Map.delete vmName 88 | } 89 | let clearAllPhases = updatePhases $ const mempty 90 | action logger `finally` clearAllPhases 91 | 92 | -- * Simple logger 93 | 94 | mkSimpleLogger :: IO Logger 95 | mkSimpleLogger = do 96 | currentPhases <- newMVar mempty 97 | let logDone :: VmName -> Map.Map VmName Text -> IO () 98 | logDone vmName phases = do 99 | case Map.lookup vmName phases of 100 | Nothing -> pure () 101 | Just phase -> T.hPutStrLn System.IO.stderr $ vmNameToText vmName <> ": done " <> phase 102 | pure $ 103 | Logger 104 | { setPhase = \vmName phase -> do 105 | modifyMVar_ currentPhases $ \phases -> do 106 | logDone vmName phases 107 | T.hPutStrLn System.IO.stderr $ vmNameToText vmName <> ": " <> phase <> "..." 108 | pure $ Map.insert vmName phase phases, 109 | clearPhase = \vmName -> do 110 | modifyMVar_ currentPhases $ \phases -> do 111 | logDone vmName phases 112 | pure $ Map.delete vmName phases, 113 | pushLog = T.hPutStrLn 114 | } 115 | -------------------------------------------------------------------------------- /src/Commands.hs: -------------------------------------------------------------------------------- 1 | module Commands 2 | ( list, 3 | down, 4 | ssh, 5 | status, 6 | Commands.ip, 7 | tap, 8 | ) 9 | where 10 | 11 | import Context 12 | import Context.Utils 13 | import Control.Exception.Safe (throwIO) 14 | import Cradle 15 | import Data.Containers.ListUtils (nubOrd) 16 | import Data.List.NonEmpty (NonEmpty (..)) 17 | import Data.Map qualified as Map 18 | import Data.Maybe (catMaybes, isJust) 19 | import Data.Text qualified as T 20 | import Logging 21 | import Net.IPv4 qualified as IPv4 22 | import Options (AllOrSomeVms (..), DryRunFlag, RemoveFlag (..), VmName (..)) 23 | import State 24 | import StdLib 25 | import System.Console.ANSI qualified as ANSI 26 | import System.IO qualified 27 | import System.Posix (sigKILL, signalProcess) 28 | import Table (renderTable) 29 | import Vde qualified 30 | 31 | list :: Context -> IO () 32 | list ctx = do 33 | vms <- listVms (nixVms ctx) ctx 34 | output ctx $ case vms of 35 | [] -> "no vms configured" 36 | vms -> "configured vms:\n" <> T.intercalate "\n" (map ((" - " <>) . vmNameToText) vms) 37 | 38 | down :: Context -> AllOrSomeVms -> IO () 39 | down ctx vmNames = do 40 | toStop <- case vmNames of 41 | Some vmNames -> pure vmNames 42 | All -> do 43 | all <- listRunningVms ctx 44 | case Map.keys all of 45 | [] -> do 46 | info ctx "no vms running, nothing to do" 47 | exitSuccess 48 | a : r -> pure $ a :| r 49 | state <- readState ctx 50 | forM_ toStop $ \vmName -> do 51 | case Map.lookup vmName (state ^. #vms) of 52 | Nothing -> output ctx $ vmNameToText vmName <> " is not running, nothing to do" 53 | Just vmState -> case vmState of 54 | Building {} -> abort ctx $ vmNameToText vmName <> ": building, cannot stop a building vm" 55 | Booting {} -> abort ctx $ vmNameToText vmName <> ": booting, cannot stop a booting vm" 56 | Running {pid} -> do 57 | output ctx $ "stopping " <> vmNameToText vmName 58 | signalProcess sigKILL pid 59 | removeVm ctx vmName 60 | 61 | ssh :: Context -> VmName -> Text -> IO () 62 | ssh ctx vmName command = do 63 | vmState <- State.readVmState ctx vmName 64 | case vmState of 65 | Nothing -> abort ctx $ "vm '" <> vmNameToText vmName <> "' is not running" 66 | Just vmState -> case vmState of 67 | Building {} -> do 68 | abort ctx "cannot ssh into a building vm" 69 | Booting {} -> do 70 | abort ctx "cannot ssh into a booting vm" 71 | Running {port} -> do 72 | exitCode :: ExitCode <- (ctx ^. #nixVms . #sshIntoVm . to runSshIntoVm) ctx vmName port command 73 | throwIO exitCode 74 | 75 | status :: Context -> [VmName] -> IO () 76 | status ctx args = do 77 | configuredVms <- listVms (nixVms ctx) ctx 78 | runningVms <- State.listRunningVms ctx 79 | tapRunning <- isJust <$> Vde.vde_plug2tapReadPidFile ctx 80 | let getIp vmName = 81 | if tapRunning 82 | then 83 | (^. #ip) <$> Map.lookup vmName runningVms 84 | else Nothing 85 | supportsAnsi <- ANSI.hNowSupportsANSI System.IO.stdout 86 | let listedVms = case args of 87 | [] -> nubOrd (configuredVms <> Map.keys runningVms) 88 | args -> args 89 | let vmStatus = case listedVms of 90 | [] -> "no vms configured, no vms running" 91 | vmNames -> do 92 | T.stripEnd $ 93 | renderTable supportsAnsi $ 94 | flip map vmNames $ \vmName -> 95 | [ ("name", cs $ vmNameToText vmName), 96 | ("status", vmStateToText (Map.lookup vmName runningVms)) 97 | ] 98 | <> maybe [] (\ip -> [("ip", cs (IPv4.encode ip))]) (getIp vmName) 99 | let tapStatus = if tapRunning then Just "(The tap device 'nixos-compose0' is up.)" else Nothing 100 | output ctx $ T.intercalate "\n" $ catMaybes [Just vmStatus, tapStatus] 101 | 102 | ip :: Context -> VmName -> IO () 103 | ip ctx vm = modifyState_ ctx $ \state -> do 104 | case Map.lookup vm (state ^. #vms) of 105 | Nothing -> abort ctx $ "vm not running: " <> vmNameToText vm 106 | Just vmState -> output ctx $ IPv4.encode (vmState ^. #ip) 107 | pure state 108 | 109 | tap :: Context -> RemoveFlag -> DryRunFlag -> IO () 110 | tap ctx removeFlag dryRunFlag = do 111 | case removeFlag of 112 | NoRemove -> do 113 | modifyState_ ctx $ \state -> do 114 | state <- case state ^. #vde of 115 | Just _ -> pure state 116 | Nothing -> do 117 | vdeState <- Vde.start ctx 118 | pure $ state & (#vde ?~ vdeState) 119 | Vde.setupTapDevice ctx dryRunFlag hostIp 120 | pure state 121 | Remove -> do 122 | pid <- Vde.vde_plug2tapReadPidFile ctx 123 | case pid of 124 | Nothing -> info ctx "tap device not running, nothing to do" 125 | Just pid -> Vde.stopTapDevice ctx dryRunFlag pid 126 | -------------------------------------------------------------------------------- /src/Vde.hs: -------------------------------------------------------------------------------- 1 | module Vde where 2 | 3 | import Context 4 | import Context.Utils 5 | import Control.Exception.Safe (SomeException, catch, throwIO, try) 6 | import Cradle qualified 7 | import Data.Aeson (FromJSON, ToJSON) 8 | import Data.Text qualified as T 9 | import Logging 10 | import Net.IPv4 (IPv4) 11 | import Net.IPv4 qualified as IPv4 12 | import Options 13 | import StdLib 14 | import System.Directory (createDirectoryIfMissing, doesDirectoryExist, removeDirectoryRecursive) 15 | import System.IO.Error (isDoesNotExistError) 16 | import System.Posix (sigKILL, signalProcess) 17 | import System.Process 18 | import Text.Read (readMaybe) 19 | import Utils (which) 20 | 21 | newtype VdeState = VdeState 22 | { pid :: ProcessID 23 | } 24 | deriving stock (Generic, Show, Eq) 25 | deriving anyclass (ToJSON, FromJSON) 26 | 27 | start :: Context -> IO VdeState 28 | start ctx = do 29 | ctlDir <- getVdeCtlDir ctx 30 | (stdinPipe, _) <- createPipe 31 | (_, _, _, handle) <- 32 | createProcess 33 | (System.Process.proc "vde_switch" ["--sock", ctlDir, "--dirmode", "0700", "--hub"]) 34 | { std_in = UseHandle stdinPipe -- `CreatePipe :: StdStream` doesn't work reliably 35 | } 36 | registerProcess ctx VdeSwitch handle 37 | pid <- 38 | System.Process.getPid handle 39 | >>= maybe (impossible ctx "vde_switch process has no pid") pure 40 | pure $ VdeState {pid} 41 | 42 | stop :: Context -> VdeState -> IO () 43 | stop ctx state = do 44 | _ :: Either SomeException () <- try $ signalProcess sigKILL $ state ^. #pid 45 | removeDirectoryRecursive =<< getVdeCtlDir ctx 46 | 47 | getVdeCtlDir :: Context -> IO FilePath 48 | getVdeCtlDir ctx = do 49 | let ctlDir = storageDir ctx "vde_switch.ctl" 50 | createDirectoryIfMissing True ctlDir 51 | pure ctlDir 52 | 53 | -- We have some golden tests for the issued commands (in `TapSpec`), but when 54 | -- changing the sudo process invocations, you should manually make sure that 55 | -- setting up a `tap` device still works. With e.g.: 56 | -- 57 | -- - nix shell .#default 58 | -- - nixos-compose up test-vm 59 | -- - nixos-compose tap 60 | -- - curl $(nixos-compose ip test-vm) 61 | -- - nixos-compose down test-vm 62 | setupTapDevice :: Context -> DryRunFlag -> IPv4 -> IO () 63 | setupTapDevice ctx dryRunFlag ipAddress = do 64 | tapIsRunning <- vde_plug2tapReadPidFile ctx 65 | case tapIsRunning of 66 | Just _ -> output ctx "tap device already running" 67 | Nothing -> do 68 | commands <- do 69 | vdeCtlDir <- getVdeCtlDir ctx 70 | vde_plug2tapPath <- 71 | which "vde_plug2tap" 72 | <&> fromMaybe (error "impossible: vde_plug2tap not in path") 73 | ipPath <- 74 | which "ip" 75 | <&> fromMaybe (error "impossible: ip not in path") 76 | pure 77 | [ [cs vde_plug2tapPath, "--daemon", "--pidfile", cs (vde_plug2tapPidFile ctx), "--sock", cs vdeCtlDir, "nixos-compose0"], 78 | [cs ipPath, "addr", "add", IPv4.encode ipAddress <> "/24", "dev", "nixos-compose0" :: Text], 79 | [cs ipPath, "link", "set", "nixos-compose0", "up" :: Text] 80 | ] 81 | sudo <- which "sudo" 82 | case sudo of 83 | Nothing -> do 84 | info 85 | ctx 86 | ( T.intercalate 87 | "\n" 88 | [ "`sudo` not found in the $PATH, cannot create `tap` device.", 89 | "You can run the following commands with elevated privileges to create it manually:", 90 | "" 91 | ] 92 | ) 93 | output ctx (T.intercalate "\n" $ fmap T.unwords commands) 94 | exitWith $ ExitFailure 1 95 | Just _ -> case dryRunFlag of 96 | DryRun -> do 97 | info 98 | ctx 99 | ( T.intercalate 100 | "\n" 101 | [ "Would run the following commands:", 102 | "" 103 | ] 104 | ) 105 | output ctx (T.intercalate "\n" $ fmap T.unwords commands) 106 | exitSuccess 107 | NoDryRun -> forM_ commands runWithSudo 108 | 109 | stopTapDevice :: Context -> DryRunFlag -> Pid -> IO () 110 | stopTapDevice ctx dryRunFlag pid = 111 | case dryRunFlag of 112 | NoDryRun -> runWithSudo ["kill", "-15", cs (show pid) :: Text] 113 | DryRun -> do 114 | info 115 | ctx 116 | ( T.intercalate 117 | "\n" 118 | [ "Would run the following commands:", 119 | "" 120 | ] 121 | ) 122 | output ctx (T.unwords ["kill", "-15", cs (show pid)]) 123 | exitSuccess 124 | 125 | vde_plug2tapPidFile :: Context -> FilePath 126 | vde_plug2tapPidFile ctx = do 127 | storageDir ctx "vde_plug2tap.pid" 128 | 129 | vde_plug2tapReadPidFile :: Context -> IO (Maybe Pid) 130 | vde_plug2tapReadPidFile ctx = do 131 | content <- 132 | (Just <$> readFile (vde_plug2tapPidFile ctx)) 133 | `catch` (\e -> if isDoesNotExistError e then pure Nothing else throwIO e) 134 | case content of 135 | Nothing -> pure Nothing 136 | Just content -> 137 | case readMaybe content :: Maybe Pid of 138 | Nothing -> impossible ctx ("pidFile doesn't contain number: " <> cs (show content)) 139 | Just pid -> do 140 | tapIsRunning <- doesDirectoryExist $ "/proc/" <> show (pid :: ProcessID) 141 | if tapIsRunning 142 | then pure $ Just pid 143 | else pure Nothing 144 | 145 | runWithSudo :: [Text] -> IO () 146 | runWithSudo args = 147 | Cradle.run_ $ 148 | Cradle.cmd "sudo" 149 | & Cradle.addArgs args 150 | -------------------------------------------------------------------------------- /spec/TestUtils.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | module TestUtils where 4 | 5 | import Context 6 | import Control.Concurrent (newMVar, readMVar, threadDelay) 7 | import Control.Exception.Safe (SomeException, finally, throwIO, try) 8 | import Cradle qualified 9 | import Data.Map qualified as Map 10 | import Data.Maybe (fromJust, isJust) 11 | import Data.String (IsString) 12 | import Data.String.Conversions 13 | import Data.Text qualified as T 14 | import GHC.Clock (getMonotonicTime) 15 | import GHC.Exts (IsString (..)) 16 | import Logger (mkSimpleLogger) 17 | import Network.Socket.Free (getFreePort) 18 | import Options (VmName (..)) 19 | import Run (run) 20 | import State 21 | import StdLib 22 | import System.Environment (lookupEnv) 23 | import System.IO (hPutStr) 24 | import System.IO qualified 25 | import System.IO.Silently 26 | import System.IO.Temp (withSystemTempDirectory, withSystemTempFile) 27 | import System.Process 28 | import Test.Hspec 29 | 30 | data TestResult = TestResult 31 | { stdout :: Text, 32 | stderr :: Text, 33 | exitCode :: ExitCode 34 | } 35 | deriving stock (Generic, Show, Eq) 36 | 37 | assertSuccess :: (HasCallStack) => IO TestResult -> IO TestResult 38 | assertSuccess action = do 39 | result <- action 40 | case result ^. #exitCode of 41 | ExitFailure code -> 42 | expectationFailure $ 43 | cs $ 44 | "command exited with " 45 | <> cs (show code) 46 | <> "\nStdout: \n" 47 | <> stdout result 48 | <> "\nStderr: \n" 49 | <> stderr result 50 | ExitSuccess -> pure () 51 | pure result 52 | 53 | test :: Context -> [Text] -> IO TestResult 54 | test ctx args = do 55 | (stderr, (stdout, exitCode)) <- hCapture [System.IO.stderr] $ capture $ run ctx args 56 | debugEnvVar <- lookupEnv "DEBUG" 57 | when (isJust debugEnvVar) $ do 58 | putStr stdout 59 | hPutStr System.IO.stderr stderr 60 | pure $ TestResult (cs stdout) (cs stderr) exitCode 61 | 62 | withContext :: NixVms -> (Context -> IO a) -> IO a 63 | withContext nixVms action = do 64 | withSystemTempFile "test-stdin" $ \_stdinFile stdinHandle -> do 65 | withSystemTempDirectory "test-working-dir" $ \workingDir -> do 66 | withSystemTempDirectory "test-storage-dir" $ \storageDir -> do 67 | testState <- newMVar $ TestState mempty mempty 68 | logger <- mkSimpleLogger 69 | let ctx = 70 | Context 71 | { testState = Just testState, 72 | stdin = stdinHandle, 73 | workingDir = workingDir, 74 | storageDir = storageDir "nixos-compose", 75 | nixVms, 76 | logger 77 | } 78 | action ctx `finally` endAllRegisteredProcesses ctx 79 | 80 | readTestState :: Context -> IO TestState 81 | readTestState ctx = readMVar (fromJust $ ctx ^. #testState) 82 | 83 | endAllRegisteredProcesses :: Context -> IO () 84 | endAllRegisteredProcesses ctx = do 85 | testState <- readTestState ctx 86 | mapM_ endProcess (testState ^. #registeredProcesses) 87 | 88 | endProcess :: ProcessHandle -> IO () 89 | endProcess handle = do 90 | terminateProcess handle 91 | _ <- waitForProcess handle 92 | pure () 93 | 94 | stopProcess :: Context -> ProcessType -> IO () 95 | stopProcess ctx typ = updateTestState ctx $ \testState -> do 96 | let map = testState ^. #registeredProcesses 97 | case Map.lookup typ map of 98 | Nothing -> 99 | error $ 100 | cs $ 101 | "cannot find executable: " 102 | <> cs (show typ) 103 | <> " in " 104 | <> T.intercalate ", " (fmap (cs . show) (Map.keys map)) 105 | Just handle -> do 106 | endProcess handle 107 | pure $ testState & #registeredProcesses .~ Map.delete typ map 108 | 109 | instance IsString VmName where 110 | fromString :: String -> VmName 111 | fromString = VmName . cs 112 | 113 | withMockContext :: [VmName] -> (Context -> IO a) -> IO a 114 | withMockContext vmNames action = do 115 | let mockNixVms = 116 | NixVms 117 | { listVms = \_ctx -> pure vmNames, 118 | buildVmScript = \_ctx _handle _vmName _ip -> do 119 | port <- getFreePort 120 | pure ("/fake-vm-script", port), 121 | runVm = 122 | \_ctx handle vmName _vmScript -> do 123 | unless (vmName `elem` vmNames) $ do 124 | error $ cs $ "nix vm mock: vm not found: " <> vmNameToText vmName 125 | (_, _, _, ph) <- do 126 | createProcess 127 | (proc "sleep" ["inf"]) 128 | { std_in = NoStream, 129 | std_out = UseHandle handle, 130 | std_err = UseHandle handle 131 | } 132 | pure ph, 133 | sshIntoVm = SshIntoVm $ \ctx vmName _port command -> do 134 | unless (vmName `elem` vmNames) $ do 135 | error $ cs $ "nix vm mock: vm not found: " <> vmNameToText vmName 136 | _state <- State.readVmState ctx vmName 137 | withSystemTempDirectory "fake-ssh" $ \tempDir -> do 138 | Cradle.run $ 139 | Cradle.cmd "bash" 140 | & Cradle.addArgs ["-c", command] 141 | & Cradle.setWorkingDir tempDir, 142 | updateVmHostsEntry = \ctx vmName _port hostName ip -> do 143 | updateTestState ctx $ pure . (#vmHostEntries %~ Map.insert (vmName, hostName) ip) 144 | } 145 | withContext mockNixVms action 146 | 147 | runningVms :: Context -> IO [VmName] 148 | runningVms ctx = Map.keys <$> State.listRunningVms ctx 149 | 150 | waitFor :: IO a -> IO a 151 | waitFor action = do 152 | startTime <- getMonotonicTime 153 | inner startTime 154 | where 155 | inner startTime = do 156 | result :: Either SomeException a <- try action 157 | case result of 158 | Left e -> do 159 | now <- getMonotonicTime 160 | if now - startTime < 2 161 | then do 162 | threadDelay 50_000 163 | inner startTime 164 | else throwIO e 165 | Right a -> pure a 166 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | inputs.nixpkgs.url = "github:NixOS/nixpkgs/nixos-25.05"; 3 | inputs.flake-utils.url = "github:numtide/flake-utils"; 4 | inputs.cradle = { 5 | url = "github:garnix-io/cradle"; 6 | inputs = { 7 | nixpkgs.follows = "nixpkgs"; 8 | flake-utils.follows = "flake-utils"; 9 | }; 10 | }; 11 | inputs.garnix-lib = { 12 | url = "github:garnix-io/garnix-lib"; 13 | inputs.nixpkgs.follows = "nixpkgs"; 14 | }; 15 | outputs = { self, nixpkgs, flake-utils, cradle, garnix-lib }: 16 | (flake-utils.lib.eachDefaultSystem (system: 17 | let 18 | pkgs = import "${nixpkgs}" { inherit system; config.allowBroken = true; }; 19 | lib = pkgs.lib; 20 | haskellPackages = pkgs.haskellPackages.override { 21 | overrides = final: prev: { 22 | cradle = cradle.lib.${system}.mkCradle final; 23 | }; 24 | }; 25 | prodSrc = 26 | lib.fileset.toSource { 27 | root = ./.; 28 | fileset = lib.fileset.unions [ 29 | ./nixos-compose.cabal 30 | ./src 31 | ]; 32 | }; 33 | haskellPackage = pkgs.haskell.lib.overrideCabal (haskellPackages.callCabal2nix "nixos-compose" prodSrc { }) (old: { 34 | buildDepends = (old.buildDepends or [ ]) ++ [ pkgs.openssh pkgs.nix ]; 35 | doCheck = false; 36 | configureFlags = [ 37 | "--ghc-option=-Werror" 38 | "--ghc-option=-O2" 39 | "--ghc-option=-D__NIXOS_COMPOSE_VERSION__=${self.shortRev or self.dirtyShortRev}" 40 | ]; 41 | }); 42 | runtimeDeps = [ 43 | pkgs.iproute2 44 | pkgs.nix 45 | pkgs.openssh 46 | pkgs.vde2 47 | pkgs.which 48 | ]; 49 | testDeps = [ 50 | pkgs.bash 51 | pkgs.coreutils 52 | pkgs.ps 53 | pkgs.python3 54 | pkgs.tree 55 | ]; 56 | ghcWithDeps = 57 | ( 58 | let 59 | withTestDeps = pkgs.haskell.lib.overrideCabal haskellPackage (old: { doCheck = true; }); 60 | in 61 | haskellPackages.ghc.withPackages (p: withTestDeps.buildInputs) 62 | ); 63 | devSrc = lib.fileset.toSource { 64 | root = ./.; 65 | fileset = lib.fileset.unions [ 66 | ./nixos-compose.cabal 67 | ./src 68 | ./spec 69 | ./.golden 70 | ]; 71 | }; 72 | in 73 | rec { 74 | packages = { 75 | default = 76 | let 77 | mkShellCompletion = shell: outPath: '' 78 | mkdir -p $out/${builtins.dirOf outPath} 79 | ${haskellPackage}/bin/nixos-compose --${shell}-completion-script ${haskellPackage}/bin/nixos-compose > $out/${outPath} 80 | ''; 81 | in 82 | pkgs.runCommand haskellPackage.name 83 | { 84 | nativeBuildInputs = [ pkgs.makeWrapper ]; 85 | } 86 | '' 87 | mkdir -p $out/bin/ 88 | cp -r ${haskellPackage}/bin/. $out/bin/ 89 | wrapProgram "$out/bin/nixos-compose" \ 90 | --prefix PATH : ${pkgs.lib.makeBinPath runtimeDeps} 91 | 92 | ${mkShellCompletion "bash" "share/bash-completion/completions/nixos-compose.bash"} 93 | ${mkShellCompletion "zsh" "share/zsh/vendor-completions/_nixos-compose"} 94 | ${mkShellCompletion "fish" "share/fish/vendor_completions.d/nixos-compose.fish"} 95 | ''; 96 | }; 97 | checks = { 98 | hlint = pkgs.runCommand "hlint" { buildInputs = [ pkgs.hlint ]; } 99 | '' 100 | cd ${devSrc} 101 | hlint src spec -XQuasiQuotes 102 | touch $out 103 | ''; 104 | }; 105 | apps = { 106 | spec = { 107 | type = "app"; 108 | program = pkgs.lib.getExe (pkgs.writeShellApplication { 109 | name = "spec"; 110 | inheritPath = false; 111 | runtimeInputs = [ 112 | ghcWithDeps 113 | pkgs.cabal-install 114 | ] ++ 115 | runtimeDeps ++ 116 | testDeps; 117 | text = '' 118 | dir=$(mktemp -d) 119 | trap 'rm -r $dir' EXIT 120 | cd "$dir" 121 | cp -r ${devSrc}/. . 122 | chmod -R a+w . 123 | cabal run spec --ghc-option=-Werror -- --strict 124 | ''; 125 | }); 126 | }; 127 | watch = 128 | { 129 | type = "app"; 130 | program = pkgs.lib.getExe (pkgs.writeShellApplication { 131 | name = "watch"; 132 | inheritPath = false; 133 | runtimeInputs = [ 134 | ghcWithDeps 135 | pkgs.cabal-install 136 | pkgs.ghcid 137 | pkgs.hpack 138 | ] ++ 139 | runtimeDeps ++ 140 | testDeps; 141 | text = '' 142 | rm dist-newstyle -rf 143 | hpack 144 | ghcid \ 145 | --command "cabal repl test:spec --ghc-options=-fdefer-typed-holes" \ 146 | --allow-eval \ 147 | --test ":main --skip Integration $*" \ 148 | --warnings \ 149 | ''; 150 | }); 151 | }; 152 | 153 | }; 154 | devShells = { 155 | default = pkgs.mkShell { 156 | buildInputs = with pkgs; ([ 157 | (haskell-language-server.override { dynamic = true; }) 158 | ghcWithDeps 159 | cabal-install 160 | ghcid 161 | haskellPackages.cabal2nix 162 | haskellPackages.hspec-discover 163 | hlint 164 | nil 165 | nixpkgs-fmt 166 | ormolu 167 | packages.default.buildInputs 168 | ] ++ 169 | runtimeDeps ++ 170 | testDeps); 171 | }; 172 | }; 173 | } 174 | )) // 175 | { 176 | nixosConfigurations."test-vm" = nixpkgs.lib.nixosSystem { 177 | modules = [ 178 | garnix-lib.nixosModules.garnix 179 | ({ pkgs, ... }: { 180 | networking.hostName = "test-vm"; 181 | nixpkgs.hostPlatform = "x86_64-linux"; 182 | system.stateVersion = "25.05"; 183 | garnix.server.enable = true; 184 | networking.firewall.allowedTCPPorts = [ 80 ]; 185 | services.nginx = { 186 | enable = true; 187 | virtualHosts.default.locations."/".return = "200 'hello from test-vm\\n'"; 188 | }; 189 | }) 190 | ]; 191 | }; 192 | }; 193 | } 194 | -------------------------------------------------------------------------------- /src/State.hs: -------------------------------------------------------------------------------- 1 | module State 2 | ( -- * global state 3 | State (..), 4 | emptyState, 5 | readState, 6 | modifyState, 7 | modifyState_, 8 | 9 | -- * vm state 10 | VmState (..), 11 | getPid, 12 | vmStateToText, 13 | claimVm, 14 | readVmState, 15 | writeVmState, 16 | removeVm, 17 | getVmFilePath, 18 | listRunningVms, 19 | 20 | -- * IPs 21 | hostIp, 22 | getNextIp, 23 | ) 24 | where 25 | 26 | import Context 27 | import Context.Utils 28 | import Data.Aeson 29 | import Data.ByteString.Lazy qualified 30 | import Data.Map (Map) 31 | import Data.Map qualified as Map 32 | import Data.Text.IO qualified as T 33 | import Logging 34 | import Net.IPv4 (IPv4) 35 | import Net.IPv4 qualified as IPv4 36 | import Options (VmName (..)) 37 | import StdLib 38 | import System.Console.ANSI qualified as ANSI 39 | import System.Directory 40 | ( createDirectoryIfMissing, 41 | doesDirectoryExist, 42 | listDirectory, 43 | removeDirectoryRecursive, 44 | ) 45 | import System.FileLock 46 | import Table (StyledText, withColor) 47 | import Utils (filterMapM) 48 | import Vde qualified 49 | 50 | -- global state 51 | 52 | data State = State 53 | { vde :: Maybe Vde.VdeState, 54 | vms :: Map VmName VmState, 55 | nextIp :: IPv4 56 | } 57 | deriving stock (Generic, Show, Eq) 58 | deriving anyclass (ToJSON, FromJSON) 59 | 60 | emptyState :: State 61 | emptyState = 62 | State 63 | { vde = Nothing, 64 | vms = mempty, 65 | nextIp = fst ipRange 66 | } 67 | 68 | -- every other state interaction is implemented in terms of this `modifyState` function 69 | modifyState :: Context -> (State -> IO (State, a)) -> IO a 70 | modifyState ctx action = do 71 | file <- getStateFile ctx 72 | withFileLock file Exclusive $ \_lock -> do 73 | contents <- T.readFile file 74 | parsed <- 75 | if contents == "" 76 | then pure emptyState 77 | else either (impossible ctx . cs) pure (eitherDecode' (cs contents) :: Either String State) 78 | cleanedUp <- cleanUpVms ctx parsed >>= cleanUpVdeSwitch ctx 79 | (next, a) <- action cleanedUp 80 | next <- cleanUpVdeSwitch ctx next 81 | Data.ByteString.Lazy.writeFile file (encode (next :: State)) 82 | pure a 83 | 84 | modifyState_ :: Context -> (State -> IO State) -> IO () 85 | modifyState_ ctx action = modifyState ctx $ \state -> do 86 | new <- action state 87 | pure (new, ()) 88 | 89 | readState :: Context -> IO State 90 | readState ctx = modifyState ctx $ \state -> do 91 | pure (state, state) 92 | 93 | getStateFile :: Context -> IO FilePath 94 | getStateFile ctx = do 95 | let dir = storageDir ctx 96 | createDirectoryIfMissing True dir 97 | pure $ dir "state.json" 98 | 99 | cleanUpVdeSwitch :: Context -> State -> IO State 100 | cleanUpVdeSwitch ctx state = do 101 | tapPid <- Vde.vde_plug2tapReadPidFile ctx 102 | case (state ^. #vde, Map.keys (state ^. #vms), tapPid) of 103 | (Just vdeState, [], Nothing) -> do 104 | Vde.stop ctx vdeState 105 | pure $ state & #vde .~ Nothing 106 | _ -> pure state 107 | 108 | -- * vm state 109 | 110 | data VmState 111 | = Building 112 | { ip :: IPv4 113 | } 114 | | Booting 115 | { ip :: IPv4 116 | } 117 | | Running 118 | { port :: Int, 119 | pid :: ProcessID, 120 | ip :: IPv4 121 | } 122 | deriving stock (Generic, Show, Eq) 123 | deriving anyclass (ToJSON, FromJSON) 124 | 125 | getPid :: VmState -> Maybe ProcessID 126 | getPid = \case 127 | Building {} -> Nothing 128 | Booting {} -> Nothing 129 | Running {pid} -> Just pid 130 | 131 | vmStateToText :: Maybe VmState -> StyledText 132 | vmStateToText = \case 133 | Nothing -> withColor ANSI.Blue "not running" 134 | Just (Building {}) -> withColor ANSI.Yellow "building" 135 | Just (Booting {}) -> withColor ANSI.Yellow "booting" 136 | Just (Running {}) -> withColor ANSI.Green "running" 137 | 138 | cleanUpVms :: Context -> State -> IO State 139 | cleanUpVms ctx state = do 140 | running <- filterMapM isRunning (state ^. #vms) 141 | pure $ state & #vms .~ running 142 | where 143 | isRunning :: VmName -> VmState -> IO Bool 144 | isRunning vmName = \case 145 | Building {} -> pure True 146 | Booting {} -> pure True 147 | Running {pid} -> do 148 | isRunning <- doesDirectoryExist $ "/proc/" <> show (pid :: ProcessID) 149 | unless isRunning $ do 150 | info ctx $ "WARN: cannot find process for vm: " <> vmNameToText vmName 151 | removeVmDir ctx vmName 152 | pure isRunning 153 | 154 | claimVm :: Context -> VmName -> VmState -> IO (Either VmState ()) 155 | claimVm ctx vm new = modifyState ctx $ \state -> do 156 | case Map.lookup vm (state ^. #vms) of 157 | Just existing -> do 158 | pure (state, Left existing) 159 | Nothing -> do 160 | vdeState <- case state ^. #vde of 161 | Just vdeState -> pure vdeState 162 | Nothing -> Vde.start ctx 163 | pure 164 | ( state 165 | & (#vms %~ Map.insert vm new) 166 | & (#vde ?~ vdeState), 167 | Right () 168 | ) 169 | 170 | readVmState :: Context -> VmName -> IO (Maybe VmState) 171 | readVmState ctx vmName = do 172 | state <- readState ctx 173 | pure $ Map.lookup vmName (state ^. #vms) 174 | 175 | writeVmState :: Context -> VmName -> VmState -> IO () 176 | writeVmState ctx vmName vmState = do 177 | modifyState_ ctx $ \state -> do 178 | pure $ state & #vms %~ Map.insert vmName vmState 179 | 180 | removeVm :: Context -> VmName -> IO () 181 | removeVm ctx vmName = do 182 | removeVmDir ctx vmName 183 | modifyState_ ctx $ \state -> do 184 | pure $ state & #vms %~ Map.delete vmName 185 | 186 | listRunningVms :: Context -> IO (Map VmName VmState) 187 | listRunningVms ctx = do 188 | state <- readState ctx 189 | pure $ state ^. #vms 190 | 191 | removeVmDir :: Context -> VmName -> IO () 192 | removeVmDir ctx vmName = do 193 | removeDirectoryRecursive $ storageDir ctx "vms" cs (vmNameToText vmName) 194 | vmDirs <- listDirectory (storageDir ctx "vms") 195 | when (null vmDirs) $ do 196 | removeDirectoryRecursive (storageDir ctx "vms") 197 | 198 | getVmFilePath :: Context -> VmName -> FilePath -> IO FilePath 199 | getVmFilePath ctx vmName path = do 200 | let dir = storageDir ctx "vms" cs (vmNameToText vmName) 201 | createDirectoryIfMissing True dir 202 | pure $ dir path 203 | 204 | -- * IPs 205 | 206 | hostIp :: IPv4 207 | hostIp = IPv4.fromOctets 10 0 0 1 208 | 209 | ipRange :: (IPv4, IPv4) 210 | ipRange = (IPv4.fromOctets 10 0 0 2, IPv4.fromOctets 10 0 0 254) 211 | 212 | getNextIp :: Context -> IO IPv4 213 | getNextIp ctx = modifyState ctx $ \state -> do 214 | let findIp candidate 215 | | candidate > snd ipRange = findIp (fst ipRange) 216 | | candidate `elem` map (^. #ip) (Map.elems (state ^. #vms)) = 217 | findIp (succ candidate) 218 | | otherwise = candidate 219 | let ip = findIp $ state ^. #nextIp 220 | pure (state & #nextIp .~ succ ip, ip) 221 | -------------------------------------------------------------------------------- /src/NixVms.hs: -------------------------------------------------------------------------------- 1 | module NixVms (NixVms (..), production) where 2 | 3 | import Context 4 | import Context.Utils (runWithErrorHandling) 5 | import Cradle 6 | import Data.Aeson qualified as Aeson 7 | import Data.Map.Strict qualified as Map 8 | import Data.String.Interpolate (i) 9 | import Data.Text qualified as T 10 | import Logging 11 | import Net.IPv4 (IPv4) 12 | import Net.IPv4 qualified as IPv4 13 | import Network.Socket.Free (getFreePort) 14 | import Options (VmName (..)) 15 | import State 16 | import StdLib 17 | import System.Directory (createDirectoryIfMissing, listDirectory) 18 | import System.Environment (getEnvironment) 19 | import System.FilePath (takeDirectory) 20 | import System.IO (Handle) 21 | import System.Process (CreateProcess (..), ProcessHandle, StdStream (..), createProcess, proc) 22 | import Utils 23 | import Vde qualified 24 | import Prelude 25 | 26 | production :: NixVms 27 | production = 28 | NixVms 29 | { listVms = listVmsImpl, 30 | buildVmScript = buildVmScriptImpl, 31 | runVm = runVmImpl, 32 | sshIntoVm = SshIntoVm sshIntoVmImpl, 33 | updateVmHostsEntry = updateVmHostsEntryImpl 34 | } 35 | 36 | listVmsImpl :: Context -> IO [VmName] 37 | listVmsImpl ctx = do 38 | Cradle.StdoutRaw json <- 39 | runWithErrorHandling ctx $ 40 | Cradle.cmd "nix" 41 | & Cradle.setWorkingDir (workingDir ctx) 42 | & addArgs 43 | ( nixStandardFlags 44 | <> [ "eval", 45 | ".#.", 46 | "--json", 47 | "--apply", 48 | "outputs: builtins.attrNames (outputs.nixosConfigurations or {})" 49 | ] 50 | ) 51 | case Aeson.eitherDecode' (cs json) of 52 | Left err -> impossible ctx $ cs err 53 | Right (parsed :: [Text]) -> pure $ map VmName parsed 54 | 55 | buildVmScriptImpl :: Context -> Maybe Handle -> VmName -> IPv4 -> IO (FilePath, Port) 56 | buildVmScriptImpl ctx handle vmName ip = do 57 | port <- getFreePort 58 | moduleExtensions <- getModuleExtensions ctx vmName port ip 59 | (Cradle.StdoutTrimmed drvPathJson) <- 60 | runWithErrorHandling ctx $ 61 | Cradle.cmd "nix" 62 | & Cradle.setWorkingDir (workingDir ctx) 63 | & Cradle.addArgs 64 | ( nixStandardFlags 65 | <> [ "eval", 66 | ".#nixosConfigurations." <> toNixString (vmNameToText vmName), 67 | "--json", 68 | "--apply", 69 | "nixConfig: (nixConfig.extendModules { modules = [(" <> moduleExtensions <> ")]; }).config.system.build.vm.drvPath" 70 | ] 71 | ) 72 | & maybe id addStderrHandle handle 73 | drvPath :: Text <- case Aeson.eitherDecode' $ cs drvPathJson of 74 | Right t -> pure t 75 | Left err -> impossible ctx $ cs err 76 | 77 | (Cradle.StdoutTrimmed outPath) <- 78 | runWithErrorHandling ctx $ 79 | Cradle.cmd "nix" 80 | & Cradle.addArgs 81 | ( nixStandardFlags 82 | <> [ "build", 83 | "--print-out-paths", 84 | "--no-link", 85 | drvPath <> "^*" 86 | ] 87 | ) 88 | & Cradle.setWorkingDir (workingDir ctx) 89 | & maybe id addStderrHandle handle 90 | 91 | files <- listDirectory (cs outPath "bin") 92 | case files of 93 | [file] -> pure (cs outPath "bin" file, port) 94 | files -> impossible ctx $ "expected one vm script: " <> cs (show files) 95 | 96 | nixStandardFlags :: [Text] 97 | nixStandardFlags = 98 | [ "--extra-experimental-features", 99 | "nix-command flakes" 100 | ] 101 | 102 | getModuleExtensions :: Context -> VmName -> Port -> IPv4 -> IO Text 103 | getModuleExtensions ctx vmName port ip = do 104 | publicKey <- readFile =<< getVmFilePath ctx vmName "vmkey.pub" 105 | pure $ 106 | cs 107 | [i| 108 | { config, pkgs, ... }: { 109 | console.enable = false; 110 | services.openssh.enable = true; 111 | users.users.vmuser = { 112 | isNormalUser = true; 113 | group = "wheel"; 114 | openssh.authorizedKeys.keys = [ #{toNixString $ cs publicKey} ]; 115 | packages = [ 116 | (pkgs.writeShellApplication { 117 | name = "update-vm-hosts-entry"; 118 | text = '' 119 | HOSTNAME="$1" 120 | IP="$2" 121 | sudo sed -i "/ $HOSTNAME\$/d" /etc/hosts 122 | sudo tee --append /etc/hosts <<< "$IP $HOSTNAME" > /dev/null 123 | ''; 124 | }) 125 | ]; 126 | }; 127 | security.sudo.extraRules = [ 128 | { users = [ "vmuser" ]; commands = [ { command = "ALL"; options = [ "NOPASSWD" ]; } ]; } 129 | ]; 130 | virtualisation.vmVariant.virtualisation = { 131 | graphics = false; 132 | forwardPorts = [{ 133 | from = "host"; 134 | host.port = #{port}; 135 | guest.port = builtins.head config.services.openssh.ports; 136 | }]; 137 | }; 138 | networking.interfaces.eth1.ipv4.addresses = [{ 139 | address = "#{IPv4.encode ip :: Text}"; 140 | prefixLength = 24; 141 | }]; 142 | } 143 | |] 144 | 145 | toNixString :: Text -> Text 146 | toNixString s = "\"" <> T.concatMap escapeChar (cs s) <> "\"" 147 | where 148 | escapeChar c = case c of 149 | '"' -> "\\\"" 150 | '$' -> "\\$" 151 | '\\' -> "\\\\" 152 | c -> T.singleton c 153 | 154 | runVmImpl :: Context -> Handle -> VmName -> FilePath -> IO ProcessHandle 155 | runVmImpl ctx handle vmName vmExecutable = do 156 | nixDiskImage <- getVmFilePath ctx vmName "image.qcow2" 157 | createDirectoryIfMissing True (takeDirectory nixDiskImage) 158 | parentEnvironment <- getEnvironment <&> Map.fromList 159 | vdeCtlDir <- Vde.getVdeCtlDir ctx 160 | (_, _, _, ph) <- 161 | createProcess 162 | ( ( System.Process.proc 163 | vmExecutable 164 | [ "-device", 165 | "virtio-net-pci,netdev=vlan1,mac=52:54:00:12:01:03", 166 | "-netdev", 167 | "vde,id=vlan1,sock=" <> vdeCtlDir 168 | ] 169 | ) 170 | { env = 171 | Just $ 172 | Map.toList $ 173 | parentEnvironment 174 | <> "NIX_DISK_IMAGE" ~> nixDiskImage 175 | <> "NIXOS_COMPOSE_FLAKE_DIR" ~> (ctx ^. #workingDir), 176 | std_in = CreatePipe, 177 | std_out = UseHandle handle, 178 | std_err = UseHandle handle 179 | } 180 | ) 181 | pure ph 182 | 183 | sshIntoVmImpl :: (Cradle.Output o) => Context -> VmName -> Port -> Text -> IO o 184 | sshIntoVmImpl ctx vmName port command = do 185 | vmKeyPath <- getVmFilePath ctx vmName "vmkey" 186 | Cradle.run $ 187 | Cradle.cmd "ssh" 188 | & Cradle.setStdinHandle (ctx ^. #stdin) 189 | & Cradle.addArgs 190 | [ "-i", 191 | cs vmKeyPath, 192 | "-l", 193 | "vmuser", 194 | "-o", 195 | "StrictHostKeyChecking=no", 196 | "-o", 197 | "UserKnownHostsFile=/dev/null", 198 | "-o", 199 | "ConnectTimeout=2", 200 | "-p", 201 | cs (show port), 202 | "-q", 203 | "localhost", 204 | "--", 205 | command 206 | ] 207 | 208 | updateVmHostsEntryImpl :: Context -> VmName -> Port -> Hostname -> IPv4 -> IO () 209 | updateVmHostsEntryImpl ctx vmName port hostname ip = do 210 | sshIntoVmImpl ctx vmName port $ "update-vm-hosts-entry " <> hostnameToText hostname <> " " <> IPv4.encode ip 211 | -------------------------------------------------------------------------------- /spec/NetworkingSpec.hs: -------------------------------------------------------------------------------- 1 | module NetworkingSpec where 2 | 3 | import Context 4 | import Control.Monad (replicateM) 5 | import Cradle 6 | import Data.Maybe (fromJust) 7 | import Net.IPv4 qualified as IPv4 8 | import Options (VmName (..)) 9 | import State (getNextIp, getPid, readState, readVmState) 10 | import StdLib 11 | import System.Directory (getSymbolicLinkTarget, listDirectory) 12 | import System.FilePath 13 | import Test.Hspec 14 | import TestUtils 15 | import Utils 16 | 17 | spec :: Spec 18 | spec = do 19 | describe "`vde_switch`" $ do 20 | let assertVdeIsRunning ctx = do 21 | state <- readState ctx 22 | exe <- getSymbolicLinkTarget $ "/proc" show (state ^. #vde . to fromJust . #pid :: ProcessID) "exe" 23 | takeFileName exe `shouldBe` "vde_switch" 24 | 25 | let assertVmIsRunning ctx vmName = do 26 | state <- fromJust <$> readVmState ctx vmName 27 | let pid = fromJust $ getPid state 28 | comm <- readFile $ "/proc" show (pid :: ProcessID) "comm" 29 | comm `shouldBe` "sleep\n" 30 | 31 | it "starts the switch when starting a vm" $ do 32 | withMockContext ["a"] $ \ctx -> do 33 | _ <- assertSuccess $ test ctx ["up", "a"] 34 | assertVdeIsRunning ctx 35 | 36 | it "stops the switch when a vm is stopped" $ do 37 | withMockContext ["a"] $ \ctx -> do 38 | _ <- assertSuccess $ test ctx ["up", "a"] 39 | state <- readState ctx 40 | _ <- assertSuccess $ test ctx ["down", "a"] 41 | (^. #vde) <$> readState ctx `shouldReturn` Nothing 42 | (StdoutRaw stdout) <- Cradle.run $ cmd "ps" & addArgs ["-p", show (state ^. #vde . to fromJust . #pid), "-o", "stat", "--no-headers"] 43 | -- It's stopped, but still a zombie, since it's a child of the test-suite. 44 | stdout `shouldSatisfy` (`elem` ["Z\n", "Z+\n"]) 45 | 46 | it "cleans up the files after stopping" $ do 47 | withMockContext ["a"] $ \ctx -> do 48 | _ <- assertSuccess $ test ctx ["up", "a"] 49 | _ <- assertSuccess $ test ctx ["down", "a"] 50 | listDirectory (ctx ^. #storageDir) `shouldReturn` ["state.json"] 51 | 52 | it "keeps the switch running for multiple vms" $ do 53 | withMockContext ["a", "b"] $ \ctx -> do 54 | _ <- assertSuccess $ test ctx ["up", "a"] 55 | _ <- assertSuccess $ test ctx ["up", "b"] 56 | assertVdeIsRunning ctx 57 | _ <- assertSuccess $ test ctx ["down", "b"] 58 | assertVdeIsRunning ctx 59 | 60 | it "stops the switch after all vms are stopped" $ do 61 | withMockContext ["a", "b"] $ \ctx -> do 62 | _ <- assertSuccess $ test ctx ["up", "a"] 63 | _ <- assertSuccess $ test ctx ["up", "b"] 64 | assertVdeIsRunning ctx 65 | _ <- assertSuccess $ test ctx ["down", "b"] 66 | _ <- assertSuccess $ test ctx ["down", "a"] 67 | (^. #vde) <$> readState ctx `shouldReturn` Nothing 68 | 69 | it "restarts the switch after e.g. a reboot" $ do 70 | withMockContext ["a", "b"] $ \ctx -> do 71 | _ <- assertSuccess $ test ctx ["up", "a"] 72 | endAllRegisteredProcesses ctx 73 | _ <- assertSuccess $ test ctx ["up", "a"] 74 | assertVdeIsRunning ctx 75 | assertVmIsRunning ctx "a" 76 | 77 | describe "ip assignments" $ do 78 | it "assigns an ip to vms" $ do 79 | withMockContext ["a"] $ \ctx -> do 80 | _ <- assertSuccess $ test ctx ["up", "a"] 81 | output <- assertSuccess $ test ctx ["ip", "a"] 82 | output ^. #stdout `shouldBe` "10.0.0.2\n" 83 | 84 | it "handles non-running vms gracefully" $ do 85 | withMockContext ["a"] $ \ctx -> do 86 | test ctx ["ip", "a"] 87 | `shouldReturn` TestResult "" "vm not running: a\n" (ExitFailure 1) 88 | _ <- assertSuccess $ test ctx ["up", "a"] 89 | stopProcess ctx (Vm "a") 90 | test ctx ["ip", "a"] 91 | `shouldReturn` TestResult 92 | { stdout = "", 93 | stderr = "WARN: cannot find process for vm: a\nvm not running: a\n", 94 | exitCode = ExitFailure 1 95 | } 96 | 97 | it "assigns different ips to different vms" $ do 98 | withMockContext ["a", "b", "c"] $ \ctx -> do 99 | _ <- assertSuccess $ test ctx ["up", "a"] 100 | _ <- assertSuccess $ test ctx ["up", "b"] 101 | _ <- assertSuccess $ test ctx ["up", "c"] 102 | output <- assertSuccess $ test ctx ["ip", "a"] 103 | output ^. #stdout `shouldBe` "10.0.0.2\n" 104 | output <- assertSuccess $ test ctx ["ip", "b"] 105 | output ^. #stdout `shouldBe` "10.0.0.3\n" 106 | output <- assertSuccess $ test ctx ["ip", "c"] 107 | output ^. #stdout `shouldBe` "10.0.0.4\n" 108 | 109 | it "tries not to re-assign vms" $ do 110 | withMockContext ["a", "b", "c"] $ \ctx -> do 111 | _ <- assertSuccess $ test ctx ["up", "a"] 112 | stdout <$> assertSuccess (test ctx ["ip", "a"]) `shouldReturn` "10.0.0.2\n" 113 | _ <- assertSuccess $ test ctx ["up", "b"] 114 | stdout <$> assertSuccess (test ctx ["ip", "b"]) `shouldReturn` "10.0.0.3\n" 115 | _ <- assertSuccess $ test ctx ["down", "b"] 116 | _ <- assertSuccess $ test ctx ["up", "b"] 117 | stdout <$> assertSuccess (test ctx ["ip", "b"]) `shouldReturn` "10.0.0.4\n" 118 | _ <- assertSuccess $ test ctx ["down", "b"] 119 | _ <- assertSuccess $ test ctx ["up", "c"] 120 | stdout <$> assertSuccess (test ctx ["ip", "c"]) `shouldReturn` "10.0.0.5\n" 121 | 122 | it "wraps around and doesn't assign ips that are in use" $ do 123 | withMockContext ["a"] $ \ctx -> do 124 | _ <- assertSuccess $ test ctx ["up", "a"] 125 | ips <- replicateM 251 $ do 126 | getNextIp ctx 127 | ips `shouldBe` [IPv4.fromOctets 10 0 0 3 .. IPv4.fromOctets 10 0 0 253] 128 | ips <- replicateM 3 $ do 129 | IPv4.encode <$> getNextIp ctx 130 | ips `shouldBe` ["10.0.0.254", "10.0.0.3", "10.0.0.4"] 131 | 132 | describe "hostnames" $ do 133 | it "registers hostname mappings amongst all VMs" $ do 134 | withMockContext ["a", "b", "c"] $ \ctx -> do 135 | let allPairs :: [a] -> [(a, a)] 136 | allPairs list = (,) <$> list <*> list 137 | _ <- assertSuccess $ test ctx ["up"] 138 | testState <- readTestState ctx 139 | testState ^. #vmHostEntries 140 | `shouldBe` ( [ ("a", IPv4.ipv4 10 0 0 2), 141 | ("b", IPv4.ipv4 10 0 0 3), 142 | ("c", IPv4.ipv4 10 0 0 4) 143 | ] 144 | & allPairs 145 | & map (\((fromName, _), (toName, toIP)) -> (VmName fromName, fromJust $ parseHostname toName) ~> toIP) 146 | & mconcat 147 | ) 148 | 149 | it "only sets VM names that are valid hostnames" $ do 150 | withMockContext 151 | [ "valid-hostname", 152 | "invalid?hostname" 153 | ] 154 | $ \ctx -> do 155 | _ <- assertSuccess $ test ctx ["up"] 156 | testState <- readTestState ctx 157 | testState ^. #vmHostEntries 158 | `shouldBe` ( (VmName "invalid?hostname", fromJust $ parseHostname "valid-hostname") ~> IPv4.ipv4 10 0 0 2 159 | <> (VmName "valid-hostname", fromJust $ parseHostname "valid-hostname") ~> IPv4.ipv4 10 0 0 2 160 | ) 161 | 162 | it "prints a warning if an invalid hostname is used" $ do 163 | withMockContext 164 | [ "valid-hostname", 165 | "invalid?hostname" 166 | ] 167 | $ \ctx -> do 168 | result <- assertSuccess (test ctx ["up"]) 169 | cs (result ^. #stderr) `shouldContain` "WARN: \"invalid?hostname\" is not a valid hostname. It will not be added to /etc/hosts.\n" 170 | -------------------------------------------------------------------------------- /src/Commands/Up.hs: -------------------------------------------------------------------------------- 1 | module Commands.Up (up) where 2 | 3 | import Context 4 | import Context.Utils 5 | import Control.Exception.Safe (catch, onException, throwIO) 6 | import Cradle 7 | import Data.List.NonEmpty (NonEmpty (..)) 8 | import Data.Map qualified as Map 9 | import Data.String.AnsiEscapeCodes.Strip.Text (stripAnsiEscapeCodes) 10 | import Data.Text qualified as T 11 | import Data.Text.IO qualified as T 12 | import GHC.Conc (atomically) 13 | import Ki qualified 14 | import Logging 15 | import Options (AllOrSomeVms (..), Verbosity (..), VmName (..)) 16 | import SafeCreatePipe (safeCreatePipe) 17 | import State 18 | import StdLib 19 | import System.Directory (doesFileExist) 20 | import System.IO (BufferMode (..), Handle, IOMode (..), hClose, hSetBuffering, openFile, stderr) 21 | import System.IO.Error (isEOFError) 22 | import System.Process (ProcessHandle, getPid, getProcessExitCode) 23 | import Table (unstyledText) 24 | import Utils 25 | 26 | up :: Context -> Verbosity -> AllOrSomeVms -> IO () 27 | up ctx verbosity upOptions = do 28 | vmNames <- case upOptions of 29 | All -> do 30 | vmNames <- listVms (nixVms ctx) ctx 31 | case vmNames of 32 | [] -> abort ctx "No vms are defined. Nothing to do." 33 | a : r -> pure $ a :| r 34 | Some vmNames -> pure vmNames 35 | 36 | Ki.scoped $ \scope -> do 37 | forM_ vmNames $ \vmName -> do 38 | ip <- getNextIp ctx 39 | Ki.fork scope $ do 40 | existing <- claimVm ctx vmName $ Building {ip} 41 | case existing of 42 | Left existing -> 43 | output ctx $ 44 | vmNameToText vmName 45 | <> ": already " 46 | <> unstyledText (vmStateToText (Just existing)) 47 | Right () -> do 48 | (ctx ^. #logger . #setPhase) vmName "building" 49 | (pid, port) <- removeVmWhenFailing ctx vmName $ do 50 | vmKeyPath <- getVmFilePath ctx vmName "vmkey" 51 | exists <- doesFileExist vmKeyPath 52 | when exists $ do 53 | impossible ctx $ cs vmKeyPath <> " already exists" 54 | () <- 55 | runWithErrorHandling ctx $ 56 | Cradle.cmd "ssh-keygen" 57 | & Cradle.addArgs ["-f", vmKeyPath, "-N", ""] 58 | (vmScript, port) <- 59 | terminating ctx verbosity vmName $ \handle -> do 60 | buildVmScript (nixVms ctx) ctx handle vmName ip 61 | State.writeVmState ctx vmName $ Booting {ip} 62 | (ctx ^. #logger . #setPhase) vmName "booting" 63 | nonTerminating ctx verbosity vmName $ \handle -> do 64 | (handle, logFile) <- case handle of 65 | Nothing -> do 66 | logFile <- getVmFilePath ctx vmName "log.txt" 67 | handle <- openFile logFile WriteMode 68 | pure (handle, Just logFile) 69 | Just handle -> pure (handle, Nothing) 70 | ph <- (ctx ^. #nixVms . #runVm) ctx handle vmName vmScript 71 | registerProcess ctx (Vm vmName) ph 72 | pid <- 73 | System.Process.getPid ph 74 | >>= maybe (impossible ctx "qemu process has no pid") pure 75 | waitForVm ctx vmName port ph $ \vmScriptExitCode -> do 76 | case logFile of 77 | Just logFile -> do 78 | hClose handle 79 | output <- T.readFile logFile 80 | info ctx (T.intercalate "\n" ["VM failed to start:\n", T.stripEnd output]) 81 | exitWith $ case vmScriptExitCode of 82 | ExitSuccess -> ExitFailure 1 83 | vmScriptExitCode -> vmScriptExitCode 84 | Nothing -> do 85 | info ctx "VM failed to start" 86 | exitWith $ case vmScriptExitCode of 87 | ExitSuccess -> ExitFailure 1 88 | vmScriptExitCode -> vmScriptExitCode 89 | pure (pid, port) 90 | State.writeVmState ctx vmName (Running {pid, port, ip}) 91 | (ctx ^. #logger . #clearPhase) vmName 92 | atomically $ Ki.awaitAll scope 93 | updateVmHostEntries ctx 94 | 95 | -- | Logs everything written to the handle according to the given verbosity. 96 | -- The handle can be passed to *terminating* child processes. 97 | -- The handle will be closed after the given action is done and the stream threads will be waited for. 98 | terminating :: Context -> Verbosity -> VmName -> (Maybe Handle -> IO a) -> IO a 99 | terminating ctx verbosity vmName action = 100 | Ki.scoped $ \scope -> do 101 | handle <- newVerbosityHandle scope verbosity (logLineForVm ctx vmName) 102 | x <- action handle 103 | forM_ handle $ \handle -> do 104 | System.IO.hClose handle 105 | atomically $ Ki.awaitAll scope 106 | return x 107 | 108 | -- | Logs everything written to the handle according to the given verbosity. 109 | -- The handle can be passed to *non-terminating* child processes. 110 | -- Once the given action is done, the handle *won't* be closed, but logging will stop. 111 | nonTerminating :: Context -> Verbosity -> VmName -> (Maybe Handle -> IO a) -> IO a 112 | nonTerminating ctx verbosity vmName action = 113 | Ki.scoped $ \scope -> do 114 | handle <- newVerbosityHandle scope verbosity (logLineForVm ctx vmName) 115 | action handle 116 | 117 | logLineForVm :: Context -> VmName -> Text -> IO () 118 | logLineForVm ctx vmName line = 119 | (ctx ^. #logger . #pushLog) 120 | System.IO.stderr 121 | $ line 122 | & stripAnsiEscapeCodes 123 | & removeNonPrintableChars 124 | & ((vmNameToText vmName <> "> ") <>) 125 | where 126 | removeNonPrintableChars :: Text -> Text 127 | removeNonPrintableChars = T.filter (>= ' ') 128 | 129 | newVerbosityHandle :: Ki.Scope -> Verbosity -> (Text -> IO ()) -> IO (Maybe Handle) 130 | newVerbosityHandle scope verbosity logLine = 131 | case verbosity of 132 | DefaultVerbosity -> pure Nothing 133 | Verbose -> do 134 | (readEnd, writeEnd) <- safeCreatePipe 135 | hSetBuffering writeEnd LineBuffering 136 | _ <- Ki.fork scope (streamFromHandle readEnd logLine) 137 | pure $ Just writeEnd 138 | where 139 | streamFromHandle :: Handle -> (Text -> IO ()) -> IO () 140 | streamFromHandle handle logLine = do 141 | line <- 142 | (Just <$> T.hGetLine handle) 143 | `catch` ( \case 144 | e | isEOFError e -> pure Nothing 145 | e -> throwIO e 146 | ) 147 | case line of 148 | Nothing -> pure () 149 | Just line -> do 150 | logLine line 151 | streamFromHandle handle logLine 152 | 153 | removeVmWhenFailing :: Context -> VmName -> IO a -> IO a 154 | removeVmWhenFailing ctx vmName action = do 155 | onException action $ do 156 | State.removeVm ctx vmName 157 | 158 | waitForVm :: Context -> VmName -> Port -> ProcessHandle -> (ExitCode -> IO ()) -> IO () 159 | waitForVm ctx vmName port ph handleCrash = do 160 | (StdoutRaw _, StderrRaw _, sshExitCode) <- (ctx ^. #nixVms . #sshIntoVm . to runSshIntoVm) ctx vmName port "true" 161 | case sshExitCode of 162 | ExitSuccess -> pure () 163 | ExitFailure _ -> do 164 | vmScriptExitCode <- getProcessExitCode ph 165 | case vmScriptExitCode of 166 | Nothing -> waitForVm ctx vmName port ph handleCrash 167 | Just vmScriptExitCode -> handleCrash vmScriptExitCode 168 | 169 | updateVmHostEntries :: Context -> IO () 170 | updateVmHostEntries ctx = do 171 | runningVms <- listRunningVms ctx 172 | forM_ (Map.toList runningVms) $ \(targetVmName, targetVmState) -> do 173 | case parseHostname $ vmNameToText targetVmName of 174 | Nothing -> info ctx $ "WARN: \"" <> vmNameToText targetVmName <> "\" is not a valid hostname. It will not be added to /etc/hosts." 175 | Just targetHostname -> do 176 | forM_ (Map.toList runningVms) $ \(updatingVmName, updatingVmState) -> do 177 | case updatingVmState of 178 | Building {} -> pure () 179 | Booting {} -> pure () 180 | Running {port} -> do 181 | updateVmHostsEntry 182 | (nixVms ctx) 183 | ctx 184 | updatingVmName 185 | port 186 | targetHostname 187 | (targetVmState ^. #ip) 188 | -------------------------------------------------------------------------------- /spec/CliSpec.hs: -------------------------------------------------------------------------------- 1 | module CliSpec where 2 | 3 | import Context 4 | import Data.Map qualified as Map 5 | import Data.Maybe (fromJust) 6 | import Data.String.Interpolate (i) 7 | import Data.String.Interpolate.Util (unindent) 8 | import Data.Text qualified as T 9 | import Data.Text.IO qualified as T 10 | import Net.IPv4 qualified as IPv4 11 | import State (getPid, readVmState) 12 | import State qualified 13 | import StdLib 14 | import System.Directory (doesDirectoryExist, listDirectory) 15 | import Table (renderTable) 16 | import Test.Hspec 17 | import Test.Hspec.Golden (defaultGolden) 18 | import TestUtils 19 | 20 | spec :: Spec 21 | spec = do 22 | describe "help output" $ do 23 | it "outputs all commands when invoked without arguments" $ do 24 | withMockContext ["a"] $ \ctx -> do 25 | result <- test ctx [] 26 | pure $ defaultGolden "stderr" (cs (result ^. #stderr)) 27 | 28 | it "has a --version flag" $ do 29 | withMockContext [] $ \ctx -> do 30 | test ctx ["--version"] 31 | `shouldReturn` TestResult "unknown\n" "" ExitSuccess 32 | 33 | it "ignores other options and flags when --version is given" $ do 34 | withMockContext [] $ \ctx -> do 35 | test ctx ["--version", "list"] 36 | `shouldReturn` TestResult "unknown\n" "" ExitSuccess 37 | 38 | describe "status" $ do 39 | context "without vm arguments" $ do 40 | it "lists the status of all vms" $ do 41 | withMockContext ["a", "b"] $ \ctx -> do 42 | _ <- assertSuccess $ test ctx ["up", "a"] 43 | _ <- assertSuccess $ test ctx ["up", "b"] 44 | result <- assertSuccess $ test ctx ["status"] 45 | result ^. #stdout 46 | `shouldBe` renderTable 47 | False 48 | [ [("name", "a"), ("status", "running")], 49 | [("name", "b"), ("status", "running")] 50 | ] 51 | 52 | it "lists all vms when some are running" $ do 53 | withMockContext ["a", "b"] $ \ctx -> do 54 | _ <- assertSuccess $ test ctx ["up", "a"] 55 | result <- assertSuccess $ test ctx ["status"] 56 | result ^. #stdout 57 | `shouldBe` renderTable 58 | False 59 | [ [("name", "a"), ("status", "running")], 60 | [("name", "b"), ("status", "not running")] 61 | ] 62 | 63 | it "lists all vms when none are running" $ do 64 | withMockContext ["a", "b"] $ \ctx -> do 65 | result <- assertSuccess $ test ctx ["status"] 66 | result ^. #stdout 67 | `shouldBe` renderTable 68 | False 69 | [ [("name", "a"), ("status", "not running")], 70 | [("name", "b"), ("status", "not running")] 71 | ] 72 | 73 | it "prints a nice message when no vms are configured" $ do 74 | withMockContext [] $ \ctx -> do 75 | result <- assertSuccess $ test ctx ["status"] 76 | result ^. #stdout `shouldBe` "no vms configured, no vms running\n" 77 | 78 | it "accepts multiple vm names" $ do 79 | withMockContext ["a", "b", "c"] $ \ctx -> do 80 | _ <- assertSuccess $ test ctx ["up", "a"] 81 | _ <- assertSuccess $ test ctx ["up", "b"] 82 | _ <- assertSuccess $ test ctx ["up", "c"] 83 | result <- assertSuccess $ test ctx ["status", "a", "c"] 84 | result ^. #stdout 85 | `shouldBe` renderTable 86 | False 87 | [ [("name", "a"), ("status", "running")], 88 | [("name", "c"), ("status", "running")] 89 | ] 90 | result <- assertSuccess $ test ctx ["status", "c", "b"] 91 | result ^. #stdout 92 | `shouldBe` renderTable 93 | False 94 | [ [("name", "c"), ("status", "running")], 95 | [("name", "b"), ("status", "running")] 96 | ] 97 | result <- assertSuccess $ test ctx ["status", "b", "d"] 98 | result ^. #stdout 99 | `shouldBe` renderTable 100 | False 101 | [ [("name", "b"), ("status", "running")], 102 | [("name", "d"), ("status", "not running")] 103 | ] 104 | 105 | it "removes the state directory when the vm process is not running anymore" $ do 106 | withMockContext ["a"] $ \ctx -> do 107 | _ <- assertSuccess $ test ctx ["up", "a"] 108 | stopProcess ctx (Vm "a") 109 | test ctx ["status", "a"] 110 | `shouldReturn` TestResult 111 | (renderTable False [[("name", "a"), ("status", "not running")]]) 112 | "WARN: cannot find process for vm: a\n" 113 | ExitSuccess 114 | listDirectory (ctx ^. #storageDir) `shouldReturn` ["state.json"] 115 | 116 | describe "running vms from other flake files" $ do 117 | let fakeVmState = 118 | State.Running 119 | { port = 8080, 120 | pid = 42, 121 | ip = IPv4.fromOctets 10 0 0 42 122 | } 123 | it "prints running vms when there's no configured vms in the local flake file" $ do 124 | withMockContext [] $ \ctx -> do 125 | State.modifyState_ ctx (pure . (#vms %~ Map.insert "other" fakeVmState)) 126 | result <- assertSuccess $ test ctx ["status"] 127 | result ^. #stdout `shouldBe` renderTable False [[("name", "other"), ("status", "running")]] 128 | 129 | it "prints running vms from other directories with configured vms" $ do 130 | withMockContext ["a"] $ \ctx -> do 131 | State.modifyState_ ctx (pure . (#vms %~ Map.insert "other" fakeVmState)) 132 | result <- assertSuccess $ test ctx ["status"] 133 | result ^. #stdout 134 | `shouldBe` renderTable 135 | False 136 | [ [("name", "a"), ("status", "not running")], 137 | [("name", "other"), ("status", "running")] 138 | ] 139 | 140 | describe "list" $ do 141 | it "lists all configured vms" $ do 142 | withMockContext ["a", "b", "c"] $ \ctx -> do 143 | result <- assertSuccess $ test ctx ["list"] 144 | result ^. #stdout 145 | `shouldBe` cs 146 | ( unindent 147 | [i| 148 | configured vms: 149 | - a 150 | - b 151 | - c 152 | |] 153 | ) 154 | 155 | it "has a nice message when no vms are configured" $ do 156 | withMockContext [] $ \ctx -> do 157 | result <- assertSuccess $ test ctx ["list"] 158 | result ^. #stdout `shouldBe` "no vms configured\n" 159 | 160 | describe "down" $ do 161 | it "stops vms" $ do 162 | withMockContext ["a"] $ \ctx -> do 163 | _ <- assertSuccess $ test ctx ["up", "a"] 164 | runningVms ctx `shouldReturn` ["a"] 165 | state <- fromJust <$> readVmState ctx "a" 166 | test ctx ["down", "a"] `shouldReturn` TestResult "stopping a\n" "" ExitSuccess 167 | runningVms ctx `shouldReturn` [] 168 | exist <- doesDirectoryExist ("/proc" show (fromJust $ State.getPid state)) 169 | when exist $ do 170 | status <- do 171 | contents <- T.readFile ("/proc" show (fromJust $ State.getPid state) "status") 172 | pure $ 173 | contents 174 | & T.lines 175 | & mapMaybe (T.stripPrefix "State:") 176 | & fmap T.strip 177 | status `shouldBe` ["Z (zombie)"] 178 | 179 | it "stops multiple specified vms" $ do 180 | withMockContext ["a", "b", "c"] $ \ctx -> do 181 | _ <- assertSuccess $ test ctx ["up", "a", "b", "c"] 182 | runningVms ctx `shouldReturn` ["a", "b", "c"] 183 | _ <- assertSuccess $ test ctx ["down", "a", "c"] 184 | runningVms ctx `shouldReturn` ["b"] 185 | 186 | it "stops all vms when no vm name given" $ do 187 | withMockContext ["a", "b"] $ \ctx -> do 188 | _ <- assertSuccess $ test ctx ["up", "a", "b"] 189 | runningVms ctx `shouldReturn` ["a", "b"] 190 | _ <- assertSuccess $ test ctx ["down"] 191 | runningVms ctx `shouldReturn` [] 192 | 193 | it "prints a nice message when no vm names are given and no vms are running" $ do 194 | withMockContext ["a", "b"] $ \ctx -> do 195 | (stderr <$> assertSuccess (test ctx ["down"])) `shouldReturn` "no vms running, nothing to do\n" 196 | 197 | it "prints a nice message when the specified vms are not running" $ do 198 | withMockContext ["a", "b"] $ \ctx -> do 199 | _ <- assertSuccess $ test ctx ["up", "a"] 200 | (stdout <$> assertSuccess (test ctx ["down", "b"])) `shouldReturn` "b is not running, nothing to do\n" 201 | 202 | describe "ssh" $ do 203 | let cases = 204 | [ (["true"], ExitSuccess), 205 | (["false"], ExitFailure 1), 206 | (["--", "bash", "-c", "'exit 42'"], ExitFailure 42) 207 | ] 208 | forM_ cases $ \(command, exitCode) -> 209 | it ("relays the exit code " <> show exitCode) $ do 210 | withMockContext ["a"] $ \ctx -> do 211 | _ <- assertSuccess $ test ctx ["up", "a"] 212 | result <- test ctx (["ssh", "a"] <> command) 213 | result 214 | `shouldBe` TestResult 215 | { exitCode, 216 | stdout = "", 217 | stderr = "" 218 | } 219 | 220 | it "handles non-existing VMs gracefully" $ do 221 | withMockContext [] $ \ctx -> do 222 | result <- test ctx ["ssh", "a"] 223 | result 224 | `shouldBe` TestResult 225 | { exitCode = ExitFailure 1, 226 | stdout = "", 227 | stderr = "vm 'a' is not running\n" 228 | } 229 | -------------------------------------------------------------------------------- /spec/TapSpec.hs: -------------------------------------------------------------------------------- 1 | module TapSpec where 2 | 3 | import Context 4 | import Cradle qualified 5 | import Data.Maybe (isJust) 6 | import Data.String.Interpolate (i) 7 | import Data.String.Interpolate.Util (unindent) 8 | import Data.Text qualified as T 9 | import Data.Text.IO qualified as T 10 | import State (readState) 11 | import StdLib 12 | import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeFile) 13 | import System.Environment (getEnv) 14 | import System.IO.Temp (withSystemTempDirectory) 15 | import System.Posix (sigKILL, signalProcess) 16 | import System.Process 17 | import Table (renderTable) 18 | import Test.Hspec 19 | import Test.Mockery.Environment (withModifiedEnvironment) 20 | import TestUtils 21 | import Utils (which) 22 | import Vde qualified 23 | 24 | spec :: Spec 25 | spec = do 26 | describe "tap" $ do 27 | it "allows connecting with vms from the host by ip address" $ do 28 | withMockContext ["server"] $ \ctx -> do 29 | withMockSudo $ \getMockSudoCalls -> do 30 | _ <- assertSuccess $ test ctx ["up", "server"] 31 | _ <- assertSuccess $ test ctx ["tap"] 32 | expected <- expectedCommands ctx 33 | getMockSudoCalls `shouldReturn` unlines (fmap unwords expected) 34 | 35 | it "prints a nice message when `sudo` is not in the `$PATH`" $ do 36 | sudo <- which "sudo" 37 | case sudo of 38 | Just _ -> do 39 | pendingWith "this test relies on `sudo` *not* being in the path" 40 | Nothing -> pure () 41 | withMockContext ["server"] $ \ctx -> do 42 | _ <- assertSuccess $ test ctx ["up", "server"] 43 | expectedStdout <- expectedCommands ctx 44 | test ctx ["tap"] 45 | `shouldReturn` TestResult 46 | (cs $ unlines $ fmap unwords expectedStdout) 47 | "`sudo` not found in the $PATH, cannot create `tap` device.\nYou can run the following commands with elevated privileges to create it manually:\n\n" 48 | (ExitFailure 1) 49 | 50 | it "allows starting tap before starting vms" $ do 51 | withMockContext ["server"] $ \ctx -> do 52 | withMockSudo $ \getMockSudoCalls -> do 53 | _ <- assertSuccess $ test ctx ["tap"] 54 | expected <- expectedCommands ctx 55 | getMockSudoCalls `shouldReturn` unlines (fmap unwords expected) 56 | state <- readState ctx 57 | state ^. #vde `shouldSatisfy` isJust 58 | _ <- assertSuccess $ test ctx ["up", "server"] 59 | pure () 60 | 61 | it "handles double starting the tap device gracefully" $ do 62 | withMockContext [] $ \ctx -> do 63 | withMockSudo $ \getMockSudoCalls -> do 64 | _ <- assertSuccess $ test ctx ["tap"] 65 | _ <- getMockSudoCalls 66 | test ctx ["tap"] `shouldReturn` TestResult "tap device already running\n" "" ExitSuccess 67 | getMockSudoCalls `shouldReturn` "" 68 | 69 | it "allows removing the tap device with vms running" $ do 70 | withMockContext ["server"] $ \ctx -> do 71 | withMockSudo $ \getMockSudoCalls -> do 72 | _ <- assertSuccess $ test ctx ["tap"] 73 | tapPid <- getTapPid ctx 74 | _ <- getMockSudoCalls 75 | _ <- assertSuccess $ test ctx ["up", "server"] 76 | _ <- assertSuccess $ test ctx ["tap", "--remove"] 77 | getMockSudoCalls `shouldReturn` ("kill -15 " <> show tapPid <> "\n") 78 | 79 | it "allows removing the tap device with no vms running" $ do 80 | withMockContext ["server"] $ \ctx -> do 81 | withMockSudo $ \getMockSudoCalls -> do 82 | _ <- assertSuccess $ test ctx ["tap"] 83 | tapPid <- getTapPid ctx 84 | _ <- getMockSudoCalls 85 | _ <- assertSuccess $ test ctx ["tap", "--remove"] 86 | getMockSudoCalls `shouldReturn` ("kill -15 " <> show tapPid <> "\n") 87 | 88 | it "allows re-starting the tap device after e.g. a reboot" $ do 89 | withMockContext [] $ \ctx -> do 90 | withMockSudo $ \getMockSudoCalls -> do 91 | _ <- assertSuccess $ test ctx ["tap"] 92 | _ <- getMockSudoCalls 93 | tapPid <- getTapPid ctx 94 | signalProcess sigKILL tapPid 95 | waitFor $ do 96 | doesDirectoryExist ("/proc/" <> show (tapPid :: ProcessID)) `shouldReturn` False 97 | _ <- assertSuccess $ test ctx ["tap"] 98 | expected <- expectedCommands ctx 99 | getMockSudoCalls `shouldReturn` unlines (fmap unwords expected) 100 | 101 | context "--dry-run" $ do 102 | it "has a --dry-run mode" $ do 103 | withMockContext ["server"] $ \ctx -> do 104 | withMockSudo $ \getMockSudoCalls -> do 105 | _ <- assertSuccess $ test ctx ["up", "server"] 106 | expectedStderr <- expectedCommands ctx 107 | result <- test ctx ["tap", "--dry-run"] 108 | getMockSudoCalls `shouldReturn` [] 109 | result 110 | `shouldBe` TestResult 111 | (cs $ unlines $ fmap unwords expectedStderr) 112 | "Would run the following commands:\n\n" 113 | ExitSuccess 114 | 115 | it "allows showing removal commands with --dry-run" $ do 116 | withMockContext ["server"] $ \ctx -> do 117 | withMockSudo $ \getMockSudoCalls -> do 118 | _ <- assertSuccess $ test ctx ["tap"] 119 | _ <- getMockSudoCalls 120 | tapPid <- getTapPid ctx 121 | result <- test ctx ["tap", "--remove", "--dry-run"] 122 | getMockSudoCalls `shouldReturn` [] 123 | result 124 | `shouldBe` TestResult 125 | ("kill -15 " <> cs (show tapPid) <> "\n") 126 | "Would run the following commands:\n\n" 127 | ExitSuccess 128 | 129 | describe "status output" $ do 130 | it "shows ip addresses when the tap device is up, when no vm name is given" $ do 131 | withMockContext ["server"] $ \ctx -> do 132 | withMockSudo $ \_getMockSudoCalls -> do 133 | _ <- assertSuccess $ test ctx ["up", "server"] 134 | _ <- assertSuccess $ test ctx ["tap"] 135 | result <- assertSuccess $ test ctx ["status"] 136 | result ^. #stdout 137 | `shouldBe` T.unlines 138 | [ T.stripEnd $ 139 | renderTable 140 | False 141 | [ [("name", "server"), ("status", "running"), ("ip", "10.0.0.2")] 142 | ], 143 | "(The tap device 'nixos-compose0' is up.)" 144 | ] 145 | 146 | it "shows ip addresses when the tap device is up, when a vm name is given" $ do 147 | withMockContext ["server"] $ \ctx -> do 148 | withMockSudo $ \_getMockSudoCalls -> do 149 | _ <- assertSuccess $ test ctx ["up", "server"] 150 | _ <- assertSuccess $ test ctx ["tap"] 151 | result <- assertSuccess $ test ctx ["status", "server"] 152 | result ^. #stdout 153 | `shouldBe` T.unlines 154 | [ T.stripEnd $ 155 | renderTable 156 | False 157 | [ [("name", "server"), ("status", "running"), ("ip", "10.0.0.2")] 158 | ], 159 | "(The tap device 'nixos-compose0' is up.)" 160 | ] 161 | 162 | it "shows when the tap device is up, and no vms are configured or running" $ do 163 | withMockContext [] $ \ctx -> do 164 | withMockSudo $ \_getMockSudoCalls -> do 165 | _ <- assertSuccess $ test ctx ["tap"] 166 | result <- assertSuccess $ test ctx ["status"] 167 | result ^. #stdout 168 | `shouldBe` T.unlines 169 | [ "no vms configured, no vms running", 170 | "(The tap device 'nixos-compose0' is up.)" 171 | ] 172 | 173 | withMockSudo :: (IO String -> IO a) -> IO a 174 | withMockSudo action = do 175 | withSystemTempDirectory "mock-sudo" $ \mockSudoDir -> do 176 | let mockSudoBinDir = mockSudoDir "bin" 177 | let mockSudoPath = mockSudoBinDir "sudo" 178 | createDirectoryIfMissing True mockSudoBinDir 179 | T.writeFile 180 | mockSudoPath 181 | ( T.strip $ 182 | cs $ 183 | unindent 184 | [i| 185 | #!/usr/bin/env python3 186 | 187 | import subprocess 188 | import sys 189 | 190 | args = " ".join(sys.argv[1:]) 191 | with open("#{mockSudoDir}/calls", "a") as calls: 192 | calls.write(args + "\\n") 193 | try: 194 | pidFileFlagIndex = sys.argv.index("--pidfile") 195 | except ValueError: 196 | pidFileFlagIndex = None 197 | if pidFileFlagIndex is not None: 198 | pidFile = sys.argv[pidFileFlagIndex + 1] 199 | process = subprocess.Popen(["sleep", "inf"]) 200 | with open(pidFile, "w") as file: 201 | file.write(str(process.pid)) 202 | |] 203 | ) 204 | Cradle.run_ $ Cradle.cmd "chmod" & Cradle.addArgs ["+x", mockSudoPath] 205 | pathWithMockSudo <- 206 | getEnv "PATH" 207 | <&> ((mockSudoBinDir <> ":") <>) 208 | withModifiedEnvironment [("PATH", pathWithMockSudo)] $ do 209 | let getCalls = do 210 | exists <- doesFileExist (mockSudoDir "calls") 211 | if exists 212 | then do 213 | calls <- cs <$> T.readFile (mockSudoDir "calls") 214 | removeFile (mockSudoDir "calls") 215 | pure calls 216 | else pure "" 217 | action getCalls 218 | 219 | expectedCommands :: Context -> IO [[String]] 220 | expectedCommands ctx = do 221 | Paths {vde_plug2tap, ip, vdeCtlDir, pidFile} <- getPaths ctx 222 | pure 223 | [ [vde_plug2tap, "--daemon", "--pidfile", pidFile, "--sock", vdeCtlDir, "nixos-compose0"], 224 | [ip, "addr", "add", "10.0.0.1/24", "dev", "nixos-compose0"], 225 | [ip, "link", "set", "nixos-compose0", "up"] 226 | ] 227 | 228 | getTapPid :: Context -> IO Pid 229 | getTapPid ctx = do 230 | Paths {pidFile} <- getPaths ctx 231 | content <- readFile pidFile 232 | pure $ read content 233 | 234 | data Paths = Paths 235 | { vde_plug2tap :: FilePath, 236 | ip :: FilePath, 237 | vdeCtlDir :: FilePath, 238 | pidFile :: FilePath 239 | } 240 | 241 | getPaths :: Context -> IO Paths 242 | getPaths ctx = do 243 | vde_plug2tap <- 244 | which "vde_plug2tap" 245 | <&> fromMaybe (error "vde_plug2tap not found in PATH") 246 | ip <- 247 | which "ip" 248 | <&> fromMaybe (error "ip not found in PATH") 249 | vdeCtlDir <- Vde.getVdeCtlDir ctx 250 | let pidFile = storageDir ctx "vde_plug2tap.pid" 251 | pure $ Paths {vde_plug2tap, ip, vdeCtlDir, pidFile} 252 | -------------------------------------------------------------------------------- /spec/IntegrationSpec.hs: -------------------------------------------------------------------------------- 1 | module IntegrationSpec (spec) where 2 | 3 | import Context 4 | import Cradle qualified 5 | import Data.ByteString qualified as B 6 | import Data.Maybe (fromJust) 7 | import Data.String.Conversions 8 | import Data.String.Interpolate (i) 9 | import Data.Text qualified as T 10 | import Data.Text.IO qualified as T 11 | import NixVms qualified 12 | import State (getPid, readVmState) 13 | import StdLib 14 | import System.Directory (copyFile, doesDirectoryExist, getCurrentDirectory, listDirectory) 15 | import System.IO (SeekMode (..), hSeek) 16 | import Table (renderTable) 17 | import Test.Hspec 18 | import Test.Hspec.Golden (defaultGolden) 19 | import Test.Mockery.Directory (inTempDirectory) 20 | import TestUtils 21 | 22 | spec :: Spec 23 | spec = do 24 | around_ inTempDirectory $ around (withContext NixVms.production) $ do 25 | it "lists vms" $ \ctx -> do 26 | writeFile 27 | (workingDir ctx "flake.nix") 28 | [i| 29 | { 30 | inputs.nixpkgs.url = "github:nixos/nixpkgs/#{nixpkgs2505Commit}"; 31 | outputs = { nixpkgs, ... }: { 32 | nixosConfigurations.a = (nixpkgs.lib.nixosSystem { 33 | modules = [ 34 | { 35 | networking.hostName = "a"; 36 | nixpkgs.hostPlatform = "x86_64-linux"; 37 | system.stateVersion = "25.05"; 38 | } 39 | ]; 40 | }); 41 | nixosConfigurations.b = (nixpkgs.lib.nixosSystem { 42 | modules = [ 43 | { 44 | networking.hostName = "b"; 45 | nixpkgs.hostPlatform = "x86_64-linux"; 46 | system.stateVersion = "25.05"; 47 | } 48 | ]; 49 | }); 50 | nixosConfigurations.c = (nixpkgs.lib.nixosSystem { 51 | modules = [ 52 | { 53 | networking.hostName = "c"; 54 | nixpkgs.hostPlatform = "x86_64-linux"; 55 | system.stateVersion = "25.05"; 56 | } 57 | ]; 58 | }); 59 | }; 60 | } 61 | |] 62 | result <- assertSuccess $ test ctx ["list"] 63 | result ^. #stdout `shouldBe` "configured vms:\n - a\n - b\n - c\n" 64 | 65 | it "lists vms when there's no `nixosConfigurations` field" $ \ctx -> do 66 | writeFile 67 | (workingDir ctx "flake.nix") 68 | [i| 69 | { 70 | inputs.nixpkgs.url = "github:nixos/nixpkgs/#{nixpkgs2505Commit}"; 71 | outputs = { nixpkgs, ... }: { }; 72 | } 73 | |] 74 | result <- assertSuccess $ test ctx ["list"] 75 | result ^. #stdout `shouldBe` "no vms configured\n" 76 | 77 | it "starts vms" $ \ctx -> do 78 | writeStandardFlake ctx Nothing 79 | _ <- assertSuccess $ test ctx ["up", "server", "--verbose"] 80 | (stdout <$> assertSuccess (test ctx ["ssh", "server", "hostname"])) `shouldReturn` "server\n" 81 | (stdout <$> assertSuccess (test ctx ["status", "server"])) `shouldReturn` renderTable False [[("name", "server"), ("status", "running")]] 82 | 83 | it "has nice output when starting vms" $ \ctx -> do 84 | writeStandardFlake ctx Nothing 85 | result <- assertSuccess $ test ctx ["up", "server"] 86 | stdout result `shouldBe` "" 87 | stderr result 88 | `shouldBe` T.unlines 89 | [ "server: building...", 90 | "server: done building", 91 | "server: booting...", 92 | "server: done booting" 93 | ] 94 | 95 | it "has nice output when the nix build fails" $ \ctx -> do 96 | writeStandardFlake ctx Nothing 97 | result <- test ctx ["up", "does-not-exist"] 98 | result ^. #exitCode `shouldBe` ExitFailure 1 99 | stdout result `shouldBe` "" 100 | cs (stderr result) `shouldContain` "does-not-exist: building...\nCommand exited with code 1" 101 | cs (stderr result) `shouldContain` "does not provide attribute 'packages.x86_64-linux.nixosConfigurations.\"does-not-exist\"" 102 | 103 | it "starts vms with arbitrary hostnames" $ \ctx -> do 104 | writeStandardFlake ctx (Just "{ lib, ...} : { networking.hostName = lib.mkForce \"other-hostname\"; }") 105 | _ <- assertSuccess $ test ctx ["up", "server"] 106 | pure () 107 | 108 | it "starts a shell by default" $ \ctx -> do 109 | writeStandardFlake ctx Nothing 110 | _ <- assertSuccess $ test ctx ["up", "server"] 111 | B.hPutStr (ctx ^. #stdin) "echo foo\nexit\n" 112 | hSeek (ctx ^. #stdin) AbsoluteSeek 0 113 | (stdout <$> assertSuccess (test ctx ["ssh", "server"])) `shouldReturn` "foo\n\ESC]0;\a" 114 | 115 | it "can start multiple vms" $ \ctx -> do 116 | writeFile 117 | (workingDir ctx "flake.nix") 118 | [i| 119 | { 120 | inputs.nixpkgs.url = "github:nixos/nixpkgs/#{nixpkgs2505Commit}"; 121 | outputs = { nixpkgs, ... }: { 122 | nixosConfigurations.a = (nixpkgs.lib.nixosSystem { 123 | modules = [ 124 | { 125 | networking.hostName = "a"; 126 | nixpkgs.hostPlatform = "x86_64-linux"; 127 | system.stateVersion = "25.05"; 128 | } 129 | ]; 130 | }); 131 | nixosConfigurations.b = (nixpkgs.lib.nixosSystem { 132 | modules = [ 133 | { 134 | networking.hostName = "b"; 135 | nixpkgs.hostPlatform = "x86_64-linux"; 136 | system.stateVersion = "25.05"; 137 | } 138 | ]; 139 | }); 140 | }; 141 | } 142 | |] 143 | _ <- assertSuccess $ test ctx ["up", "a", "b"] 144 | (stdout <$> assertSuccess (test ctx ["ssh", "a", "hostname"])) `shouldReturn` "a\n" 145 | (stdout <$> assertSuccess (test ctx ["ssh", "b", "hostname"])) `shouldReturn` "b\n" 146 | 147 | it "works if openssh is configured to listen on a different port" $ \ctx -> do 148 | writeFile 149 | (workingDir ctx "flake.nix") 150 | [i| 151 | { 152 | inputs.nixpkgs.url = "github:nixos/nixpkgs/#{nixpkgs2505Commit}"; 153 | outputs = { nixpkgs, ... }: { 154 | nixosConfigurations.a = (nixpkgs.lib.nixosSystem { 155 | modules = [ 156 | { 157 | networking.hostName = "a"; 158 | nixpkgs.hostPlatform = "x86_64-linux"; 159 | system.stateVersion = "25.05"; 160 | services.openssh.ports = [ 2222 ]; 161 | } 162 | ]; 163 | }); 164 | }; 165 | } 166 | |] 167 | _ <- assertSuccess $ test ctx ["up", "a"] 168 | (stdout <$> assertSuccess (test ctx ["ssh", "a", "hostname"])) `shouldReturn` "a\n" 169 | 170 | it "can stop vms" $ \ctx -> do 171 | writeStandardFlake ctx Nothing 172 | _ <- assertSuccess $ test ctx ["up", "server"] 173 | (stdout <$> assertSuccess (test ctx ["status", "server"])) `shouldReturn` renderTable False [[("name", "server"), ("status", "running")]] 174 | state <- fromJust <$> readVmState ctx "server" 175 | _ <- assertSuccess $ test ctx ["down", "server"] 176 | (stdout <$> assertSuccess (test ctx ["status", "server"])) `shouldReturn` renderTable False [[("name", "server"), ("status", "not running")]] 177 | exist <- doesDirectoryExist ("/proc" show (fromJust $ getPid state)) 178 | when exist $ do 179 | status <- do 180 | contents <- T.readFile ("/proc" show (fromJust $ getPid state) "status") 181 | pure $ 182 | contents 183 | & T.lines 184 | & mapMaybe (T.stripPrefix "State:") 185 | & fmap T.strip 186 | status `shouldBe` ["Z (zombie)"] 187 | 188 | it "doesn't complain when starting a vm twice" $ \ctx -> do 189 | writeStandardFlake ctx Nothing 190 | _ <- assertSuccess $ test ctx ["up", "server"] 191 | result <- assertSuccess $ test ctx ["up", "server"] 192 | result ^. #stdout `shouldBe` "server: already running\n" 193 | 194 | it "allows mounting the repo root using the NIXOS_COMPOSE_FLAKE_DIR environment variable" $ \ctx -> do 195 | writeFile (workingDir ctx "foo") "bar" 196 | writeFile 197 | (workingDir ctx "flake.nix") 198 | [i| 199 | { 200 | inputs.nixpkgs.url = "github:nixos/nixpkgs/#{nixpkgs2505Commit}"; 201 | outputs = { nixpkgs, ... }: { 202 | nixosConfigurations.server = (nixpkgs.lib.nixosSystem { 203 | modules = [ 204 | { 205 | networking.hostName = "server"; 206 | nixpkgs.hostPlatform = "x86_64-linux"; 207 | system.stateVersion = "25.05"; 208 | virtualisation.vmVariant.virtualisation.sharedDirectories.test = { 209 | source = "$NIXOS_COMPOSE_FLAKE_DIR"; 210 | target = "/mnt"; 211 | }; 212 | } 213 | ]; 214 | }); 215 | }; 216 | } 217 | |] 218 | _ <- assertSuccess $ test ctx ["up", "server"] 219 | (stdout <$> assertSuccess (test ctx ["ssh", "server", "sudo cat /mnt/foo"])) `shouldReturn` "bar" 220 | 221 | it "does not output device status report ansi sequences" $ \ctx -> do 222 | writeStandardFlake ctx Nothing 223 | result <- assertSuccess $ test ctx ["up", "server", "-v"] 224 | result ^. #stdout `shouldNotSatisfy` ("\ESC[6n" `T.isInfixOf`) 225 | 226 | describe "networking" $ do 227 | repoRoot <- runIO getCurrentDirectory 228 | it "allows talking from one vm to the other by static ip" $ \ctx -> do 229 | copyFile (repoRoot "spec/static-ips/flake.nix") (workingDir ctx "flake.nix") 230 | _ <- assertSuccess $ test ctx ["up", "a", "b"] 231 | aIp <- T.strip . stdout <$> assertSuccess (test ctx ["ip", "a"]) 232 | bIp <- T.strip . stdout <$> assertSuccess (test ctx ["ip", "b"]) 233 | result <- assertSuccess $ test ctx ["ssh", "a", "ping -c 1 " <> bIp] 234 | result ^. #stdout `shouldSatisfy` ("1 received" `T.isInfixOf`) 235 | result <- assertSuccess $ test ctx ["ssh", "b", "ping -c 1 " <> aIp] 236 | result ^. #stdout `shouldSatisfy` ("1 received" `T.isInfixOf`) 237 | 238 | it "allows connecting to VMs by their name" $ \ctx -> do 239 | copyFile (repoRoot "spec/domains/flake.nix") (workingDir ctx "flake.nix") 240 | _ <- assertSuccess $ test ctx ["up", "server", "client"] 241 | result <- assertSuccess $ test ctx ["ssh", "client", "fetch-from-server"] 242 | result ^. #stdout `shouldBe` "hello from nginx" 243 | 244 | context "not inside a temporary working dir (for hspec-golden)" $ do 245 | it "stores the qcow2 image and other files in the storage dir" $ do 246 | stdout <- inTempDirectory $ do 247 | TestUtils.withContext NixVms.production $ \ctx -> do 248 | writeStandardFlake ctx Nothing 249 | _ <- assertSuccess $ test ctx ["up", "server"] 250 | files <- listDirectory "." 251 | files `shouldBe` [] 252 | Cradle.StdoutRaw stdout <- Cradle.run $ Cradle.cmd "tree" & Cradle.setWorkingDir (ctx ^. #storageDir) 253 | pure stdout 254 | pure $ defaultGolden "storage-tree" (cs stdout) 255 | 256 | writeStandardFlake :: Context -> Maybe Text -> IO () 257 | writeStandardFlake ctx addedModule = do 258 | let emptyModule = "{}" 259 | let flake = 260 | cs 261 | [i| 262 | { 263 | inputs.nixpkgs.url = "github:nixos/nixpkgs/#{nixpkgs2505Commit}"; 264 | outputs = { nixpkgs, ... }: { 265 | nixosConfigurations.server = (nixpkgs.lib.nixosSystem { 266 | modules = [ 267 | { 268 | networking.hostName = "server"; 269 | nixpkgs.hostPlatform = "x86_64-linux"; 270 | system.stateVersion = "25.05"; 271 | } 272 | (#{fromMaybe emptyModule addedModule}) 273 | ]; 274 | }); 275 | }; 276 | } 277 | |] 278 | T.writeFile (ctx ^. #workingDir "flake.nix") flake 279 | 280 | nixpkgs2505Commit :: Text 281 | nixpkgs2505Commit = "3ff0e34b1383648053bba8ed03f201d3466f90c9" 282 | -------------------------------------------------------------------------------- /spec/UpSpec.hs: -------------------------------------------------------------------------------- 1 | module UpSpec where 2 | 3 | import Context 4 | import Control.Concurrent (MVar, modifyMVar_, myThreadId, newEmptyMVar, newMVar, putMVar, readMVar, threadDelay, throwTo) 5 | import Control.Exception (AsyncException (..)) 6 | import Control.Monad (forever) 7 | import Cradle 8 | import Data.Maybe (fromJust) 9 | import Data.Set (Set) 10 | import Data.Set qualified as Set 11 | import Data.Text qualified as T 12 | import Data.Text.IO qualified as T 13 | import Ki qualified 14 | import Net.IPv4 qualified as IPv4 15 | import State (VmState (..), readState, readVmState) 16 | import StdLib 17 | import System.Console.ANSI (Color (..), ColorIntensity (..), ConsoleLayer (..), SGR (..), setSGRCode) 18 | import System.IO qualified 19 | import System.Process (CreateProcess (..), StdStream (..), createProcess, proc) 20 | import Table (renderTable) 21 | import Test.Hspec 22 | import TestUtils 23 | 24 | spec :: Spec 25 | spec = do 26 | it "starts a vm" $ do 27 | withMockContext ["a"] $ \ctx -> do 28 | result <- assertSuccess $ test ctx ["up", "a"] 29 | result ^. #stderr `shouldBe` "a: building...\na: done building\na: booting...\na: done booting\n" 30 | 31 | it "starts vms in parallel" $ do 32 | let vmNames = ["a", "b", "c"] 33 | buildVmBarrier <- newBarrier (length vmNames) 34 | sshVmBarrier <- newBarrier (length vmNames) 35 | let mockNixVms = 36 | NixVms 37 | { listVms = \_ctx -> pure vmNames, 38 | buildVmScript = \_ctx _handle _vmName _ip -> do 39 | waitBarrier buildVmBarrier 40 | pure ("/fake-vm-script", 1234), 41 | runVm = 42 | \_ctx _handle _vmName _vmScript -> do 43 | (_, _, _, ph) <- do 44 | createProcess 45 | (proc "sleep" ["inf"]) 46 | { std_in = NoStream, 47 | std_out = NoStream, 48 | std_err = NoStream 49 | } 50 | pure ph, 51 | sshIntoVm = SshIntoVm $ \_ctx _vmName _port _command -> do 52 | waitBarrier sshVmBarrier 53 | Cradle.run $ Cradle.cmd "true", 54 | updateVmHostsEntry = \_ctx _vmName _port _hostName _ip -> pure () 55 | } 56 | withContext mockNixVms $ \ctx -> do 57 | result <- assertSuccess $ test ctx ["up"] 58 | groupIntoSets [3, 6, 3] (T.lines $ result ^. #stderr) 59 | `shouldBe` map 60 | Set.fromList 61 | [ ["a: building...", "b: building...", "c: building..."], 62 | [ "a: done building", 63 | "a: booting...", 64 | "b: done building", 65 | "b: booting...", 66 | "c: done building", 67 | "c: booting..." 68 | ], 69 | ["a: done booting", "b: done booting", "c: done booting"] 70 | ] 71 | 72 | context "when no vm names are given" $ do 73 | it "starts all vms" $ do 74 | withMockContext ["a", "b", "c"] $ \ctx -> do 75 | _ <- assertSuccess $ test ctx ["up"] 76 | runningVms ctx `shouldReturn` ["a", "b", "c"] 77 | 78 | it "gives a nice message when no vms are defined" $ do 79 | withMockContext [] $ \ctx -> do 80 | result <- test ctx ["up"] 81 | result `shouldBe` TestResult "" "No vms are defined. Nothing to do.\n" (ExitFailure 1) 82 | 83 | describe "vm building state" $ do 84 | context "when the nix build blocks" $ do 85 | let blockingBuildVmScript :: Context -> Context 86 | blockingBuildVmScript = 87 | (#nixVms . #buildVmScript) 88 | .~ ( \_ctx _handle _vmName _ip -> do 89 | forever $ threadDelay 1_000_000 90 | ) 91 | it "locks the state of a vm when building the nixos config" $ do 92 | withMockContext ["a"] $ \(blockingBuildVmScript -> ctx) -> do 93 | Ki.scoped $ \scope -> do 94 | _ <- Ki.fork scope $ do 95 | test ctx ["up", "a"] 96 | waitFor $ do 97 | vmState <- fromJust <$> readVmState ctx "a" 98 | vmState `shouldBe` Building {ip = IPv4.fromOctets 10 0 0 2} 99 | test ctx ["up", "a"] `shouldReturn` TestResult "a: already building\n" "" ExitSuccess 100 | test ctx ["status", "a"] `shouldReturn` TestResult (renderTable False [[("name", "a"), ("status", "building")]]) "" ExitSuccess 101 | test ctx ["ip", "a"] `shouldReturn` TestResult "10.0.0.2\n" "" ExitSuccess 102 | 103 | it "handles attempts to stop building vms gracefully" $ do 104 | withMockContext ["a"] $ \(blockingBuildVmScript -> ctx) -> do 105 | Ki.scoped $ \scope -> do 106 | _ <- Ki.fork scope $ do 107 | test ctx ["up", "a"] 108 | waitFor $ do 109 | test ctx ["down", "a"] 110 | `shouldReturn` TestResult 111 | { stdout = "", 112 | stderr = "a: building, cannot stop a building vm\n", 113 | exitCode = ExitFailure 1 114 | } 115 | 116 | it "locks the state of a vm when booting" $ do 117 | let blockingRunVm :: Context -> Context 118 | blockingRunVm = 119 | (#nixVms . #runVm) 120 | .~ ( \_ctx _handle _vmName _vmScript -> do 121 | forever $ threadDelay 1_000_000 122 | ) 123 | withMockContext ["a"] $ \(blockingRunVm -> ctx) -> do 124 | Ki.scoped $ \scope -> do 125 | _ <- Ki.fork scope $ do 126 | test ctx ["up", "a"] 127 | waitFor $ do 128 | vmState <- fromJust <$> readVmState ctx "a" 129 | vmState `shouldBe` Booting {ip = IPv4.fromOctets 10 0 0 2} 130 | test ctx ["up", "a"] `shouldReturn` TestResult "a: already booting\n" "" ExitSuccess 131 | test ctx ["status", "a"] `shouldReturn` TestResult (renderTable False [[("name", "a"), ("status", "booting")]]) "" ExitSuccess 132 | test ctx ["ip", "a"] `shouldReturn` TestResult "10.0.0.2\n" "" ExitSuccess 133 | 134 | describe "when nix evaluation fails" $ do 135 | let failingBuildVmScript :: Context -> Context 136 | failingBuildVmScript = 137 | #nixVms 138 | . #buildVmScript 139 | .~ ( \_ctx _handle _vmName _ip -> do 140 | T.hPutStrLn System.IO.stderr "test output" 141 | exitWith $ ExitFailure 42 142 | ) 143 | it "prints out the error message" $ do 144 | withMockContext ["a"] $ \(failingBuildVmScript -> ctx) -> do 145 | test ctx ["up", "a"] `shouldReturn` TestResult "" "a: building...\ntest output\n" (ExitFailure 42) 146 | 147 | it "doesn't add a vm to the state" $ do 148 | withMockContext ["a"] $ \(failingBuildVmScript -> ctx) -> do 149 | test ctx ["up", "a"] `shouldReturn` TestResult "" "a: building...\ntest output\n" (ExitFailure 42) 150 | (^. #vms) <$> readState ctx `shouldReturn` mempty 151 | (^. #vde) <$> readState ctx `shouldReturn` Nothing 152 | 153 | it "doesn't add a vm to the state when interrupted by an async exception, e.g. Ctrl-C" $ do 154 | blockingOnBuild <- newEmptyMVar 155 | let blockingBuildVmScript :: Context -> Context 156 | blockingBuildVmScript = 157 | (#nixVms . #buildVmScript) 158 | .~ ( \_ctx _handle _vmName _ip -> do 159 | putMVar blockingOnBuild () 160 | forever $ threadDelay 1_000_000 161 | ) 162 | withMockContext ["a"] $ \(blockingBuildVmScript -> ctx) -> do 163 | Ki.scoped $ \scope -> do 164 | threadId <- newEmptyMVar 165 | _ <- Ki.fork scope $ do 166 | myThreadId >>= putMVar threadId 167 | test ctx ["up", "a"] 168 | readMVar blockingOnBuild 169 | threadId <- readMVar threadId 170 | throwTo threadId UserInterrupt 171 | waitFor $ do 172 | (^. #vms) <$> readState ctx `shouldReturn` mempty 173 | (^. #vde) <$> readState ctx `shouldReturn` Nothing 174 | 175 | describe "when the vm script terminates unexpectedly" $ do 176 | let failingRunVm :: Int -> Context -> Context 177 | failingRunVm exitCode context = 178 | context 179 | & (#nixVms . #runVm) 180 | .~ ( \_ctx handle _vmName _vmScript -> do 181 | T.hPutStrLn handle "test output" 182 | (_, _, _, ph) <- do 183 | createProcess 184 | (proc "bash" ["-c", "sleep 0.01; exit " <> show exitCode]) 185 | { std_in = NoStream, 186 | std_out = NoStream, 187 | std_err = NoStream 188 | } 189 | pure ph 190 | ) 191 | & (#nixVms . #sshIntoVm) 192 | .~ SshIntoVm 193 | ( \_ctx _vmName _port _command -> do 194 | threadDelay 10_000 195 | Cradle.run $ 196 | Cradle.cmd "bash" 197 | & Cradle.addArgs ["-c", "exit 255" :: Text] 198 | ) 199 | 200 | it "shows the script output, when the script fails" $ do 201 | withMockContext ["a"] $ \(failingRunVm 42 -> ctx) -> do 202 | test ctx ["up", "a"] 203 | `shouldReturn` TestResult 204 | "" 205 | ( T.unlines 206 | [ "a: building...", 207 | "a: done building", 208 | "a: booting...", 209 | "VM failed to start:", 210 | "", 211 | "test output" 212 | ] 213 | ) 214 | (ExitFailure 42) 215 | 216 | it "shows the script output, when the script exits with exit code 0" $ do 217 | withMockContext ["a"] $ \(failingRunVm 0 -> ctx) -> do 218 | test ctx ["up", "a"] 219 | `shouldReturn` TestResult 220 | "" 221 | ( T.unlines 222 | [ "a: building...", 223 | "a: done building", 224 | "a: booting...", 225 | "VM failed to start:", 226 | "", 227 | "test output" 228 | ] 229 | ) 230 | (ExitFailure 1) 231 | 232 | it "shows the script output, with --verbose" $ do 233 | withMockContext ["a"] $ \(failingRunVm 42 -> ctx) -> do 234 | test ctx ["up", "a", "--verbose"] 235 | `shouldReturn` TestResult 236 | "" 237 | ( T.unlines 238 | [ "a: building...", 239 | "a: done building", 240 | "a: booting...", 241 | "a> test output", 242 | "VM failed to start" 243 | ] 244 | ) 245 | (ExitFailure 42) 246 | 247 | it "cleans up the state.json file" $ do 248 | withMockContext ["a"] $ \(failingRunVm 0 -> ctx) -> do 249 | _ <- test ctx ["up", "a"] 250 | state <- readState ctx 251 | state ^. #vms `shouldBe` mempty 252 | state ^. #vde `shouldBe` Nothing 253 | 254 | describe "verbosity" $ do 255 | context "with default verbosity" $ do 256 | it "does not print the boot logs" $ do 257 | withMockContext ["a"] $ \(withLogMessage (Msg Boot "test boot message") -> ctx) -> do 258 | result <- assertSuccess $ test ctx ["up", "a"] 259 | result ^. #stderr `shouldSatisfy` (not . ("test boot message" `T.isInfixOf`)) 260 | 261 | context "when the `--verbose` flag is given" $ do 262 | it "prints out nix build logs" $ do 263 | withMockContext ["a"] $ \(withLogMessage (Msg Build "test build message") -> ctx) -> do 264 | result <- assertSuccess $ test ctx ["up", "a", "--verbose"] 265 | T.lines (result ^. #stderr) `shouldContain` ["a> test build message"] 266 | 267 | it "prints out boot logs" $ do 268 | withMockContext ["a"] $ \(withLogMessage (Msg Boot "test boot message") -> ctx) -> do 269 | result <- assertSuccess $ test ctx ["up", "a", "--verbose"] 270 | T.lines (result ^. #stderr) `shouldContain` ["a> test boot message"] 271 | 272 | it "strips ansi escape sequences" $ do 273 | let message = cs (setSGRCode [SetColor Foreground Vivid Yellow]) <> "yellow message" <> cs (setSGRCode [Reset]) 274 | withMockContext ["a"] $ \(withLogMessage (Msg Boot message) -> ctx) -> do 275 | result <- assertSuccess $ test ctx ["up", "a", "--verbose"] 276 | T.lines (result ^. #stderr) `shouldContain` ["a> yellow message"] 277 | 278 | it "removes nonprintable characters" $ do 279 | let message = cs (setSGRCode [SetColor Foreground Vivid Yellow]) <> "nonprintable: \BEL" <> cs (setSGRCode [Reset]) 280 | withMockContext ["a"] $ \(withLogMessage (Msg Boot message) -> ctx) -> do 281 | result <- assertSuccess $ test ctx ["up", "a", "--verbose"] 282 | T.lines (result ^. #stderr) `shouldContain` ["a> nonprintable: "] 283 | 284 | data Barrier = Barrier 285 | { target :: Int, 286 | signal :: MVar (), 287 | count :: MVar Int 288 | } 289 | 290 | newBarrier :: Int -> IO Barrier 291 | newBarrier target = Barrier target <$> newEmptyMVar <*> newMVar 0 292 | 293 | waitBarrier :: Barrier -> IO () 294 | waitBarrier Barrier {target, signal, count} = do 295 | modifyMVar_ count $ \c -> do 296 | let new = c + 1 297 | when (new == target) $ putMVar signal () 298 | pure new 299 | readMVar signal 300 | 301 | groupIntoSets :: (Ord a) => [Int] -> [a] -> [Set a] 302 | groupIntoSets ns list = case (ns, list) of 303 | (n : ns, list) -> 304 | let (group, rest) = splitAt n list 305 | in Set.fromList group : groupIntoSets ns rest 306 | ([], []) -> [] 307 | _ -> error "groupIntoSets: didn't get right amount of elements" 308 | 309 | data LogMessage = Msg Phase Text 310 | 311 | data Phase 312 | = Build 313 | | Boot 314 | deriving stock (Eq) 315 | 316 | withLogMessage :: LogMessage -> Context -> Context 317 | withLogMessage (Msg phase message) context = 318 | context 319 | & (#nixVms . #buildVmScript) 320 | %~ ( \buildVmScript ctx handle vmName ip -> do 321 | when (phase == Build) $ do 322 | forM_ handle $ \handle -> do 323 | T.hPutStrLn handle message 324 | buildVmScript ctx handle vmName ip 325 | ) 326 | & (#nixVms . #runVm) 327 | %~ ( \runVm ctx handle vmName vmExecutable -> do 328 | when (phase == Boot) $ do 329 | T.hPutStrLn handle message 330 | runVm ctx handle vmName vmExecutable 331 | ) 332 | --------------------------------------------------------------------------------