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
newtype NumVCPUs = NumVCPUs Int
newtype MiBMemory = MiBMemory Int
data AutoStart = AutoStart | NoAutoStart
data DiskImageType = Raw
installed :: Property DebianLike
installed :: Property DebianLike
installed = [Package] -> Property DebianLike
Apt.installed [Package
"libvirt-clients", Package
"virtinst", Package
"libvirt-daemon", Package
"libvirt-daemon-system"]
defaultNetworkAutostarted :: Property DebianLike
defaultNetworkAutostarted :: Property DebianLike
defaultNetworkAutostarted = Property UnixLike
autostarted
Property UnixLike
-> Property DebianLike
-> CombinedType (Property UnixLike) (Property DebianLike)
forall x y. Combines x y => x -> y -> CombinedType x y
`requires` Property DebianLike
installed
Property DebianLike
-> Property DebianLike
-> CombinedType (Property DebianLike) (Property DebianLike)
forall x y. Combines x y => x -> y -> CombinedType x y
`before` Property DebianLike
defaultNetworkStarted
where
autostarted :: Property UnixLike
autostarted = IO Bool -> UncheckedProperty UnixLike -> Property UnixLike
forall (p :: * -> *) i (m :: * -> *).
(Checkable p i, LiftPropellor m) =>
m Bool -> p i -> Property i
check (Bool -> Bool
not (Bool -> Bool) -> IO Bool -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Package -> IO Bool
doesFileExist Package
autostartFile) (UncheckedProperty UnixLike -> Property UnixLike)
-> UncheckedProperty UnixLike -> Property UnixLike
forall a b. (a -> b) -> a -> b
$
Package -> [Package] -> UncheckedProperty UnixLike
cmdProperty Package
"virsh" [Package
"net-autostart", Package
"default"]
autostartFile :: Package
autostartFile = Package
"/etc/libvirt/qemu/networks/autostart/default.xml"
defaultNetworkStarted :: Property DebianLike
defaultNetworkStarted :: Property DebianLike
defaultNetworkStarted = Property UnixLike
go Property UnixLike
-> Property DebianLike
-> CombinedType (Property UnixLike) (Property DebianLike)
forall x y. Combines x y => x -> y -> CombinedType x y
`requires` Property DebianLike
installed
where
go :: Property UnixLike
go :: Property UnixLike
go = Package -> Propellor Result -> Property UnixLike
forall k (metatypes :: k).
SingI metatypes =>
Package -> Propellor Result -> Property (MetaTypes metatypes)
property Package
"start libvirt's default network" (Propellor Result -> Property UnixLike)
-> Propellor Result -> Property UnixLike
forall a b. (a -> b) -> a -> b
$ do
[[Package]]
runningNetworks <- IO [[Package]] -> Propellor [[Package]]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [[Package]] -> Propellor [[Package]])
-> IO [[Package]] -> Propellor [[Package]]
forall a b. (a -> b) -> a -> b
$ [Package] -> IO [[Package]]
virshGetColumns [Package
"net-list"]
if [Package
"default"] [Package] -> [[Package]] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Int -> [Package] -> [Package]
forall a. Int -> [a] -> [a]
take Int
1 ([Package] -> [Package]) -> [[Package]] -> [[Package]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Package]]
runningNetworks)
then Propellor Result
noChange
else IO () -> Propellor Result
makeChange (IO () -> Propellor Result) -> IO () -> Propellor Result
forall a b. (a -> b) -> a -> b
$ IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM IO Bool
startIt (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Package -> IO ()
forall (m :: * -> *) a. MonadIO m => Package -> m a
errorMessage Package
"failed to start default network"
startIt :: IO Bool
startIt = Package -> [CommandParam] -> IO Bool
boolSystem Package
"virsh" [Package -> CommandParam
Param Package
"net-start", Package -> CommandParam
Param Package
"default"]
defined
:: DiskImageType
-> MiBMemory
-> NumVCPUs
-> AutoStart
-> Host
-> Property (HasInfo + DebianLike)
defined :: DiskImageType
-> MiBMemory
-> NumVCPUs
-> AutoStart
-> Host
-> Property (HasInfo + DebianLike)
defined DiskImageType
imageType (MiBMemory Int
mem) (NumVCPUs Int
cpus) AutoStart
auto Host
h =
(Property
(Sing '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
Property (HasInfo + DebianLike)
built Property
(Sing '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
-> Property UnixLike
-> CombinedType
(Property
(Sing '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish]))
(Property UnixLike)
forall x y. Combines x y => x -> y -> CombinedType x y
`before` Property UnixLike
nuked Property
(Sing '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
-> Property UnixLike
-> CombinedType
(Property
(Sing '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish]))
(Property UnixLike)
forall x y. Combines x y => x -> y -> CombinedType x y
`before` Property UnixLike
xmlDefined Property
(Sing '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
-> Property UnixLike
-> CombinedType
(Property
(Sing '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish]))
(Property UnixLike)
forall x y. Combines x y => x -> y -> CombinedType x y
`before` Property UnixLike
started)
Property
(Sing '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
-> Property DebianLike
-> CombinedType
(Property
(Sing '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish]))
(Property DebianLike)
forall x y. Combines x y => x -> y -> CombinedType x y
`requires` Property DebianLike
installed
where
built :: Property (HasInfo + DebianLike)
built :: Property (HasInfo + DebianLike)
built = IO Bool
-> Property
(Sing '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
-> Property
(Sing '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
forall (p :: * -> *) i (m :: * -> *).
(Checkable p i, LiftPropellor m) =>
m Bool -> p i -> Property i
check (Bool -> Bool
not (Bool -> Bool) -> IO Bool -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Package -> IO Bool
doesFileExist Package
imageLoc) (Property
(Sing '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
-> Property
(Sing '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish]))
-> Property
(Sing '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
-> Property
(Sing '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
forall a b. (a -> b) -> a -> b
$
RevertableProperty
(Sing '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
Linux
-> Property
(Sing '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
forall setupmetatypes undometatypes.
RevertableProperty setupmetatypes undometatypes
-> Property setupmetatypes
setupRevertableProperty (RevertableProperty
(Sing '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
Linux
-> Property
(Sing '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish]))
-> RevertableProperty
(Sing '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
Linux
-> Property
(Sing '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
forall a b. (a -> b) -> a -> b
$ Host
-> RawDiskImage
-> Debootstrapped
-> RevertableProperty (HasInfo + DebianLike) Linux
forall d bootstrapper.
(DiskImage d, ChrootBootstrapper bootstrapper) =>
Host
-> d
-> bootstrapper
-> RevertableProperty (HasInfo + DebianLike) Linux
imageBuiltFor Host
h
(RawDiskImage
image) (DebootstrapConfig -> Debootstrapped
Debootstrapped DebootstrapConfig
forall a. Monoid a => a
mempty)
nuked :: Property UnixLike
nuked :: Property UnixLike
nuked = RawDiskImage -> Property UnixLike
forall d. DiskImage d => d -> Property UnixLike
imageChrootNotPresent RawDiskImage
image
xmlDefined :: Property UnixLike
xmlDefined :: Property UnixLike
xmlDefined = IO Bool -> Property UnixLike -> Property UnixLike
forall (p :: * -> *) i (m :: * -> *).
(Checkable p i, LiftPropellor m) =>
m Bool -> p i -> Property i
check (Bool -> Bool
not (Bool -> Bool) -> IO Bool -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Package -> IO Bool
doesFileExist Package
conf) (Property UnixLike -> Property UnixLike)
-> Property UnixLike -> Property UnixLike
forall a b. (a -> b) -> a -> b
$
Package -> Propellor Result -> Property UnixLike
forall k (metatypes :: k).
SingI metatypes =>
Package -> Propellor Result -> Property (MetaTypes metatypes)
property Package
"define the libvirt VM" (Propellor Result -> Property UnixLike)
-> Propellor Result -> Property UnixLike
forall a b. (a -> b) -> a -> b
$
Package
-> (Package -> Handle -> Propellor Result) -> Propellor Result
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Package -> (Package -> Handle -> m a) -> m a
withTmpFile (Host -> Package
hostName Host
h) ((Package -> Handle -> Propellor Result) -> Propellor Result)
-> (Package -> Handle -> Propellor Result) -> Propellor Result
forall a b. (a -> b) -> a -> b
$ \Package
t Handle
fh -> do
Package
xml <- IO Package -> Propellor Package
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Package -> Propellor Package)
-> IO Package -> Propellor Package
forall a b. (a -> b) -> a -> b
$ Package -> [Package] -> IO Package
readProcess Package
"virt-install" ([Package] -> IO Package) -> [Package] -> IO Package
forall a b. (a -> b) -> a -> b
$
[ Package
"-n", Host -> Package
hostName Host
h
, Package
"--memory=" Package -> Package -> Package
forall a. [a] -> [a] -> [a]
++ Int -> Package
forall a. Show a => a -> Package
show Int
mem
, Package
"--vcpus=" Package -> Package -> Package
forall a. [a] -> [a] -> [a]
++ Int -> Package
forall a. Show a => a -> Package
show Int
cpus
, Package
"--disk"
, Package
"path=" Package -> Package -> Package
forall a. [a] -> [a] -> [a]
++ Package
imageLoc
Package -> Package -> Package
forall a. [a] -> [a] -> [a]
++ Package
",device=disk,bus=virtio"
, Package
"--print-xml"
] [Package] -> [Package] -> [Package]
forall a. [a] -> [a] -> [a]
++ [Package]
autoStartArg [Package] -> [Package] -> [Package]
forall a. [a] -> [a] -> [a]
++ [Package]
osVariantArg
IO () -> Propellor ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Propellor ()) -> IO () -> Propellor ()
forall a b. (a -> b) -> a -> b
$ Handle -> Package -> IO ()
hPutStrLn Handle
fh Package
xml
IO () -> Propellor ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Propellor ()) -> IO () -> Propellor ()
forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
hClose Handle
fh
IO () -> Propellor Result
makeChange (IO () -> Propellor Result) -> IO () -> Propellor Result
forall a b. (a -> b) -> a -> b
$ IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (Package -> IO Bool
defineIt Package
t) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Package -> IO ()
forall (m :: * -> *) a. MonadIO m => Package -> m a
errorMessage Package
"failed to define VM"
where
defineIt :: Package -> IO Bool
defineIt Package
t = Package -> [CommandParam] -> IO Bool
boolSystem Package
"virsh" [Package -> CommandParam
Param Package
"define", Package -> CommandParam
Param Package
t]
started :: Property UnixLike
started :: Property UnixLike
started = case AutoStart
auto of
AutoStart
AutoStart -> Package -> Propellor Result -> Property UnixLike
forall k (metatypes :: k).
SingI metatypes =>
Package -> Propellor Result -> Property (MetaTypes metatypes)
property Package
"start the VM" (Propellor Result -> Property UnixLike)
-> Propellor Result -> Property UnixLike
forall a b. (a -> b) -> a -> b
$ do
[[Package]]
runningVMs <- IO [[Package]] -> Propellor [[Package]]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [[Package]] -> Propellor [[Package]])
-> IO [[Package]] -> Propellor [[Package]]
forall a b. (a -> b) -> a -> b
$ [Package] -> IO [[Package]]
virshGetColumns [Package
"list"]
if [Host -> Package
hostName Host
h] [Package] -> [[Package]] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Int -> [Package] -> [Package]
forall a. Int -> [a] -> [a]
take Int
1 ([Package] -> [Package])
-> ([Package] -> [Package]) -> [Package] -> [Package]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Package] -> [Package]
forall a. Int -> [a] -> [a]
drop Int
1 ([Package] -> [Package]) -> [[Package]] -> [[Package]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Package]]
runningVMs)
then Propellor Result
noChange
else IO () -> Propellor Result
makeChange (IO () -> Propellor Result) -> IO () -> Propellor Result
forall a b. (a -> b) -> a -> b
$ IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM IO Bool
startIt (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Package -> IO ()
forall (m :: * -> *) a. MonadIO m => Package -> m a
errorMessage Package
"failed to start VM"
AutoStart
NoAutoStart -> Property UnixLike
forall k (t :: k). SingI t => Property (MetaTypes t)
doNothing
where
startIt :: IO Bool
startIt = Package -> [CommandParam] -> IO Bool
boolSystem Package
"virsh" [Package -> CommandParam
Param Package
"start", Package -> CommandParam
Param (Package -> CommandParam) -> Package -> CommandParam
forall a b. (a -> b) -> a -> b
$ Host -> Package
hostName Host
h]
image :: RawDiskImage
image = case DiskImageType
imageType of
DiskImageType
Raw -> Package -> RawDiskImage
RawDiskImage Package
imageLoc
imageLoc :: Package
imageLoc =
Package
"/var/lib/libvirt/images" Package -> Package -> Package
</> Host -> Package
hostName Host
h Package -> Package -> Package
<.> case DiskImageType
imageType of
DiskImageType
Raw -> Package
"img"
conf :: Package
conf = Package
"/etc/libvirt/qemu" Package -> Package -> Package
</> Host -> Package
hostName Host
h Package -> Package -> Package
<.> Package
"xml"
osVariantArg :: [Package]
osVariantArg = [Package] -> (Package -> [Package]) -> Maybe Package -> [Package]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Package
v -> [Package
"--os-variant=" Package -> Package -> Package
forall a. [a] -> [a] -> [a]
++ Package
v]) (Maybe Package -> [Package]) -> Maybe Package -> [Package]
forall a b. (a -> b) -> a -> b
$ Host -> Maybe Package
osVariant Host
h
autoStartArg :: [Package]
autoStartArg = case AutoStart
auto of
AutoStart
AutoStart -> [Package
"--autostart"]
AutoStart
NoAutoStart -> []
osVariant :: Host -> Maybe String
osVariant :: Host -> Maybe Package
osVariant Host
h = Host -> Maybe System
hostSystem Host
h Maybe System -> (System -> Maybe Package) -> Maybe Package
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \System
s -> case System
s of
System (Debian DebianKernel
_ (Stable Package
"jessie")) Architecture
_ -> Package -> Maybe Package
forall a. a -> Maybe a
Just Package
"debian8"
System (Debian DebianKernel
_ (Stable Package
"stretch")) Architecture
_ -> Package -> Maybe Package
forall a. a -> Maybe a
Just Package
"debian9"
System (Debian DebianKernel
_ DebianSuite
Testing) Architecture
_ -> Package -> Maybe Package
forall a. a -> Maybe a
Just Package
"debiantesting"
System (Debian DebianKernel
_ DebianSuite
Unstable) Architecture
_ -> Package -> Maybe Package
forall a. a -> Maybe a
Just Package
"debiantesting"
System (Buntish Package
"trusty") Architecture
_ -> Package -> Maybe Package
forall a. a -> Maybe a
Just Package
"ubuntu14.04"
System (Buntish Package
"utopic") Architecture
_ -> Package -> Maybe Package
forall a. a -> Maybe a
Just Package
"ubuntu14.10"
System (Buntish Package
"vivid") Architecture
_ -> Package -> Maybe Package
forall a. a -> Maybe a
Just Package
"ubuntu15.04"
System (Buntish Package
"wily") Architecture
_ -> Package -> Maybe Package
forall a. a -> Maybe a
Just Package
"ubuntu15.10"
System (Buntish Package
"xenial") Architecture
_ -> Package -> Maybe Package
forall a. a -> Maybe a
Just Package
"ubuntu16.04"
System (Buntish Package
"yakkety") Architecture
_ -> Package -> Maybe Package
forall a. a -> Maybe a
Just Package
"ubuntu16.10"
System (Buntish Package
"zesty") Architecture
_ -> Package -> Maybe Package
forall a. a -> Maybe a
Just Package
"ubuntu17.04"
System (Buntish Package
"artful") Architecture
_ -> Package -> Maybe Package
forall a. a -> Maybe a
Just Package
"ubuntu17.10"
System (Buntish Package
"bionic") Architecture
_ -> Package -> Maybe Package
forall a. a -> Maybe a
Just Package
"ubuntu18.04"
System (FreeBSD (FBSDProduction FBSDVersion
FBSD101)) Architecture
_ -> Package -> Maybe Package
forall a. a -> Maybe a
Just Package
"freebsd10.1"
System (FreeBSD (FBSDProduction FBSDVersion
FBSD102)) Architecture
_ -> Package -> Maybe Package
forall a. a -> Maybe a
Just Package
"freebsd10.2"
System (FreeBSD (FBSDProduction FBSDVersion
FBSD093)) Architecture
_ -> Package -> Maybe Package
forall a. a -> Maybe a
Just Package
"freebsd9.3"
System (FreeBSD (FBSDLegacy FBSDVersion
FBSD101)) Architecture
_ -> Package -> Maybe Package
forall a. a -> Maybe a
Just Package
"freebsd10.1"
System (FreeBSD (FBSDLegacy FBSDVersion
FBSD102)) Architecture
_ -> Package -> Maybe Package
forall a. a -> Maybe a
Just Package
"freebsd10.2"
System (FreeBSD (FBSDLegacy FBSDVersion
FBSD093)) Architecture
_ -> Package -> Maybe Package
forall a. a -> Maybe a
Just Package
"freebsd9.3"
System Distribution
ArchLinux Architecture
_ -> Maybe Package
forall a. Maybe a
Nothing
System (Debian DebianKernel
_ DebianSuite
_) Architecture
_ -> Maybe Package
forall a. Maybe a
Nothing
System (Buntish Package
_) Architecture
_ -> Maybe Package
forall a. Maybe a
Nothing
virshGetColumns :: [String] -> IO [[String]]
virshGetColumns :: [Package] -> IO [[Package]]
virshGetColumns [Package]
args = (Package -> [Package]) -> [Package] -> [[Package]]
forall a b. (a -> b) -> [a] -> [b]
map ((Package -> Bool) -> [Package] -> [Package]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Package -> Bool) -> Package -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Package -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([Package] -> [Package])
-> (Package -> [Package]) -> Package -> [Package]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Package -> Package -> [Package]
forall a. Eq a => [a] -> [a] -> [[a]]
split Package
" ") ([Package] -> [[Package]])
-> (Package -> [Package]) -> Package -> [[Package]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Package] -> [Package]
forall a. Int -> [a] -> [a]
drop Int
2 ([Package] -> [Package])
-> (Package -> [Package]) -> Package -> [Package]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Package -> [Package]
lines
(Package -> [[Package]]) -> IO Package -> IO [[Package]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Package -> [Package] -> IO Package
readProcess Package
"virsh" [Package]
args
hostSystem :: Host -> Maybe System
hostSystem :: Host -> Maybe System
hostSystem = InfoVal System -> Maybe System
forall v. InfoVal v -> Maybe v
fromInfoVal (InfoVal System -> Maybe System)
-> (Host -> InfoVal System) -> Host -> Maybe System
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Info -> InfoVal System
forall v. IsInfo v => Info -> v
fromInfo (Info -> InfoVal System)
-> (Host -> Info) -> Host -> InfoVal System
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Host -> Info
hostInfo