-- | 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 -- TODO: | QCow2

-- | Install basic libvirt components
installed :: Property DebianLike
installed = Apt.installed ["libvirt-clients", "virtinst", "libvirt-daemon", "libvirt-daemon-system"]

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