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
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
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)
data LXCError = LXCError
{ lxcErrorString :: String
, lxcErrorNum :: Int
}
deriving (Show)
prettyLXCError :: LXCError -> String
prettyLXCError (LXCError msg num) = "Error " ++ show num ++ ": " ++ msg
data CloneOption
= CloneKeepName
| CloneKeepMacAddr
| CloneSnapshot
| CloneKeepBDevType
| CloneMaybeSnapshot
| CloneMaxFlags
deriving (Eq, Ord)
data CreateOption
= CreateQuiet
| CreateMaxFlags
deriving (Eq, Ord)
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
createFlag :: Num a => CreateOption -> a
createFlag CreateQuiet = c'LXC_CREATE_QUIET
createFlag CreateMaxFlags = c'LXC_CREATE_MAXFLAGS
data Snapshot = Snapshot
{ snapshotName :: String
, snapshotCommentPathname :: Maybe FilePath
, snapshotTimestamp :: String
, snapshotLXCPath :: FilePath
}
deriving (Show)
data Container = Container
{ containerName :: String
, containerConfigPath :: Maybe String
}
deriving (Show)
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
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
data ContainerState
= ContainerStopped
| ContainerStarting
| ContainerRunning
| ContainerStopping
| ContainerAborting
| ContainerFreezing
| ContainerFrozen
| ContainerThawed
| ContainerOtherState String
deriving (Eq, Show)
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
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
data BDevSpecs = BDevSpecs
{ bdevFSType :: String
, bdevFSSize :: Word64
, bdevZFSRootPath :: FilePath
, bdevLVMVolumeGroupName :: String
, bdevLVMLogicalVolumeName :: String
, bdevLVMThinPool :: Maybe String
, bdevDirectory :: FilePath
}
deriving (Show)
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
sz <- fn cs nullPtr 0
if (sz < 0)
then return Nothing
else allocaBytes (fromIntegral sz) $ \cretv -> do
_ <- 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)
getDaemonize :: LXC Bool
getDaemonize = lxc $ \c -> toBool <$> peek (p'lxc_container'daemonize c)
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
isDefined :: LXC Bool
isDefined = boolFn p'lxc_container'is_defined
isRunning :: LXC Bool
isRunning = boolFn p'lxc_container'is_running
state :: LXC ContainerState
state = lxc $ \c -> do
fn <- peek (p'lxc_container'state c)
cs <- mkStringFn fn c
parseState <$> peekCString cs
freeze :: LXC Bool
freeze = boolFn p'lxc_container'freeze
unfreeze :: LXC Bool
unfreeze = boolFn p'lxc_container'unfreeze
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)
loadConfig :: Maybe FilePath
-> LXC Bool
loadConfig = stringBoolFn p'lxc_container'load_config
start :: Bool
-> [String]
-> LXC Bool
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 :: LXC Bool
stop = boolFn p'lxc_container'stop
wantDaemonize :: Bool
-> LXC Bool
wantDaemonize = boolBoolFn p'lxc_container'want_daemonize
wantCloseAllFDs :: Bool
-> LXC Bool
wantCloseAllFDs = boolBoolFn p'lxc_container'want_close_all_fds
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 :: ContainerState
-> Int
-> LXC Bool
wait s t = lxc $ \c -> do
fn <- mkFn mkWaitFn p'lxc_container'wait c
withCString (printState s) $ \cs ->
toBool <$> fn cs (fromIntegral t)
setConfigItem :: String
-> String
-> LXC Bool
setConfigItem = setItemFn' p'lxc_container'set_config_item
destroy :: LXC Bool
destroy = boolFn p'lxc_container'destroy
saveConfig :: FilePath
-> LXC Bool
saveConfig s = stringBoolFn p'lxc_container'save_config (Just s)
rename :: String
-> LXC Bool
rename s = stringBoolFn p'lxc_container'rename (Just s)
reboot :: LXC Bool
reboot = boolFn p'lxc_container'reboot
shutdown :: Int
-> LXC Bool
shutdown n = lxc $ \c -> do
fn <- mkFn mkShutdownFn p'lxc_container'shutdown c
toBool <$> fn (fromIntegral n)
clearConfig :: LXC ()
clearConfig = lxc $ join . mkFn mkClearConfigFn p'lxc_container'clear_config
getConfigItem :: String
-> LXC (Maybe String)
getConfigItem = getItemFn p'lxc_container'get_config_item
getRunningConfigItem :: String
-> LXC (Maybe String)
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
getKeys :: String
-> LXC [String]
getKeys kp = concatMap lines . maybeToList <$> getItemFn p'lxc_container'get_keys kp
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
getIPs :: String
-> String
-> Word32
-> LXC [String]
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
getCGroupItem :: String
-> LXC (Maybe String)
getCGroupItem = getItemFn p'lxc_container'get_cgroup_item
setCGroupItem :: String
-> String
-> LXC Bool
setCGroupItem = setItemFn' p'lxc_container'set_cgroup_item
clearConfigItem :: String
-> LXC Bool
clearConfigItem s = stringBoolFn p'lxc_container'clear_config_item (Just s)
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
setConfigPath :: FilePath
-> LXC Bool
setConfigPath s = stringBoolFn p'lxc_container'set_config_path (Just s)
clone :: Maybe String
-> Maybe FilePath
-> [CloneOption]
-> Maybe String
-> Maybe String
-> Maybe Word64
-> [String]
-> LXC (Maybe Container)
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)
consoleGetFD :: Maybe Int
-> LXC (Maybe (Int, Int, Int))
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)
console :: Maybe Int
-> Fd
-> Fd
-> Fd
-> Int
-> LXC Bool
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)
attach :: AttachExecFn
-> AttachCommand
-> AttachOptions
-> LXC (Maybe ProcessID)
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
attachRunWait :: AttachOptions
-> String
-> [String]
-> LXC (Maybe ExitCode)
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)
snapshot :: Maybe FilePath
-> LXC (Maybe Int)
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
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
snapshotRestore :: String
-> String
-> LXC Bool
snapshotRestore = setItemFn' p'lxc_container'snapshot_restore
snapshotDestroy :: String
-> LXC Bool
snapshotDestroy n = stringBoolFn p'lxc_container'snapshot_destroy (Just n)
mayControl :: LXC Bool
mayControl = boolFn p'lxc_container'may_control
addDeviceNode :: FilePath
-> Maybe FilePath
-> LXC Bool
addDeviceNode = setItemFn p'lxc_container'add_device_node
removeDeviceNode :: FilePath
-> Maybe FilePath
-> LXC Bool
removeDeviceNode = setItemFn p'lxc_container'remove_device_node
create :: String
-> Maybe String
-> Maybe BDevSpecs
-> [CreateOption]
-> [String]
-> LXC Bool
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'
getRef :: Ptr C'lxc_container -> IO Bool
getRef c = toBool <$> c'lxc_container_get c
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
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'
getGlobalConfigItem :: String
-> IO (Maybe String)
getGlobalConfigItem k = do
withCString k $ \ck -> do
cv <- c'lxc_get_global_config_item ck
maybePeek peekCString cv
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
listDefinedContainers :: Maybe String
-> IO [Container]
listDefinedContainers = listContainersFn c'list_defined_containers
listActiveContainers :: Maybe String
-> IO [Container]
listActiveContainers = listContainersFn c'list_active_containers
listAllContainers :: Maybe String
-> IO [Container]
listAllContainers = listContainersFn c'list_all_containers
logClose :: IO ()
logClose = c'lxc_log_close