{-| Implementation of an execution environment that uses "libvirt-lxc". -}
module B9.LibVirtLXC ( runInEnvironment
                     , supportedImageTypes
                     , setDefaultConfig
                     ) where

import Control.Applicative
import Control.Monad.IO.Class ( liftIO )
import System.Directory
import System.FilePath
import Text.Printf ( printf )
import Data.Char (toLower)

import B9.ShellScript
import B9.B9Monad
import B9.DiskImages
import B9.ExecEnv
import B9.ConfigUtils

lxcDefaultRamSize :: RamSize
lxcDefaultRamSize = RamSize 1 GB

supportedImageTypes :: [ImageType]
supportedImageTypes = [Raw]

runInEnvironment :: ExecEnv -> Script -> B9 Bool
runInEnvironment env scriptIn =
  if emptyScript scriptIn
    then return True
    else setUp >>= execute
  where
    setUp = do
      cfg <- configureLibVirtLXC
      buildId <- getBuildId
      buildBaseDir <- getBuildDir
      uuid <- randomUUID
      let scriptDirHost = buildDir </> "init-script"
          scriptDirGuest = "/" ++ buildId
          domainFile = buildBaseDir </> uuid' <.> domainConfig
          domain = createDomain cfg env buildId uuid' scriptDirHost scriptDirGuest
          uuid' = printf "%U" uuid
          script = Begin [scriptIn, successMarkerCmd scriptDirGuest]
          buildDir = buildBaseDir </> uuid'
      liftIO $ do
        createDirectoryIfMissing True scriptDirHost
        writeSh (scriptDirHost </> initScript) script
        writeFile domainFile domain
      return $ Context scriptDirHost uuid domainFile cfg

    successMarkerCmd scriptDirGuest =
      In scriptDirGuest [Run "touch" [successMarkerFile]]

    execute (Context scriptDirHost uuid domainFile cfg) = do
      let virsh = virshCommand cfg
      cmd $ printf "%s create '%s'" virsh domainFile
      cmd $ printf "%s console %U" virsh uuid
      checkSuccessMarker scriptDirHost

    checkSuccessMarker scriptDirHost =
      liftIO (doesFileExist $ scriptDirHost </> successMarkerFile)

    successMarkerFile = "SUCCESS"

    virshCommand :: LibVirtLXCConfig -> String
    virshCommand cfg = printf "%s%s -c %s" useSudo' virshPath' virshURI'
      where
        useSudo' = if useSudo cfg
                     then "sudo "
                     else ""
        virshPath' = virshPath cfg
        virshURI' = virshURI cfg

data Context = Context FilePath UUID FilePath LibVirtLXCConfig

data LibVirtLXCConfig = LibVirtLXCConfig { useSudo :: Bool
                                         , virshPath :: FilePath
                                         , emulator :: FilePath
                                         , virshURI :: FilePath
                                         , networkId :: Maybe String
                                         , guestCapabilities :: [LXCGuestCapability]
                                         } deriving (Read, Show)

-- | Available linux capabilities for lxc containers. This maps directly to the
-- capabilities defined in 'man 7 capabilities'.
data LXCGuestCapability = CAP_MKNOD
                        | CAP_AUDIT_CONTROL
                        | CAP_AUDIT_READ
                        | CAP_AUDIT_WRITE
                        | CAP_BLOCK_SUSPEND
                        | CAP_CHOWN
                        | CAP_DAC_OVERRIDE
                        | CAP_DAC_READ_SEARCH
                        | CAP_FOWNER
                        | CAP_FSETID
                        | CAP_IPC_LOCK
                        | CAP_IPC_OWNER
                        | CAP_KILL
                        | CAP_LEASE
                        | CAP_LINUX_IMMUTABLE
                        | CAP_MAC_ADMIN
                        | CAP_MAC_OVERRIDE
                        | CAP_NET_ADMIN
                        | CAP_NET_BIND_SERVICE
                        | CAP_NET_BROADCAST
                        | CAP_NET_RAW
                        | CAP_SETGID
                        | CAP_SETFCAP
                        | CAP_SETPCAP
                        | CAP_SETUID
                        | CAP_SYS_ADMIN
                        | CAP_SYS_BOOT
                        | CAP_SYS_CHROOT
                        | CAP_SYS_MODULE
                        | CAP_SYS_NICE
                        | CAP_SYS_PACCT
                        | CAP_SYS_PTRACE
                        | CAP_SYS_RAWIO
                        | CAP_SYS_RESOURCE
                        | CAP_SYS_TIME
                        | CAP_SYS_TTY_CONFIG
                        | CAP_SYSLOG
                        | CAP_WAKE_ALARM
  deriving (Read, Show)

defaultLibVirtLXCConfig :: LibVirtLXCConfig
defaultLibVirtLXCConfig = LibVirtLXCConfig
                            True
                            "/usr/bin/virsh"
                            "/usr/lib/libvirt/libvirt_lxc"
                            "lxc:///"
                            Nothing
                            [ CAP_MKNOD
                            , CAP_SYS_ADMIN
                            , CAP_SYS_CHROOT
                            , CAP_SETGID
                            , CAP_SETUID
                            , CAP_NET_BIND_SERVICE
                            , CAP_SETPCAP
                            , CAP_SYS_PTRACE
                            , CAP_SYS_MODULE
                            ]

cfgFileSection :: String
cfgFileSection = "libvirt-lxc"
useSudoK :: String
useSudoK = "use_sudo"
virshPathK :: String
virshPathK = "virsh_path"
emulatorK :: String
emulatorK = "emulator_path"
virshURIK :: String
virshURIK = "connection"
networkIdK :: String
networkIdK = "network"
guestCapabilitiesK :: String
guestCapabilitiesK = "guest_capabilities"

configureLibVirtLXC :: B9 LibVirtLXCConfig
configureLibVirtLXC = do
  c <- readLibVirtConfig
  traceL $ printf "USING LibVirtLXCConfig: %s" (show c)
  return c

setDefaultConfig :: ConfigParser
setDefaultConfig = either (error . show) id eitherCp
  where
    eitherCp = do
      let cp = emptyCP
          c = defaultLibVirtLXCConfig
      cp1 <- add_section cp cfgFileSection
      cp2 <- setshow cp1 cfgFileSection useSudoK $ useSudo c
      cp3 <- set cp2 cfgFileSection virshPathK $ virshPath c
      cp4 <- set cp3 cfgFileSection emulatorK $ emulator c
      cp5 <- set cp4 cfgFileSection virshURIK $ virshURI c
      cp6 <- setshow cp5 cfgFileSection networkIdK $ networkId c
      setshow cp6 cfgFileSection guestCapabilitiesK $ guestCapabilities c

readLibVirtConfig :: B9 LibVirtLXCConfig
readLibVirtConfig =
  do
    cp <- getConfigParser
    let geto :: (Get_C a, Read a)
             => OptionSpec -> a -> a
        geto = getOptionOr cp cfgFileSection
    return $
      LibVirtLXCConfig { useSudo = geto useSudoK $
                         useSudo defaultLibVirtLXCConfig
                       , virshPath = geto virshPathK $
                         virshPath defaultLibVirtLXCConfig
                       , emulator = geto emulatorK $
                         emulator defaultLibVirtLXCConfig
                       , virshURI = geto virshURIK $
                         virshURI defaultLibVirtLXCConfig
                       , networkId = geto networkIdK $
                         networkId defaultLibVirtLXCConfig
                       , guestCapabilities = geto guestCapabilitiesK $
                         guestCapabilities defaultLibVirtLXCConfig
                       }

initScript :: String
initScript = "init.sh"

domainConfig :: String
domainConfig = "domain.xml"

createDomain :: LibVirtLXCConfig
             -> ExecEnv
             -> String
             -> String
             -> FilePath
             -> FilePath
             -> String
createDomain cfg e buildId uuid scriptDirHost scriptDirGuest =
  "<domain type='lxc'>\n\
  \  <name>" ++ buildId ++ "</name>\n\
  \  <uuid>" ++ uuid ++ "</uuid>\n\
  \  <memory unit='" ++ memoryUnit e ++ "'>" ++ memoryAmount e ++ "</memory>\n\
  \  <currentMemory unit='" ++ memoryUnit e ++ "'>" ++ memoryAmount e ++ "</currentMemory>\n\
  \  <vcpu placement='static'>" ++ cpuCountStr e ++ "</vcpu>\n\
  \  <features>\n\
  \   <capabilities policy='default'>\n\
  \     "++ renderGuestCapabilityEntries cfg  ++"\n\
  \   </capabilities>\n\
  \  </features>\n\
  \  <os>\n\
  \    <type arch='" ++ osArch e ++ "'>exe</type>\n\
  \    <init>" ++ scriptDirGuest </> initScript ++ "</init>\n\
  \  </os>\n\
  \  <clock offset='utc'/>\n\
  \  <on_poweroff>destroy</on_poweroff>\n\
  \  <on_reboot>restart</on_reboot>\n\
  \  <on_crash>destroy</on_crash>\n\
  \  <devices>\n\
  \    <emulator>" ++ emulator cfg ++ "</emulator>\n"
  ++ unlines (libVirtNetwork (networkId cfg) ++
              (fsImage <$> (envImageMounts e)) ++
              (fsSharedDir <$> (envSharedDirectories e))) ++ "\n" ++
  "    <filesystem type='mount'>\n\
  \      <source dir='" ++ scriptDirHost ++ "'/>\n\
  \      <target dir='" ++ scriptDirGuest ++ "'/>\n\
  \    </filesystem>\n\
  \    <console>\n\
  \      <target type='lxc' port='0'/>\n\
  \    </console>\n\
  \  </devices>\n\
  \</domain>\n"

renderGuestCapabilityEntries :: LibVirtLXCConfig -> String
renderGuestCapabilityEntries = unlines . map render . guestCapabilities
  where
    render :: LXCGuestCapability -> String
    render cap =
      let capStr = toLower <$> drop (length "CAP_") (show cap)
      in printf "<%s state='on'/>" capStr

osArch :: ExecEnv -> String
osArch e = case cpuArch (envResources e) of
            X86_64 -> "x86_64"
            I386 -> "i686"

libVirtNetwork :: Maybe String -> [String]
libVirtNetwork Nothing = []
libVirtNetwork (Just n) =
  [ "<interface type='network'>"
  , "  <source network='" ++ n ++ "'/>"
  , "</interface>" ]

fsImage :: (Image, MountPoint) -> String
fsImage (img, mnt) =
  case fsTarget mnt of
    Just mntXml ->
      "<filesystem type='file' accessmode='passthrough'>\n  " ++
      fsImgDriver img ++ "\n  " ++ fsImgSource img ++ "\n  " ++ mntXml ++
                                                                "\n</filesystem>"
    Nothing ->
      ""
  where
    fsImgDriver (Image _img fmt _fs) =
      printf "<driver %s %s/>" driver fmt'
      where
        (driver, fmt') =
          case fmt of
            Raw   -> ("type='loop'", "format='raw'")
            QCow2 -> ("type='nbd'", "format='qcow2'")
            Vmdk  -> ("type='nbd'", "format='vmdk'")

    fsImgSource (Image src _fmt _fs) = "<source file='" ++ src ++ "'/>"

fsSharedDir :: SharedDirectory -> String
fsSharedDir (SharedDirectory hostDir mnt) =
  case fsTarget mnt of
    Just mntXml ->
      "<filesystem type='mount'>\n  " ++
      "<source dir='" ++ hostDir ++ "'/>" ++ "\n  " ++ mntXml ++
      "\n</filesystem>"
    Nothing ->
      ""
fsSharedDir (SharedDirectoryRO hostDir mnt) =
  case fsTarget mnt of
    Just mntXml ->
      "<filesystem type='mount'>\n  " ++
      "<source dir='" ++ hostDir ++ "'/>" ++ "\n  " ++ mntXml ++
      "\n  <readonly />\n</filesystem>"
    Nothing ->
      ""
fsSharedDir (SharedSources _) =
  error "Unreachable code reached!"

fsTarget :: MountPoint -> Maybe String
fsTarget (MountPoint dir) = Just $ "<target dir='" ++ dir ++ "'/>"
fsTarget _ = Nothing

memoryUnit :: ExecEnv -> String
memoryUnit = toUnit . maxMemory . envResources
  where
    toUnit AutomaticRamSize = toUnit lxcDefaultRamSize
    toUnit (RamSize _ u) =
      case u of
        GB -> "GiB"
        MB -> "MiB"
        KB -> "KiB"
        B  -> "B"
memoryAmount :: ExecEnv -> String
memoryAmount = show . toAmount . maxMemory . envResources
  where
    toAmount AutomaticRamSize = toAmount lxcDefaultRamSize
    toAmount (RamSize n _) = n

cpuCountStr :: ExecEnv -> String
cpuCountStr = show . cpuCount . envResources