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

import B9.B9Config (getB9Config, libVirtLXCConfigs)
import B9.B9Config.LibVirtLXC as X
import B9.B9Exec
import B9.B9Logging
import B9.BuildInfo
import B9.DiskImages
import B9.ExecEnv
import B9.ShellScript
import Control.Eff
import Control.Lens (view)
import Control.Monad.IO.Class (liftIO)
import Data.Char (toLower)
import System.Directory
import System.FilePath
import System.IO.B9Extras (UUID(), randomUUID)
import Text.Printf (printf)

logLibVirtLXCConfig :: CommandIO e => LibVirtLXCConfig -> Eff e ()
logLibVirtLXCConfig c = traceL $ printf "USING LibVirtLXCConfig: %s" (show c)

supportedImageTypes :: [ImageType]
supportedImageTypes = [Raw]

runInEnvironment ::
     forall e. (Member BuildInfoReader e, CommandIO e)
  => ExecEnv
  -> Script
  -> Eff e Bool
runInEnvironment env scriptIn =
  if emptyScript scriptIn
    then return True
    else setUp >>= execute
  where
    setUp = do
      mcfg <- view libVirtLXCConfigs <$> getB9Config
      cfg <- maybe (fail "No LibVirtLXC Configuration!") return mcfg
      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
          setupEnv = Begin [Run "export" ["HOME=/root"], Run "export" ["USER=root"], Run "source" ["/etc/profile"]]
          script = Begin [setupEnv, 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 -> Eff e Bool
    execute (Context scriptDirHost _uuid domainFile cfg) = do
      let virsh = virshCommand cfg
      cmd $ printf "%s create '%s' --console --autodestroy" virsh domainFile
    -- cmd $ printf "%s console %U" virsh uuid
      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

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 cfg e ++
  "'>" ++
  memoryAmount cfg e ++
  "</memory>\n  <currentMemory unit='" ++
  memoryUnit cfg e ++
  "'>" ++
  memoryAmount cfg 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 :: LibVirtLXCConfig -> ExecEnv -> String
memoryUnit cfg = toUnit . maxMemory . envResources
  where
    toUnit AutomaticRamSize = toUnit (guestRamSize cfg)
    toUnit (RamSize _ u) =
      case u of
        GB -> "GiB"
        MB -> "MiB"
        KB -> "KiB"
        B -> "B"

memoryAmount :: LibVirtLXCConfig -> ExecEnv -> String
memoryAmount cfg = show . toAmount . maxMemory . envResources
  where
    toAmount AutomaticRamSize = toAmount (guestRamSize cfg)
    toAmount (RamSize n _) = n

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