{-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  System.LXC.Internal.Container
-- Copyright   :  (c) Nickolay Kudasov 2014
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  nickolay.kudasov@gmail.com
--
-- Internal module to provide a set of functions to create,
-- control and manage LXC containers.
-- Normally you should import @System.LXC@ module only.
--
-----------------------------------------------------------------------------
module System.LXC.Internal.Container where

import Bindings.LXC.AttachOptions
import Bindings.LXC.Container
import Bindings.LXC.Sys.Types

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
#endif
import Control.Monad
import Control.Monad.Reader

import Data.Maybe
import Data.Word

import Foreign
import Foreign.C

import System.LXC.Internal.AttachOptions
import System.LXC.Internal.Utils

import System.Exit
import System.Posix.Types (ProcessID, Fd)

type ContainerCreateFn = Ptr C'lxc_container -> CString -> CString -> Ptr C'bdev_specs -> CInt -> Ptr CString -> IO CBool
foreign import ccall "dynamic"
  mkCreateFn :: FunPtr ContainerCreateFn -> ContainerCreateFn

type ContainerCloneFn = Ptr C'lxc_container -> CString -> CString -> CInt -> CString -> CString -> C'uint64_t -> Ptr CString -> IO (Ptr C'lxc_container)
foreign import ccall "dynamic"
  mkCloneFn :: FunPtr ContainerCloneFn -> ContainerCloneFn

type ContainerBoolFn = Ptr C'lxc_container -> IO CBool
foreign import ccall "dynamic"
  mkBoolFn :: FunPtr ContainerBoolFn -> ContainerBoolFn

type ContainerStringFn = Ptr C'lxc_container -> IO CString
foreign import ccall "dynamic"
  mkStringFn :: FunPtr ContainerStringFn -> ContainerStringFn

type ContainerProcessIDFn = Ptr C'lxc_container -> IO C'pid_t
foreign import ccall "dynamic"
  mkProcessIDFn :: FunPtr ContainerProcessIDFn -> ContainerProcessIDFn

type ContainerStringBoolFn = Ptr C'lxc_container -> CString -> IO CBool
foreign import ccall "dynamic"
  mkStringBoolFn :: FunPtr ContainerStringBoolFn -> ContainerStringBoolFn

type ContainerBoolBoolFn = Ptr C'lxc_container -> CBool -> IO CBool
foreign import ccall "dynamic"
  mkBoolBoolFn :: FunPtr ContainerBoolBoolFn -> ContainerBoolBoolFn

type ContainerStartFn = Ptr C'lxc_container -> CInt -> Ptr CString -> IO CBool
foreign import ccall "dynamic"
  mkStartFn :: FunPtr ContainerStartFn -> ContainerStartFn

type ContainerShutdownFn = Ptr C'lxc_container -> CInt -> IO CBool
foreign import ccall "dynamic"
  mkShutdownFn :: FunPtr ContainerShutdownFn -> ContainerShutdownFn

type ContainerClearConfigFn = Ptr C'lxc_container -> IO ()
foreign import ccall "dynamic"
  mkClearConfigFn :: FunPtr ContainerClearConfigFn -> ContainerClearConfigFn

type ContainerGetRunningConfigItemFn = Ptr C'lxc_container -> CString -> IO CString
foreign import ccall "dynamic"
  mkGetRunningConfigItemFn :: FunPtr ContainerGetRunningConfigItemFn -> ContainerGetRunningConfigItemFn

type ContainerGetItemFn = Ptr C'lxc_container -> CString -> CString -> CInt -> IO CInt
foreign import ccall "dynamic"
  mkGetItemFn :: FunPtr ContainerGetItemFn -> ContainerGetItemFn

type ContainerSetItemFn = Ptr C'lxc_container -> CString -> CString -> IO CBool
foreign import ccall "dynamic"
  mkSetItemFn :: FunPtr ContainerSetItemFn -> ContainerSetItemFn

type ContainerGetInterfacesFn = Ptr C'lxc_container -> IO (Ptr CString)
foreign import ccall "dynamic"
  mkGetInterfacesFn :: FunPtr ContainerGetInterfacesFn -> ContainerGetInterfacesFn

type ContainerGetIPsFn = Ptr C'lxc_container -> CString -> CString -> CInt -> IO (Ptr CString)
foreign import ccall "dynamic"
  mkGetIPsFn :: FunPtr ContainerGetIPsFn -> ContainerGetIPsFn

type ContainerWaitFn = Ptr C'lxc_container -> CString -> CInt -> IO CBool
foreign import ccall "dynamic"
  mkWaitFn :: FunPtr ContainerWaitFn -> ContainerWaitFn

type ContainerSnapshotFn = Ptr C'lxc_container -> CString -> IO CInt
foreign import ccall "dynamic"
  mkSnapshotFn :: FunPtr ContainerSnapshotFn -> ContainerSnapshotFn

type ContainerSnapshotListFn = Ptr C'lxc_container -> Ptr (Ptr C'lxc_snapshot) -> IO CInt
foreign import ccall "dynamic"
  mkSnapshotListFn :: FunPtr ContainerSnapshotListFn -> ContainerSnapshotListFn

type ContainerConsoleGetFDFn = Ptr C'lxc_container -> Ptr CInt -> Ptr CInt -> IO CInt
foreign import ccall "dynamic"
  mkConsoleGetFDFn :: FunPtr ContainerConsoleGetFDFn -> ContainerConsoleGetFDFn

type ContainerConsoleFn = Ptr C'lxc_container -> CInt -> CInt -> CInt -> CInt -> CInt -> IO CInt
foreign import ccall "dynamic"
  mkConsoleFn :: FunPtr ContainerConsoleFn -> ContainerConsoleFn

type ContainerAttachFn = Ptr C'lxc_container -> C_lxc_attach_exec_t -> Ptr () -> Ptr C'lxc_attach_options_t -> Ptr C'pid_t -> IO CInt
foreign import ccall "dynamic"
  mkAttachFn :: FunPtr ContainerAttachFn -> ContainerAttachFn

type ContainerAttachRunWaitFn = Ptr C'lxc_container -> Ptr C'lxc_attach_options_t -> CString -> Ptr CString -> IO CInt
foreign import ccall "dynamic"
  mkAttachRunWaitFn :: FunPtr ContainerAttachRunWaitFn -> ContainerAttachRunWaitFn

type SnapshotFreeFn = Ptr C'lxc_snapshot -> IO ()
foreign import ccall "dynamic"
  mkFreeFn :: FunPtr SnapshotFreeFn -> SnapshotFreeFn

-- | LXC container-related computations.
-- @'LXC' ~ 'ReaderT' ('String', 'Ptr' 'C'lxc_container') 'IO'@.
--
-- Run @'LXC' a@ computations using 'withContainer'.
newtype LXC a = LXC { runLXC :: ReaderT (String, Ptr C'lxc_container) IO a }
  deriving (Functor, Applicative, Monad, MonadReader (String, Ptr C'lxc_container), MonadIO)

lxc :: (Ptr C'lxc_container -> IO a) -> LXC a
lxc f = LXC . ReaderT $ \(_, p) -> f p

-- | Run @'LXC' a@ computation for a given 'Container'.
--
-- * for the whole computation a single @lxc_container@ structure
-- will be allocated; it will be automatically freed at the end of
-- computation.
withContainer :: MonadIO m => Container -> LXC a -> m a
withContainer c m = liftIO $ do
  withC'lxc_container c $ \cc -> do
    runReaderT (runLXC m) $ (containerName c, cc)

-- | LXC error structure.
data LXCError = LXCError
  { lxcErrorString  :: String   -- ^ Error message.
  , lxcErrorNum     :: Int      -- ^ Error number.
  }
  deriving (Show)

-- | Pretty print LXC error message.
prettyLXCError :: LXCError -> String
prettyLXCError (LXCError msg num) = "Error " ++ show num ++ ": " ++ msg

-- | Options for 'clone' operation.
data CloneOption
  = CloneKeepName        -- ^ Do not edit the rootfs to change the hostname.
  | CloneKeepMacAddr     -- ^ Do not change the MAC address on network interfaces.
  | CloneSnapshot        -- ^ Snapshot the original filesystem(s).
  | CloneKeepBDevType    -- ^ Use the same bdev type.
  | CloneMaybeSnapshot   -- ^ Snapshot only if bdev supports it, else copy.
  | CloneMaxFlags        -- ^ Number of @LXC_CLONE_*@ flags.
  deriving (Eq, Ord)

-- | Options for 'create' operation.
data CreateOption
  = CreateQuiet          -- ^ Redirect @stdin@ to @\/dev\/zero@ and @stdout@ and @stderr@ to @\/dev\/null@.
  | CreateMaxFlags       -- ^ Number of @LXC_CREATE*@ flags.
  deriving (Eq, Ord)

-- | Turn 'CloneOption' into a bit flag.
cloneFlag :: Num a => CloneOption -> a
cloneFlag CloneKeepName       = c'LXC_CLONE_KEEPNAME
cloneFlag CloneKeepMacAddr    = c'LXC_CLONE_KEEPMACADDR
cloneFlag CloneSnapshot       = c'LXC_CLONE_SNAPSHOT
cloneFlag CloneKeepBDevType   = c'LXC_CLONE_KEEPBDEVTYPE
cloneFlag CloneMaybeSnapshot  = c'LXC_CLONE_MAYBE_SNAPSHOT
cloneFlag CloneMaxFlags       = c'LXC_CLONE_MAXFLAGS

-- | Turn 'CreateOption' into a bit flag.
createFlag :: Num a => CreateOption -> a
createFlag CreateQuiet    = c'LXC_CREATE_QUIET
createFlag CreateMaxFlags = c'LXC_CREATE_MAXFLAGS

-- | An LXC container snapshot.
data Snapshot = Snapshot
  { snapshotName            :: String         -- ^ Name of snapshot.
  , snapshotCommentPathname :: Maybe FilePath -- ^ Full path to snapshots comment file.
  , snapshotTimestamp       :: String         -- ^ Time snapshot was created.
  , snapshotLXCPath         :: FilePath       -- ^ Full path to @LXCPATH@ for snapshot.
  }
  deriving (Show)

-- | Container object.
data Container = Container
  { containerName       :: String         -- ^ Container name.
  , containerConfigPath :: Maybe String   -- ^ Container config path.
  }
  deriving (Show)

-- | Allocate a new @lxc_container@.
newC'lxc_container :: Container -> IO (Ptr C'lxc_container)
newC'lxc_container (Container name configPath) = do
  c <- withCString name $ \cname ->
        maybeWith withCString configPath $ \cconfigPath ->
          c'lxc_container_new cname cconfigPath
  when (c == nullPtr) $ error "failed to allocate new container"
  return c

peekC'lxc_container :: Ptr C'lxc_container -> IO (String -> Container)
peekC'lxc_container ptr = do
  configPath <- peek (p'lxc_container'config_path ptr) >>= maybePeek peekCString
  return $ \name -> Container name configPath

-- | Marshal 'Container' to @lxc_container@ using temporary storage.
withC'lxc_container :: Container -> (Ptr C'lxc_container -> IO a) -> IO a
withC'lxc_container c f = do
  cc <- newC'lxc_container c
  ret <- f cc
  _ <- dropRef cc
  return ret

-- | Container state.
data ContainerState
  = ContainerStopped            -- ^ Container is stopped.
  | ContainerStarting           -- ^ Container is starting.
  | ContainerRunning            -- ^ Container is running.
  | ContainerStopping           -- ^ Container is stopping.
  | ContainerAborting           -- ^ Container is aborting.
  | ContainerFreezing           -- ^ Container is freezing.
  | ContainerFrozen             -- ^ Container is frozen.
  | ContainerThawed             -- ^ Container is thawed.
  | ContainerOtherState String  -- ^ Container is in some other state.
  deriving (Eq, Show)

-- | Parse state as string representation.
parseState :: String -> ContainerState
parseState "STOPPED"  = ContainerStopped
parseState "STARTING" = ContainerStarting
parseState "RUNNING"  = ContainerRunning
parseState "STOPPING" = ContainerStopping
parseState "ABORTING" = ContainerAborting
parseState "FREEZING" = ContainerFreezing
parseState "FROZEN"   = ContainerFrozen
parseState "THAWED"   = ContainerThawed
parseState s          = ContainerOtherState s

-- | Get string representation of a state.
printState :: ContainerState -> String
printState ContainerStopped         = "STOPPED"
printState ContainerStarting        = "STARTING"
printState ContainerRunning         = "RUNNING"
printState ContainerStopping        = "STOPPING"
printState ContainerAborting        = "ABORTING"
printState ContainerFreezing        = "FREEZING"
printState ContainerFrozen          = "FROZEN"
printState ContainerThawed          = "THAWED"
printState (ContainerOtherState s)  = s

-- | Specifications for how to create a new backing store.
data BDevSpecs = BDevSpecs
  { bdevFSType                :: String         -- ^ Filesystem type.
  , bdevFSSize                :: Word64         -- ^ Filesystem size in bytes.
  , bdevZFSRootPath           :: FilePath       -- ^ ZFS root path.
  , bdevLVMVolumeGroupName    :: String         -- ^ LVM Volume Group name.
  , bdevLVMLogicalVolumeName  :: String         -- ^ LVM Logical Volume name.
  , bdevLVMThinPool           :: Maybe String   -- ^ LVM thin pool to use, if any.
  , bdevDirectory             :: FilePath       -- ^ Directory path.
  }
  deriving (Show)

-- | Marshal Haskell 'BDevSpecs' into C structure using temporary storage.
--
-- * the memory is freed when the subcomputation terminates (either
--   normally or via an exception), so the pointer to the temporary
--   storage must /not/ be used after this.
withC'bdev_specs :: BDevSpecs -> (Ptr C'bdev_specs -> IO a) -> IO a
withC'bdev_specs specs f = do
  withCString (bdevFSType                        specs) $ \cFSType ->
    withCString (bdevZFSRootPath                 specs) $ \cZFSRootPath ->
      withCString (bdevLVMVolumeGroupName        specs) $ \cLVMVolumeGroupName ->
        withCString (bdevLVMLogicalVolumeName    specs) $ \cLVMLogicalVolumeName ->
          maybeWith withCString (bdevLVMThinPool specs) $ \cLVMThinPool ->
            withCString (bdevDirectory           specs) $ \cDirectory -> do
              let cspecs = C'bdev_specs
                              cFSType
                              (bdevFSSize specs)
                              (C'zfs_t cZFSRootPath)
                              (C'lvm_t
                                cLVMVolumeGroupName
                                cLVMLogicalVolumeName
                                cLVMThinPool)
                              cDirectory
              with cspecs f

type Field s a = Ptr s -> Ptr a

mkFn :: (FunPtr (Ptr s -> a) -> (Ptr s -> a)) -> Field s (FunPtr (Ptr s -> a)) -> Ptr s -> IO a
mkFn mk g s = do
  fn <- peek (g s)
  return $ mk fn s

boolFn :: Field C'lxc_container (FunPtr ContainerBoolFn) -> LXC Bool
boolFn g = lxc $ \c -> do
  fn <- mkFn mkBoolFn g c
  toBool <$> fn

stringBoolFn :: Field C'lxc_container (FunPtr ContainerStringBoolFn) -> Maybe String -> LXC Bool
stringBoolFn g s = lxc $ \c -> do
  fn <- mkFn mkStringBoolFn g c
  maybeWith withCString s $ \cs ->
    toBool <$> fn cs

boolBoolFn :: Field C'lxc_container (FunPtr ContainerBoolBoolFn) -> Bool -> LXC Bool
boolBoolFn g b = lxc $ \c -> do
  fn <- mkFn mkBoolBoolFn g c
  toBool <$> fn (if b then 1 else 0)

getItemFn :: Field C'lxc_container (FunPtr ContainerGetItemFn) -> String -> LXC (Maybe String)
getItemFn g s = lxc $ \c -> do
  fn <- mkFn mkGetItemFn g c
  withCString s $ \cs -> do
    -- call with NULL for retv to determine size of a buffer we need to allocate
    sz <- fn cs nullPtr 0
    if (sz < 0)
      then return Nothing
      else allocaBytes (fromIntegral sz) $ \cretv -> do
        -- we call fn second time to actually get item into cretv buffer
        _ <- fn cs cretv sz
        Just <$> peekCString cretv

setItemFn :: Field C'lxc_container (FunPtr ContainerSetItemFn) -> String -> Maybe String -> LXC Bool
setItemFn g k v = lxc $ \c -> do
  fn <- mkFn mkSetItemFn g c
  withCString k $ \ck ->
    maybeWith withCString v $ \cv ->
      toBool <$> fn ck cv

setItemFn' :: Field C'lxc_container (FunPtr ContainerSetItemFn) -> String -> String -> LXC Bool
setItemFn' g k v = setItemFn g k (Just v)

-- | Whether container wishes to be daemonized.
getDaemonize :: LXC Bool
getDaemonize = lxc $ \c -> toBool <$> peek (p'lxc_container'daemonize c)

-- | Get last container's error.
getLastError :: LXC (Maybe LXCError)
getLastError = lxc $ \c -> do
  cmsg <- peek (p'lxc_container'error_string c)
  msg  <- maybePeek peekCString cmsg
  num  <- fromIntegral <$> peek (p'lxc_container'error_num c)
  return $ LXCError <$> msg <*> pure num

-- | Determine if @\/var\/lib\/lxc\/\$name\/config@ exists.
--
-- @True@ if container is defined, else @False@.
isDefined :: LXC Bool
isDefined = boolFn p'lxc_container'is_defined

-- | Determine if container is running.
--
-- @True@ on success, else @False@.
isRunning :: LXC Bool
isRunning = boolFn p'lxc_container'is_running

-- | Determine state of container.
state :: LXC ContainerState
state = lxc $ \c -> do
  fn <- peek (p'lxc_container'state c)
  cs <- mkStringFn fn c  -- we do not need to free cs
  parseState <$> peekCString cs

-- | Freeze running container.
--
-- @True@ on success, else @False@.
freeze :: LXC Bool
freeze = boolFn p'lxc_container'freeze

-- | Thaw a frozen container.
--
-- @True@ on success, else @False@.
unfreeze :: LXC Bool
unfreeze = boolFn p'lxc_container'unfreeze

-- | Determine process ID of the containers init process.
initPID :: LXC (Maybe ProcessID)
initPID = lxc $ \c -> do
  fn <- mkFn mkProcessIDFn p'lxc_container'init_pid c
  pid <- fromIntegral <$> fn
  if (pid < 0)
    then return Nothing
    else return (Just pid)

-- | Load the specified configuration for the container.
loadConfig :: Maybe FilePath  -- ^ Full path to alternate configuration file, or @Nothing@ to use the default configuration file.
           -> LXC Bool        -- ^ @True@ on success, else @False@.
loadConfig = stringBoolFn p'lxc_container'load_config

-- | Start the container.
start :: Bool       -- ^ Use @lxcinit@ rather than @\/sbin\/init@.
      -> [String]   -- ^ Array of arguments to pass to init.
      -> LXC Bool   -- ^ @True@ on success, else @False@.
start useinit argv = lxc $ \c -> do
  fn <- mkFn mkStartFn p'lxc_container'start c
  case argv of
    [] -> toBool <$> fn (fromBool useinit) nullPtr
    _  -> do
      withMany withCString argv $ \cargv ->
        withArray0 nullPtr cargv $ \cargv' ->
          toBool <$> fn (fromBool useinit) cargv'

-- | Stop the container.
--
-- @True@ on success, else @False@.
stop :: LXC Bool
stop = boolFn p'lxc_container'stop

-- | Determine if the container wants to run disconnected from the terminal.
wantDaemonize :: Bool       -- ^ Value for the daemonize bit.
              -> LXC Bool   -- ^ @True@ if container wants to be daemonised, else @False@.
wantDaemonize = boolBoolFn p'lxc_container'want_daemonize

-- | Determine whether container wishes all file descriptors to be closed on startup.
wantCloseAllFDs :: Bool       -- ^ Value for the @close_all_fds@ bit.
                -> LXC Bool   -- ^ @True@ if container wants to be daemonised, else @False@.
wantCloseAllFDs = boolBoolFn p'lxc_container'want_close_all_fds

-- | Return current config file name.
configFileName :: LXC (Maybe FilePath)
configFileName = lxc $ \c -> do
  fn <- peek (p'lxc_container'config_file_name c)
  cs <- mkStringFn fn c
  s <- maybePeek peekCString cs
  when (isJust s) $ free cs
  return s

-- | Wait for container to reach a particular state.
--
-- * A timeout of @-1@ means wait forever.
-- A timeout @0@ means do not wait.
wait :: ContainerState  -- ^ State to wait for.
     -> Int             -- ^ Timeout in seconds.
     -> LXC Bool        -- ^ @True@ if state reached within timeout, else @False@.
wait s t = lxc $ \c -> do
  fn <- mkFn mkWaitFn p'lxc_container'wait c
  withCString (printState s) $ \cs ->
    toBool <$> fn cs (fromIntegral t)

-- | Set a key/value configuration option.
setConfigItem :: String     -- ^ Name of option to set.
              -> String     -- ^ Value to set.
              -> LXC Bool   -- ^ @True@ on success, else @False@.
setConfigItem = setItemFn' p'lxc_container'set_config_item

-- | Delete the container.
--
-- @True@ on success, else @False@.
--
-- * NOTE: Container must be stopped and have no dependent snapshots.
destroy :: LXC Bool
destroy = boolFn p'lxc_container'destroy

-- | Save configuaration to a file.
saveConfig :: FilePath    -- ^ Full path to file to save configuration in.
           -> LXC Bool    -- ^ @True@ on success, else @False@.
saveConfig s = stringBoolFn p'lxc_container'save_config (Just s)

-- | Rename a container.
rename :: String      -- ^ New name to be used for the container.
       -> LXC Bool    -- ^ @True@ on success, else @False@.
rename s = stringBoolFn p'lxc_container'rename (Just s)

-- | Request the container reboot by sending it @SIGINT@.
--
--  @True@ if reboot request successful, else @False@.
reboot :: LXC Bool
reboot = boolFn p'lxc_container'reboot

-- | Request the container shutdown by sending it @SIGPWR@.
shutdown :: Int         -- ^ Seconds to wait before returning false. (@-1@ to wait forever, @0@ to avoid waiting).
         -> LXC Bool    -- ^ @True@ if the container was shutdown successfully, else @False@.
shutdown n = lxc $ \c -> do
  fn <- mkFn mkShutdownFn p'lxc_container'shutdown c
  toBool <$> fn (fromIntegral n)

-- | Completely clear the containers in-memory configuration.
clearConfig :: LXC ()
clearConfig = lxc $ join . mkFn mkClearConfigFn p'lxc_container'clear_config

-- | Retrieve the value of a config item.
getConfigItem :: String             -- ^ Name of option to get.
              -> LXC (Maybe String) -- ^ The item or @Nothing@ on error.
getConfigItem = getItemFn p'lxc_container'get_config_item

-- | Retrieve the value of a config item from running container.
getRunningConfigItem :: String              -- ^ Name of option to get.
                     -> LXC (Maybe String)  -- ^ The item or @Nothing@ on error.
getRunningConfigItem k = lxc $ \c -> do
  fn <- mkFn mkGetRunningConfigItemFn p'lxc_container'get_running_config_item c
  withCString k $ \ck -> do
    cv <- fn ck
    v <- maybePeek peekCString cv
    when (isJust v) $ free cv
    return v

-- | Retrieve a list of config item keys given a key prefix.
getKeys :: String        -- ^ Key prefix.
        -> LXC [String]  -- ^ List of keys.
getKeys kp = concatMap lines . maybeToList <$> getItemFn p'lxc_container'get_keys kp

-- | Obtain a list of network interfaces.
getInterfaces :: LXC [String]
getInterfaces = lxc $ \c -> do
  cifs  <- join $ mkFn mkGetInterfacesFn p'lxc_container'get_interfaces c
  if (cifs == nullPtr)
    then return []
    else do
      cifs' <- peekArray0 nullPtr cifs
      ifs   <- mapM peekCString cifs'
      mapM_ free cifs'
      free cifs
      return ifs

-- | Determine the list of container IP addresses.
getIPs :: String        -- ^ Network interface name to consider.
       -> String        -- ^ Network family (for example @"inet"@, @"inet6"@).
       -> Word32        -- ^ IPv6 scope id (ignored if family is not "inet6").
       -> LXC [String]  -- ^ A list of network interfaces.
getIPs iface fam sid = lxc $ \c -> do
  fn <- mkFn mkGetIPsFn p'lxc_container'get_ips c
  withCString iface $ \ciface ->
    withCString fam $ \cfam -> do
      cips  <- fn ciface cfam (fromIntegral sid)
      if (cips == nullPtr)
        then return []
        else do
          cips' <- peekArray0 nullPtr cips
          ips   <- mapM peekCString cips'
          mapM_ free cips'
          free cips
          return ips

-- | Retrieve the specified cgroup subsystem value for the container.
getCGroupItem :: String              -- ^ @cgroup@ subsystem to retrieve.
              -> LXC (Maybe String)  -- ^ @cgroup@ subsystem value or @Nothing@ on error.
getCGroupItem = getItemFn p'lxc_container'get_cgroup_item

-- | Set the specified cgroup subsystem value for the container.
setCGroupItem :: String     -- ^ @cgroup@ subsystem to consider.
              -> String     -- ^ Value to set.
              -> LXC Bool   -- ^ @True@ on success, else @False@.
setCGroupItem = setItemFn' p'lxc_container'set_cgroup_item

-- | Clear a configuration item.
--
-- Analog of 'setConfigItem'.
clearConfigItem :: String     -- ^ Name of option to clear.
                -> LXC Bool   -- ^ @True@ on success, else @False@.
clearConfigItem s = stringBoolFn p'lxc_container'clear_config_item (Just s)

-- | Determine full path to the containers configuration file.
--
-- Each container can have a custom configuration path. However
-- by default it will be set to either the @LXCPATH@ configure
-- variable, or the lxcpath value in the @LXC_GLOBAL_CONF@ configuration
-- file (i.e. @\/etc\/lxc\/lxc.conf@).
--
-- The value for a specific container can be changed using
-- 'setConfigPath'.
getConfigPath :: LXC FilePath
getConfigPath = lxc $ \c -> do
  cs <- join $ mkFn mkStringFn p'lxc_container'get_config_path c
  s <- peekCString cs
  free cs
  return s

-- | Set the full path to the containers configuration file.
setConfigPath :: FilePath   -- ^ Full path to configuration file.
              -> LXC Bool    -- ^ @True@ on success, else @False@.
setConfigPath s = stringBoolFn p'lxc_container'set_config_path (Just s)

-- | Copy a stopped container.
clone :: Maybe String   -- ^ New name for the container. If @Nothing@, the same name is used and a new lxcpath MUST be specified.
      -> Maybe FilePath -- ^ lxcpath in which to create the new container. If @Nothing@, the original container's lxcpath will be used.
      -> [CloneOption]  -- ^ Additional 'CloneOption' flags to change the cloning behaviour.
      -> Maybe String   -- ^ Optionally force the cloned bdevtype to a specified plugin. By default the original is used (subject to snapshot requirements).
      -> Maybe String   -- ^ Information about how to create the new storage (i.e. fstype and fsdata).
      -> Maybe Word64   -- ^ In case of a block device backing store, an optional size. If @Nothing@, the original backing store's size will be used if possible. Note this only applies to the rootfs. For any other filesystems, the original size will be duplicated.
      -> [String]       -- ^ Additional arguments to pass to the clone hook script.
      -> LXC (Maybe Container)  -- ^ Newly-allocated copy of container @c@, or @Nothing@ on error.
clone newname lxcpath flags bdevtype bdevdata newsize hookargs = do
  oldname <- asks fst
  lxc $ \c -> do
    c' <- maybeWith withCString newname $ \cnewname ->
            maybeWith withCString lxcpath $ \clxcpath ->
              maybeWith withCString bdevtype $ \cbdevtype ->
                maybeWith withCString bdevdata $ \cbdevdata ->
                  withMany withCString hookargs $ \chookargs ->
                    withArray0 nullPtr chookargs $ \chookargs' -> do
                      fn <- mkFn mkCloneFn p'lxc_container'clone c
                      fn
                        cnewname
                        clxcpath
                        (mkFlags cloneFlag flags)
                        cbdevtype
                        cbdevdata
                        (fromMaybe 0 newsize)
                        chookargs'
    c'' <- maybePeek peekC'lxc_container c'
    when (isJust c'') $ do
      _ <- dropRef c'
      return ()
    return $ c'' <*> pure (fromMaybe oldname newname)

-- | Allocate a console tty for the container.
--
-- * The returned file descriptor is used to keep the tty
-- allocated. The caller should call close(2) on the returned file
-- descriptor when no longer required so that it may be allocated
-- by another caller.
consoleGetFD :: Maybe Int                   -- ^ Terminal number to attempt to allocate, or @Nothing@ to allocate the first available tty.
             -> LXC (Maybe (Int, Int, Int)) -- ^ Tuple /@<fd, ttynum, masterfd>@/ where @fd@ is file descriptor number, @ttynum@ is terminal number and @masterfd@ is file descriptor refering to the master side of the pty.
consoleGetFD ttynum = lxc $ \c -> do
  fn <- mkFn mkConsoleGetFDFn p'lxc_container'console_getfd c
  alloca $ \cttynum ->
    alloca $ \cmasterfd -> do
      poke cttynum (fromIntegral $ fromMaybe (-1) ttynum)
      fd       <- fromIntegral <$> fn cttynum cmasterfd
      ttynum'  <- fromIntegral <$> peek cttynum
      masterfd <- fromIntegral <$> peek cmasterfd
      if (fd < 0)
        then return Nothing
        else return $ Just (fd, ttynum', masterfd)

-- | Allocate and run a console tty.
console :: Maybe Int  -- ^ Terminal number to attempt to allocate, @Nothing@ to allocate the first available tty or @Just 0@ to allocate the console.
        -> Fd         -- ^ File descriptor to read input from.
        -> Fd         -- ^ File descriptor to write output to.
        -> Fd         -- ^ File descriptor to write error output to.
        -> Int        -- ^ The escape character (@1 == \'a\'@, @2 == \'b\'@, ...).
        -> LXC Bool   -- ^ @True@ on success, else @False@.
console ttynum stdin stdout stderr escape = lxc $ \c -> do
  fn <- mkFn mkConsoleFn p'lxc_container'console c
  toBool <$> fn (fromIntegral $ fromMaybe (-1) ttynum)
                (fromIntegral stdin)
                (fromIntegral stdout)
                (fromIntegral stderr)
                (fromIntegral escape)

-- | Create a sub-process attached to a container and run a function inside it.
attach :: AttachExecFn          -- ^ Function to run.
       -> AttachCommand         -- ^ Data to pass to @exec@ function.
       -> AttachOptions         -- ^ Attach options.
       -> LXC (Maybe ProcessID) -- ^ Process ID of process running inside container @c@ that is running @exec@ function, or @Nothing@ on error.
attach exec cmd opts = lxc $ \c -> do
  fn <- mkFn mkAttachFn p'lxc_container'attach c
  withC'lxc_attach_command_t cmd $ \ccmd ->
    withC'lxc_attach_options_t opts $ \copts ->
      alloca $ \cpid -> do
        ret <- fn (getAttachExecFn exec) (castPtr ccmd) copts cpid
        if (ret < 0)
          then return Nothing
          else Just . fromIntegral <$> peek cpid

-- | Run a program inside a container and wait for it to exit.
attachRunWait :: AttachOptions        -- ^ Attach options.
              -> String               -- ^ Full path inside container of program to run.
              -> [String]             -- ^ Array of arguments to pass to program.
              -> LXC (Maybe ExitCode) -- ^ @waitpid(2)@ status of exited process that ran program, or @Nothing@ on error.
attachRunWait opts prg argv = lxc $ \c -> do
  fn <- mkFn mkAttachRunWaitFn p'lxc_container'attach_run_wait c
  withCString prg $ \cprg ->
    withMany withCString argv $ \cargv ->
      withArray0 nullPtr cargv $ \cargv' ->
        withC'lxc_attach_options_t opts $ \copts -> do
          ret <- fromIntegral <$> fn copts cprg cargv'
          case ret of
            _ | ret < 0 -> return Nothing
            0           -> return $ Just ExitSuccess
            _           -> return $ Just (ExitFailure ret)

-- | Create a container snapshot.
--
-- Assuming default paths, snapshots will be created as
-- @\/var\/lib\/lxc\/\<c\>\/snaps\/snap\<n\>@
-- where @\<c\>@ represents the container name and @\<n\>@
-- represents the zero-based snapshot number.
snapshot :: Maybe FilePath  -- ^ Full path to file containing a description of the snapshot.
         -> LXC (Maybe Int) -- ^ @Nothing@ on error, or zero-based snapshot number.
snapshot path = lxc $ \c -> do
  fn <- mkFn mkSnapshotFn p'lxc_container'snapshot c
  maybeWith withCString path $ \cpath -> do
    n <- fn cpath
    if (n == -1)
      then return Nothing
      else return (Just $ fromIntegral n)

peekC'lxc_snapshot :: Ptr C'lxc_snapshot -> IO Snapshot
peekC'lxc_snapshot ptr = Snapshot
  <$> peekField peekCString             p'lxc_snapshot'name
  <*> peekField (maybePeek peekCString) p'lxc_snapshot'comment_pathname
  <*> peekField peekCString             p'lxc_snapshot'timestamp
  <*> peekField peekCString             p'lxc_snapshot'lxcpath
  where
    peekField g f = peek (f ptr) >>= g

-- | Obtain a list of container snapshots.
snapshotList :: LXC [Snapshot]
snapshotList = lxc $ \c -> do
  alloca $ \css -> do
    fn <- mkFn mkSnapshotListFn p'lxc_container'snapshot_list c
    n  <- fromIntegral <$> fn css
    if (n <= 0)
      then return []
      else do
        css1  <- peek css
        let css2 = take n $ iterate (flip advancePtr 1) css1
        css3   <- mapM peekC'lxc_snapshot css2
        forM_ css2 $ join . mkFn mkFreeFn p'lxc_snapshot'free
        free css1
        return css3

-- | Create a new container based on a snapshot.
--
-- The restored container will be a copy (not snapshot) of the snapshot,
-- and restored in the lxcpath of the original container.
--
-- * /WARNING:/ If new name is the same as the current container
-- name, the container will be destroyed. However, this will
-- fail if the snapshot is overlay-based, since the snapshots
-- will pin the original container.
-- * /NOTE:/ As an example, if the container exists as @\/var\/lib\/lxc\/c1@, snapname might be @"snap0"@
-- (representing @\/var\/lib\/lxc\/c1\/snaps\/snap0@). If new name is @c2@,
-- then @snap0@ will be copied to @\/var\/lib\/lxc\/c2@.
snapshotRestore :: String     -- ^ Name of snapshot.
                -> String     -- ^ Name to be used for the restored snapshot.
                -> LXC Bool   -- ^ @True@ on success, else @False@.
snapshotRestore = setItemFn' p'lxc_container'snapshot_restore

-- | Destroy the specified snapshot.
snapshotDestroy :: String     -- ^ Name of snapshot.
                -> LXC Bool   -- ^ @True@ on success, else @False@.
snapshotDestroy n = stringBoolFn p'lxc_container'snapshot_destroy (Just n)

-- | Determine if the caller may control the container.
--
-- @False@ if there is a control socket for the container monitor
-- and the caller may not access it, otherwise returns @True@.
mayControl :: LXC Bool
mayControl = boolFn p'lxc_container'may_control

-- | Add specified device to the container.
addDeviceNode :: FilePath       -- ^ Full path of the device.
              -> Maybe FilePath -- ^ Alternate path in the container (or @Nothing@ to use source path).
              -> LXC Bool       -- ^ @True@ on success, else @False@.
addDeviceNode = setItemFn p'lxc_container'add_device_node

-- | Remove specified device from the container.
removeDeviceNode :: FilePath       -- ^ Full path of the device.
                 -> Maybe FilePath -- ^ Alternate path in the container (or @Nothing@ to use source path).
                 -> LXC Bool       -- ^ @True@ on success, else @False@.
removeDeviceNode = setItemFn p'lxc_container'remove_device_node

-- | Create a container.
create :: String            -- ^ Template to execute to instantiate the root filesystem and adjust the configuration.
       -> Maybe String      -- ^ Backing store type to use (if @Nothing@, @dir@ type will be used by default).
       -> Maybe BDevSpecs   -- ^ Additional parameters for the backing store (for example LVM volume group to use).
       -> [CreateOption]    -- ^ 'CreateOption' flags. /Note: LXC 1.0 supports only @CreateQuiet@ option./
       -> [String]          -- ^ Arguments to pass to the template.
       -> LXC Bool          -- ^ @True@ on success. @False@ otherwise.
create t bdevtype bdevspecs flags argv = lxc $ \c -> toBool <$> do
  withMany withCString argv $ \cargv ->
    withArray0 nullPtr cargv $ \cargv' ->
       withCString t $ \ct ->
         maybeWith withCString bdevtype $ \cbdevtype ->
           maybeWith withC'bdev_specs bdevspecs $ \_cbdevspecs -> do
             fn <- peek $ p'lxc_container'create $ c
             mkCreateFn fn
               (c)
               ct
               cbdevtype
               nullPtr
               (mkFlags createFlag flags)
               cargv'

-- | Add a reference to the specified container.
getRef :: Ptr C'lxc_container -> IO Bool
getRef c = toBool <$> c'lxc_container_get c

-- | Drop a reference to the specified container.
--
-- @Just False@ on success, @Just True@ if reference was successfully dropped
-- and container has been freed, and @Nothing@ on error.
dropRef :: Ptr C'lxc_container -> IO (Maybe Bool)
dropRef c = do
  n <- c'lxc_container_put c
  return $ case n of
             0 -> Just False
             1 -> Just True
             _ -> Nothing

-- | Obtain a list of all container states.
getWaitStates :: IO [ContainerState]
getWaitStates = do
  sz <- fromIntegral <$> c'lxc_get_wait_states nullPtr
  allocaArray sz $ \cstates -> do
    _ <- c'lxc_get_wait_states cstates
    cstates' <- peekArray sz cstates
    map parseState <$> mapM peekCString cstates'
    -- we do not need to free the strings themselves

-- | Get the value for a global config key.
getGlobalConfigItem :: String             -- ^ The name of the config key.
                    -> IO (Maybe String)  -- ^ String representing the current value for the key. @Nothing@ on error.
getGlobalConfigItem k = do
  withCString k $ \ck -> do
    cv <- c'lxc_get_global_config_item ck
    maybePeek peekCString cv

-- | Determine version of LXC.
getVersion :: IO String
getVersion = c'lxc_get_version >>= peekCString

listContainersFn :: (CString -> Ptr (Ptr CString) -> Ptr (Ptr (Ptr C'lxc_container)) -> IO CInt)
                 -> Maybe String
                 -> IO [Container]
listContainersFn f lxcpath = do
  maybeWith withCString lxcpath $ \clxcpath ->
    alloca $ \cnames ->
      alloca $ \ccontainers -> do
        n <- fromIntegral <$> f clxcpath cnames ccontainers
        if (n <= 0)
          then return []
          else do
            cnames'  <- peek cnames
            cnames'' <- peekArray n cnames'
            names    <- mapM peekCString cnames''
            mapM_ free cnames''
            free cnames'

            ccontainers'  <- peek ccontainers
            ccontainers'' <- peekArray n ccontainers'
            containers    <- mapM peekC'lxc_container ccontainers''
            mapM_ free ccontainers''
            free ccontainers'

            return $ zipWith ($) containers names


-- | Get a list of defined containers in a lxcpath.
listDefinedContainers :: Maybe String               -- ^ lxcpath under which to look.
                      -> IO [Container]   -- ^ List of <name, container> pairs.
listDefinedContainers = listContainersFn c'list_defined_containers

-- | Get a list of active containers for a given lxcpath.
listActiveContainers :: Maybe String               -- ^ Full @LXCPATH@ path to consider.
                     -> IO [Container]   -- ^ List of <name, container> pairs.
listActiveContainers = listContainersFn c'list_active_containers

-- | Get a complete list of all containers for a given lxcpath.
listAllContainers :: Maybe String               -- ^ Full @LXCPATH@ path to consider.
                  -> IO [Container]   -- ^ List of <name, container> pairs.
listAllContainers = listContainersFn c'list_all_containers

-- | Close log file.
logClose :: IO ()
logClose = c'lxc_log_close