summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorJoey Hess2018-12-30 15:08:00 -0400
committerJoey Hess2018-12-30 15:08:00 -0400
commit84330a9a6dcd1dd2f2afa3f0ad5a8f07bd26f9d5 (patch)
tree8d31499a1ae4245a8098fcaa56f7107434b18de6 /src
parent287887cff4e43b64a592121aaa7bc371433dd686 (diff)
parentf0a3ad02488ea89088cc06d112194d9db3b751e3 (diff)
Merge branch 'master' into joeyconfig
Diffstat (limited to 'src')
-rw-r--r--src/Propellor/Bootstrap.hs42
-rw-r--r--src/Propellor/Property/DiskImage.hs24
-rw-r--r--src/Propellor/Property/Libvirt.hs210
-rw-r--r--src/Propellor/Property/SiteSpecific/JoeySites.hs1
-rw-r--r--src/Propellor/Types.hs1
-rw-r--r--src/Propellor/Types/OS.hs2
-rw-r--r--src/Utility/Process.hs11
7 files changed, 260 insertions, 31 deletions
diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs
index 66e6e1ff..6ca133cb 100644
--- a/src/Propellor/Bootstrap.hs
+++ b/src/Propellor/Bootstrap.hs
@@ -95,6 +95,8 @@ checkDepsCommand bs sys = go (getBuilder bs)
go Cabal = "if ! cabal configure >/dev/null 2>&1; then " ++ depsCommand bs sys ++ "; fi"
go Stack = "if ! stack build --dry-run >/dev/null 2>&1; then " ++ depsCommand bs sys ++ "; fi"
+data Dep = Dep String | OldDep String
+
-- Install build dependencies of propellor, using the specified
-- Bootstrapper.
--
@@ -128,32 +130,34 @@ depsCommand bs msys = "( " ++ intercalate " ; " (go bs) ++ ") || true"
useapt builder = "apt-get update" : map aptinstall (debdeps builder)
- aptinstall p = "DEBIAN_FRONTEND=noninteractive apt-get -qq --no-upgrade --no-install-recommends -y install " ++ p
+ aptinstall (Dep p) = "DEBIAN_FRONTEND=noninteractive apt-get -qq --no-upgrade --no-install-recommends -y install " ++ p
+ aptinstall (OldDep p) = "if LANG=C apt-cache policy " ++ p ++ "| grep -q Candidate:; then " ++ aptinstall (Dep p) ++ "; fi"
pkginstall p = "ASSUME_ALWAYS_YES=yes pkg install " ++ p
pacmaninstall p = "pacman -S --noconfirm --needed " ++ p
debdeps Cabal =
- [ "gnupg"
+ [ Dep "gnupg"
-- Below are the same deps listed in debian/control.
- , "ghc"
- , "cabal-install"
- , "libghc-async-dev"
- , "libghc-split-dev"
- , "libghc-hslogger-dev"
- , "libghc-unix-compat-dev"
- , "libghc-ansi-terminal-dev"
- , "libghc-ifelse-dev"
- , "libghc-network-dev"
- , "libghc-mtl-dev"
- , "libghc-transformers-dev"
- , "libghc-exceptions-dev"
- , "libghc-stm-dev"
- , "libghc-text-dev"
- , "libghc-hashable-dev"
+ , Dep "ghc"
+ , Dep "cabal-install"
+ , Dep "libghc-async-dev"
+ , Dep "libghc-split-dev"
+ , Dep "libghc-hslogger-dev"
+ , Dep "libghc-unix-compat-dev"
+ , Dep "libghc-ansi-terminal-dev"
+ , Dep "libghc-ifelse-dev"
+ , Dep "libghc-network-dev"
+ , Dep "libghc-mtl-dev"
+ , Dep "libghc-transformers-dev"
+ , Dep "libghc-exceptions-dev"
+ , Dep "libghc-text-dev"
+ , Dep "libghc-hashable-dev"
+ -- Deps that are only needed on old systems.
+ , OldDep "libghc-stm-dev"
]
debdeps Stack =
- [ "gnupg"
- , "haskell-stack"
+ [ Dep "gnupg"
+ , Dep "haskell-stack"
]
fbsddeps Cabal =
diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs
index fa41808e..29bc2d1c 100644
--- a/src/Propellor/Property/DiskImage.hs
+++ b/src/Propellor/Property/DiskImage.hs
@@ -17,6 +17,7 @@ module Propellor.Property.DiskImage (
imageRebuiltFor,
imageBuiltFrom,
imageExists,
+ imageChrootNotPresent,
GrubTarget(..),
noBootloader,
) where
@@ -200,14 +201,13 @@ imageBuilt' rebuild img mkchroot tabletype partspec =
`describe` desc
where
desc = "built disk image " ++ describeDiskImage img
- RawDiskImage imgfile = rawDiskImage img
cleanrebuild :: Property Linux
cleanrebuild
| rebuild = property desc $ do
liftIO $ removeChroot chrootdir
return MadeChange
| otherwise = doNothing
- chrootdir = imgfile ++ ".chroot"
+ chrootdir = imageChroot img
chroot =
let c = propprivdataonly $ mkchroot chrootdir
in setContainerProps c $ containerProps c
@@ -378,7 +378,7 @@ imageExists' :: RawDiskImage -> PartTable -> RevertableProperty DebianLike UnixL
imageExists' dest@(RawDiskImage img) parttable = (setup <!> cleanup) `describe` desc
where
desc = "disk image exists " ++ img
- parttablefile = img ++ ".parttable"
+ parttablefile = imageParttableFile dest
setup = property' desc $ \w -> do
oldparttable <- liftIO $ catchDefaultIO "" $ readFileStrict parttablefile
res <- ensureProperty w $ imageExists dest (partTableSize parttable)
@@ -488,6 +488,24 @@ noBootloader = pureInfoProperty "no bootloader" [NoBootloader]
noBootloaderFinalized :: Finalization
noBootloaderFinalized _img _mnt _loopDevs = doNothing
+imageChrootNotPresent :: DiskImage d => d -> Property UnixLike
+imageChrootNotPresent img = check (doesDirectoryExist dir) $
+ property "destroy the chroot used to build the image" $ makeChange $ do
+ removeChroot dir
+ nukeFile $ imageParttableFile img
+ where
+ dir = imageChroot img
+
+imageChroot :: DiskImage d => d -> FilePath
+imageChroot img = imgfile <.> "chroot"
+ where
+ RawDiskImage imgfile = rawDiskImage img
+
+imageParttableFile :: DiskImage d => d -> FilePath
+imageParttableFile img = imgfile <.> "parttable"
+ where
+ RawDiskImage imgfile = rawDiskImage img
+
isChild :: FilePath -> Maybe MountPoint -> Bool
isChild mntpt (Just d)
| d `equalFilePath` mntpt = False
diff --git a/src/Propellor/Property/Libvirt.hs b/src/Propellor/Property/Libvirt.hs
new file mode 100644
index 00000000..525dd68a
--- /dev/null
+++ b/src/Propellor/Property/Libvirt.hs
@@ -0,0 +1,210 @@
+-- | Maintainer: Sean Whitton <spwhitton@spwhitton.name>
+
+module Propellor.Property.Libvirt (
+ NumVCPUs(..),
+ MiBMemory(..),
+ AutoStart(..),
+ DiskImageType(..),
+ installed,
+ defaultNetworkAutostarted,
+ defaultNetworkStarted,
+ defined,
+) where
+
+import Propellor.Base
+import Propellor.Types.Info
+import Propellor.Property.Chroot
+import Propellor.Property.DiskImage
+import qualified Propellor.Property.Apt as Apt
+
+import Utility.Split
+
+-- | The number of virtual CPUs to assign to the virtual machine
+newtype NumVCPUs = NumVCPUs Int
+
+-- | The number of MiB of memory to assign to the virtual machine
+newtype MiBMemory = MiBMemory Int
+
+-- | Whether the virtual machine should be started after it is defined, and at
+-- host system boot
+data AutoStart = AutoStart | NoAutoStart
+
+-- | Which type of disk image to build for the virtual machine
+data DiskImageType = Raw -- | QCow2
+
+-- | Install basic libvirt components
+installed :: Property DebianLike
+installed = Apt.installed ["libvirt-clients", "virtinst"]
+
+-- | Ensure that the default libvirt network is set to autostart, and start it.
+--
+-- On Debian, it is not started by default after installation of libvirt.
+defaultNetworkAutostarted :: Property DebianLike
+defaultNetworkAutostarted = autostarted
+ `requires` installed
+ `before` defaultNetworkStarted
+ where
+ autostarted = check (not <$> doesFileExist autostartFile) $
+ cmdProperty "virsh" ["net-autostart", "default"]
+ autostartFile = "/etc/libvirt/qemu/networks/autostart/default.xml"
+
+-- | Ensure that the default libvirt network is started.
+defaultNetworkStarted :: Property DebianLike
+defaultNetworkStarted = go `requires` installed
+ where
+ go :: Property UnixLike
+ go = property "start libvirt's default network" $ do
+ runningNetworks <- liftIO $ virshGetColumns ["net-list"]
+ if ["default"] `elem` (take 1 <$> runningNetworks)
+ then noChange
+ else makeChange $ unlessM startIt $
+ errorMessage "failed to start default network"
+ startIt = boolSystem "virsh" [Param "net-start", Param "default"]
+
+
+-- | Builds a disk image with the properties of the given Host, installs a
+-- libvirt configuration file to boot the image, and if it is set to autostart,
+-- start the VM.
+--
+-- Note that building the disk image happens only once. So if you change the
+-- properties of the given Host, this property will not modify the disk image.
+-- In order to later apply properties to the VM, you should spin it directly, or
+-- arrange to have it spun with a property like 'Cron.runPropellor', or use
+-- 'Propellor.Property.Conductor' from the VM host.
+--
+-- Suggested usage in @config.hs@:
+--
+-- > mybox = host "mybox.example.com" $ props
+-- > & osDebian (Stable "stretch") X86_64
+-- > & Libvirt.defaultNetworkAutostarted
+-- > & Libvirt.defined Libvirt.Raw
+-- > (Libvirt.MiBMemory 2048) (Libvirt.NumVCPUs 2)
+-- > Libvirt.NoAutoStart subbox
+-- >
+-- > subbox = host "subbox.mybox.example.com" $ props
+-- > & osDebian Unstable X86_64
+-- > & hasPartition
+-- > ( partition EXT4
+-- > `mountedAt` "/"
+-- > `addFreeSpace` MegaBytes 10240
+-- > )
+-- > & Apt.installed ["linux-image-amd64"]
+-- > & Grub.installed PC
+-- >
+-- > & ipv4 "192.168.122.31"
+-- > & Network.static "ens3" (IPv4 "192.168.122.31")
+-- > (Just (Network.Gateway (IPv4 "192.168.122.1")))
+-- > `requires` Network.cleanInterfacesFile
+-- > & Hostname.sane
+defined
+ :: DiskImageType
+ -> MiBMemory
+ -> NumVCPUs
+ -> AutoStart
+ -> Host
+ -> Property (HasInfo + DebianLike)
+defined imageType (MiBMemory mem) (NumVCPUs cpus) auto h =
+ (built `before` nuked `before` xmlDefined `before` started)
+ `requires` installed
+ where
+ built :: Property (HasInfo + DebianLike)
+ built = check (not <$> doesFileExist imageLoc) $
+ setupRevertableProperty $ imageBuiltFor h
+ (image) (Debootstrapped mempty)
+
+ nuked :: Property UnixLike
+ nuked = imageChrootNotPresent image
+
+ xmlDefined :: Property UnixLike
+ xmlDefined = check (not <$> doesFileExist conf) $
+ property "define the libvirt VM" $
+ withTmpFile (hostName h) $ \t fh -> do
+ xml <- liftIO $ readProcess "virt-install" $
+ [ "-n", hostName h
+ , "--memory=" ++ show mem
+ , "--vcpus=" ++ show cpus
+ , "--disk"
+ , "path=" ++ imageLoc
+ ++ ",device=disk,bus=virtio"
+ , "--print-xml"
+ ] ++ autoStartArg ++ osVariantArg
+ liftIO $ hPutStrLn fh xml
+ liftIO $ hClose fh
+ makeChange $ unlessM (defineIt t) $
+ errorMessage "failed to define VM"
+ where
+ defineIt t = boolSystem "virsh" [Param "define", Param t]
+
+ started :: Property UnixLike
+ started = case auto of
+ AutoStart -> property "start the VM" $ do
+ runningVMs <- liftIO $ virshGetColumns ["list"]
+ -- From the point of view of `virsh start`, the "State"
+ -- column in the output of `virsh list` is not relevant.
+ -- So long as the VM is listed, it's considered started.
+ if [hostName h] `elem` (take 1 . drop 1 <$> runningVMs)
+ then noChange
+ else makeChange $ unlessM startIt $
+ errorMessage "failed to start VM"
+ NoAutoStart -> doNothing
+ where
+ startIt = boolSystem "virsh" [Param "start", Param $ hostName h]
+
+ image = case imageType of
+ Raw -> RawDiskImage imageLoc
+ imageLoc =
+ "/var/lib/libvirt/images" </> hostName h <.> case imageType of
+ Raw -> "img"
+ conf = "/etc/libvirt/qemu" </> hostName h <.> "xml"
+
+ osVariantArg = maybe [] (\v -> ["--os-variant=" ++ v]) $ osVariant h
+ autoStartArg = case auto of
+ AutoStart -> ["--autostart"]
+ NoAutoStart -> []
+
+-- ==== utility functions ====
+
+-- The --os-variant property is optional, per virt-install(1), so return Nothing
+-- if there isn't a known correct value. The VM will still be defined. Pass
+-- the value if we can, though, to optimise the generated XML for the host's OS
+osVariant :: Host -> Maybe String
+osVariant h = hostSystem h >>= \s -> case s of
+ System (Debian _ (Stable "jessie")) _ -> Just "debian8"
+ System (Debian _ (Stable "stretch")) _ -> Just "debian9"
+ System (Debian _ Testing) _ -> Just "debiantesting"
+ System (Debian _ Unstable) _ -> Just "debiantesting"
+
+ System (Buntish "trusty") _ -> Just "ubuntu14.04"
+ System (Buntish "utopic") _ -> Just "ubuntu14.10"
+ System (Buntish "vivid") _ -> Just "ubuntu15.04"
+ System (Buntish "wily") _ -> Just "ubuntu15.10"
+ System (Buntish "xenial") _ -> Just "ubuntu16.04"
+ System (Buntish "yakkety") _ -> Just "ubuntu16.10"
+ System (Buntish "zesty") _ -> Just "ubuntu17.04"
+ System (Buntish "artful") _ -> Just "ubuntu17.10"
+ System (Buntish "bionic") _ -> Just "ubuntu18.04"
+
+ System (FreeBSD (FBSDProduction FBSD101)) _ -> Just "freebsd10.1"
+ System (FreeBSD (FBSDProduction FBSD102)) _ -> Just "freebsd10.2"
+ System (FreeBSD (FBSDProduction FBSD093)) _ -> Just "freebsd9.3"
+ System (FreeBSD (FBSDLegacy FBSD101)) _ -> Just "freebsd10.1"
+ System (FreeBSD (FBSDLegacy FBSD102)) _ -> Just "freebsd10.2"
+ System (FreeBSD (FBSDLegacy FBSD093)) _ -> Just "freebsd9.3"
+
+ -- libvirt doesn't have an archlinux variant yet, it seems
+ System ArchLinux _ -> Nothing
+
+ -- other stable releases that we don't know about (since there are
+ -- infinitely many possible stable release names, as it is a freeform
+ -- string, we need this to avoid a compiler warning)
+ System (Debian _ _) _ -> Nothing
+ System (Buntish _) _ -> Nothing
+
+-- Run a virsh command with the given list of arguments, that is expected to
+-- yield tabular output, and return the rows
+virshGetColumns :: [String] -> IO [[String]]
+virshGetColumns args = map (filter (not . null) . split " ") . drop 2 . lines
+ <$> readProcess "virsh" args
+
+hostSystem :: Host -> Maybe System
+hostSystem = fromInfoVal . fromInfo . hostInfo
diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs
index ce0e0ccd..07787705 100644
--- a/src/Propellor/Property/SiteSpecific/JoeySites.hs
+++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs
@@ -954,7 +954,6 @@ homePower user hosts ctx sshkey = propertyList "home power" $ props
`requires` Apt.installed
[ "ghc", "cabal-install", "make"
, "libghc-http-types-dev"
- , "libghc-stm-dev"
, "libghc-aeson-dev"
, "libghc-wai-dev"
, "libghc-warp-dev"
diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs
index e10e0f5b..7052bf92 100644
--- a/src/Propellor/Types.hs
+++ b/src/Propellor/Types.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
diff --git a/src/Propellor/Types/OS.hs b/src/Propellor/Types/OS.hs
index 01d777a4..34ea4272 100644
--- a/src/Propellor/Types/OS.hs
+++ b/src/Propellor/Types/OS.hs
@@ -23,7 +23,7 @@ module Propellor.Types.OS (
import Propellor.Types.ConfigurableValue
-import Network.BSD (HostName)
+import Network.Socket (HostName)
import Data.Typeable
import Data.String
diff --git a/src/Utility/Process.hs b/src/Utility/Process.hs
index 6d981cb5..48e03f41 100644
--- a/src/Utility/Process.hs
+++ b/src/Utility/Process.hs
@@ -248,13 +248,10 @@ withHandle h creator p a = creator p' $ a . select
, std_out = Inherit
, std_err = Inherit
}
- (select, p')
- | h == StdinHandle =
- (stdinHandle, base { std_in = CreatePipe })
- | h == StdoutHandle =
- (stdoutHandle, base { std_out = CreatePipe })
- | h == StderrHandle =
- (stderrHandle, base { std_err = CreatePipe })
+ (select, p') = case h of
+ StdinHandle -> (stdinHandle, base { std_in = CreatePipe })
+ StdoutHandle -> (stdoutHandle, base { std_out = CreatePipe })
+ StderrHandle -> (stderrHandle, base { std_err = CreatePipe })
-- | Like withHandle, but passes (stdin, stdout) handles to the action.
withIOHandles