diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +Copyright (c) 2014, Nickolay Kudasov +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +* Neither the name of lxc nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,4 @@ +lxc +=== + +High level Haskell bindings to LXC (Linux containers). diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/lxc.cabal b/lxc.cabal new file mode 100644 --- /dev/null +++ b/lxc.cabal @@ -0,0 +1,33 @@ +name: lxc +version: 0.1 +synopsis: High level Haskell bindings to LXC (Linux containers). +description: The library provides Haskell LXC API, wrapping . +homepage: https://github.com/fizruk/lxc +bug-reports: https://github.com/fizruk/lxc/issues +license: BSD3 +license-file: LICENSE +author: Nickolay Kudasov +maintainer: nickolay.kudasov@gmail.com +-- copyright: +category: System +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + default-language: Haskell2010 + exposed-modules: + System.LXC + System.LXC.Container + System.LXC.AttachOptions + -- internal modules + System.LXC.Internal.Container + System.LXC.Internal.Utils + build-depends: base >=4.7 && <4.8 + , bindings-lxc >=0.1 && <0.2 + +source-repository head + type: git + location: https://github.com/fizruk/lxc.git + branch: master diff --git a/src/System/LXC.hs b/src/System/LXC.hs new file mode 100644 --- /dev/null +++ b/src/System/LXC.hs @@ -0,0 +1,7 @@ +module System.LXC ( + module System.LXC.Container, + module System.LXC.AttachOptions +) where + +import System.LXC.Container +import System.LXC.AttachOptions diff --git a/src/System/LXC/AttachOptions.hs b/src/System/LXC/AttachOptions.hs new file mode 100644 --- /dev/null +++ b/src/System/LXC/AttachOptions.hs @@ -0,0 +1,18 @@ +module System.LXC.AttachOptions ( + -- * Attach options + AttachOptions(..), + defaultAttachOptions, + -- * Attach command + AttachCommand(..), + -- * Attach @exec@ functions + AttachExecFn(..), + attachRunCommand, + attachRunShell, + -- * Flags and environment policies + AttachEnvPolicy(..), + AttachFlag(..), + fromAttachEnvPolicy, + fromAttachFlag, +) where + +import System.LXC.Internal.AttachOptions diff --git a/src/System/LXC/Container.hs b/src/System/LXC/Container.hs new file mode 100644 --- /dev/null +++ b/src/System/LXC/Container.hs @@ -0,0 +1,79 @@ +module System.LXC.Container ( + -- * Data types + Container(..), + Snapshot(..), + BDevSpecs(..), + ContainerState(..), + parseState, printState, + mkContainer, + -- * Flags + CloneOption(..), + CreateOption(..), + cloneFlag, createFlag, + -- * Container methods + -- ** Query container state. + isDefined, + isRunning, + state, + initPID, + -- ** Container config + configFileName, + getConfigPath, + setConfigPath, + loadConfig, + saveConfig, + getKeys, + setConfigItem, + getConfigItem, + getRunningConfigItem, + clearConfig, + clearConfigItem, + -- ** Freeze/unfreeze + freeze, + unfreeze, + -- ** Control container state + start, + stop, + reboot, + shutdown, + wait, + -- ** Manage containers + create, + clone, + rename, + destroy, + -- ** Console + consoleGetFD, + console, + -- ** Attach to container + attach, + attachRunWait, + -- ** Snapshots + snapshot, + snapshotList, + snapshotRestore, + -- ** Misc + wantDaemonize, + wantCloseAllFDs, + getInterfaces, + getIPs, + getCGroupItem, + setCGroupItem, + mayControl, + addDeviceNode, + removeDeviceNode, + getRef, + dropRef, + -- * Global LXC functions + -- ** List containers + listDefinedContainers, + listActiveContainers, + listAllContainers, + -- ** Misc + getWaitStates, + getGlobalConfigItem, + getVersion, + logClose, +) where + +import System.LXC.Internal.Container diff --git a/src/System/LXC/Internal/Container.hs b/src/System/LXC/Internal/Container.hs new file mode 100644 --- /dev/null +++ b/src/System/LXC/Internal/Container.hs @@ -0,0 +1,826 @@ +module System.LXC.Internal.Container where + +import Bindings.LXC.AttachOptions +import Bindings.LXC.Container +import Bindings.LXC.Sys.Types + +import Control.Applicative +import Control.Monad + +import Data.Maybe +import Data.Word + +import Foreign.C.Types +import Foreign.C.String +import Foreign.Marshal.Alloc +import Foreign.Marshal.Array +import Foreign.Marshal.Utils +import Foreign.Ptr +import Foreign.Storable + +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 + +-- | 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. +newtype Container = Container { + getContainer :: Ptr C'lxc_container -- ^ A pointer to @lxc_container@ structure. +} + +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 + +-- | 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. + } + +-- | 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 + +-- | Allocate a new container. +mkContainer :: String -- ^ Name to use for the container. + -> Maybe FilePath -- ^ Full path to configuration file to use. + -> IO Container -- ^ Newly allocated container. +mkContainer name configPath = do + c <- withCString name $ \cname -> + case configPath of + Nothing -> c'lxc_container_new cname nullPtr + Just s -> withCString s $ c'lxc_container_new cname + when (c == nullPtr) $ error "failed to allocate new container" + return $ Container c + +type Field s a = Ptr s -> Ptr a + +mkFn :: (t -> Ptr s) -> (FunPtr (Ptr s -> a) -> (Ptr s -> a)) -> Field s (FunPtr (Ptr s -> a)) -> t -> IO a +mkFn unwrap mk g t = do + let s = unwrap t + fn <- peek (g s) + return $ mk fn s + +boolFn :: Field C'lxc_container (FunPtr ContainerBoolFn) -> Container -> IO Bool +boolFn g c = do + fn <- mkFn getContainer mkBoolFn g c + toBool <$> fn + +stringBoolFn :: Field C'lxc_container (FunPtr ContainerStringBoolFn) -> Container -> Maybe String -> IO Bool +stringBoolFn g c s = do + fn <- mkFn getContainer mkStringBoolFn g c + maybeWith withCString s $ \cs -> + toBool <$> fn cs + +boolBoolFn :: Field C'lxc_container (FunPtr ContainerBoolBoolFn) -> Container -> Bool -> IO Bool +boolBoolFn g c b = do + fn <- mkFn getContainer mkBoolBoolFn g c + toBool <$> fn (if b then 1 else 0) + +getItemFn :: Field C'lxc_container (FunPtr ContainerGetItemFn) -> Container -> String -> IO (Maybe String) +getItemFn g c s = do + fn <- mkFn getContainer 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) -> Container -> String -> Maybe String -> IO Bool +setItemFn g c k v = do + fn <- mkFn getContainer mkSetItemFn g c + withCString k $ \ck -> + maybeWith withCString v $ \cv -> + toBool <$> fn ck cv + +setItemFn' :: Field C'lxc_container (FunPtr ContainerSetItemFn) -> Container -> String -> String -> IO Bool +setItemFn' g c k v = setItemFn g c k (Just v) + +-- | Determine if @\/var\/lib\/lxc\/\$name\/config@ exists. +-- +-- @True@ if container is defined, else @False@. +isDefined :: Container -> IO Bool +isDefined = boolFn p'lxc_container'is_defined + +-- | Determine if container is running. +-- +-- @True@ on success, else @False@. +isRunning :: Container -> IO Bool +isRunning = boolFn p'lxc_container'is_running + +-- | Determine state of container. +state :: Container -> IO ContainerState +state (Container 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 :: Container -> IO Bool +freeze = boolFn p'lxc_container'freeze + +-- | Thaw a frozen container. +-- +-- @True@ on success, else @False@. +unfreeze :: Container -> IO Bool +unfreeze = boolFn p'lxc_container'unfreeze + +-- | Determine process ID of the containers init process. +initPID :: Container -> IO (Maybe ProcessID) +initPID c = do + fn <- mkFn getContainer 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 :: Container -- ^ Container. + -> Maybe FilePath -- ^ Full path to alternate configuration file, or @Nothing@ to use the default configuration file. + -> IO Bool -- ^ @True@ on success, else @False@. +loadConfig = stringBoolFn p'lxc_container'load_config + +-- | Start the container. +start :: Container -- ^ Container. + -> Int -- ^ Use @lxcinit@ rather than @/sbin/init@. + -> [String] -- ^ Array of arguments to pass to init. + -> IO Bool -- ^ @True@ on success, else @False@. +start c n argv = do + fn <- mkFn getContainer mkStartFn p'lxc_container'start c + withMany withCString argv $ \cargv -> + withArray0 nullPtr cargv $ \cargv' -> + toBool <$> fn (fromIntegral n) cargv' + +-- | Stop the container. +-- +-- @True@ on success, else @False@. +stop :: Container -> IO Bool +stop = boolFn p'lxc_container'stop + +-- | Determine if the container wants to run disconnected from the terminal. +wantDaemonize :: Container -- ^ Container. + -> Bool -- ^ Value for the daemonize bit. + -> IO 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 :: Container -- ^ Container. + -> Bool -- ^ Value for the @close_all_fds@ bit. + -> IO 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 :: Container -> IO (Maybe FilePath) +configFileName (Container 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 :: Container -- ^ Container. + -> ContainerState -- ^ State to wait for. + -> Int -- ^ Timeout in seconds. + -> IO Bool -- ^ @True@ if state reached within timeout, else @False@. +wait c s t = do + fn <- mkFn getContainer mkWaitFn p'lxc_container'wait c + withCString (printState s) $ \cs -> + toBool <$> fn cs (fromIntegral t) + +-- | Set a key/value configuration option. +setConfigItem :: Container -- ^ Container. + -> String -- ^ Name of option to set. + -> String -- ^ Value to set. + -> IO 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 :: Container -> IO Bool +destroy = boolFn p'lxc_container'destroy + +-- | Save configuaration to a file. +saveConfig :: Container -- ^ Container. + -> FilePath -- ^ Full path to file to save configuration in. + -> IO Bool -- ^ @True@ on success, else @False@. +saveConfig c s = stringBoolFn p'lxc_container'save_config c (Just s) + +-- | Rename a container. +rename :: Container -- ^ Container. + -> String -- ^ New name to be used for the container. + -> IO Bool -- ^ @True@ on success, else @False@. +rename c s = stringBoolFn p'lxc_container'rename c (Just s) + +-- | Request the container reboot by sending it @SIGINT@. +-- +-- @True@ if reboot request successful, else @False@. +reboot :: Container -> IO Bool +reboot = boolFn p'lxc_container'reboot + +-- | Request the container shutdown by sending it @SIGPWR@. +shutdown :: Container -- ^ Container. + -> Int -- ^ Seconds to wait before returning false. (@-1@ to wait forever, @0@ to avoid waiting). + -> IO Bool -- ^ @True@ if the container was shutdown successfully, else @False@. +shutdown c n = do + fn <- mkFn getContainer mkShutdownFn p'lxc_container'shutdown c + toBool <$> fn (fromIntegral n) + +-- | Completely clear the containers in-memory configuration. +clearConfig :: Container -> IO () +clearConfig = join . mkFn getContainer mkClearConfigFn p'lxc_container'clear_config + +-- | Retrieve the value of a config item. +getConfigItem :: Container -- ^ Container. + -> String -- ^ Name of option to get. + -> IO (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 :: Container -- ^ Container. + -> String -- ^ Name of option to get. + -> IO (Maybe String) -- ^ The item or @Nothing@ on error. +getRunningConfigItem c k = do + fn <- mkFn getContainer 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 :: Container -- ^ Container. + -> String -- ^ Key prefix. + -> IO [String] -- ^ List of keys. +getKeys c kp = concatMap lines . maybeToList <$> getItemFn p'lxc_container'get_keys c kp + +-- | Obtain a list of network interfaces. +getInterfaces :: Container -> IO [String] +getInterfaces c = do + cifs <- join $ mkFn getContainer 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 :: Container -- ^ Container. + -> String -- ^ Network interface name to consider. + -> String -- ^ Network family (for example @"inet"@, @"inet6"@). + -> Word32 -- ^ IPv6 scope id (ignored if family is not "inet6"). + -> IO [String] -- ^ A list of network interfaces. +getIPs c iface fam sid = do + fn <- mkFn getContainer 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 :: Container -- ^ Container. + -> String -- ^ @cgroup@ subsystem to retrieve. + -> IO (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 :: Container -- ^ Container. + -> String -- ^ @cgroup@ subsystem to consider. + -> String -- ^ Value to set. + -> IO Bool -- ^ @True@ on success, else @False@. +setCGroupItem = setItemFn' p'lxc_container'set_cgroup_item + +-- | Clear a configuration item. +-- +-- Analog of 'setConfigItem'. +clearConfigItem :: Container -- ^ Container. + -> String -- ^ Name of option to clear. + -> IO Bool -- ^ @True@ on success, else @False@. +clearConfigItem c s = stringBoolFn p'lxc_container'clear_config_item c (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 :: Container -> IO FilePath +getConfigPath c = do + cs <- join $ mkFn getContainer 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 :: Container -- ^ Container. + -> FilePath -- ^ Full path to configuration file. + -> IO Bool -- ^ @True@ on success, else @False@. +setConfigPath c s = stringBoolFn p'lxc_container'set_config_path c (Just s) + +-- | Copy a stopped container. +clone :: Container -- ^ Original container. + -> 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. + -> IO Container +clone c newname lxcpath flags bdevtype bdevdata newsize hookargs = 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 <- peek $ p'lxc_container'clone $ getContainer c + mkCloneFn fn + (getContainer c) + cnewname + clxcpath + (mkFlags cloneFlag flags) + cbdevtype + cbdevdata + (fromMaybe 0 newsize) + chookargs' + when (c' == nullPtr) $ error "failed to clone a container" + return $ Container c' + +-- | 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 :: Container -- ^ Container. + -> Maybe Int -- ^ Terminal number to attempt to allocate, or @Nothing@ to allocate the first available tty. + -> IO (Maybe (Int, Int, Int)) -- ^ Tuple /@@/ where @fd@ is file descriptor number, @ttynum@ is terminal number and @masterfd@ is file descriptor refering to the master side of the pty. +consoleGetFD c ttynum = do + fn <- mkFn getContainer 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 :: Container -- ^ Container. + -> 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\'@, ...). + -> IO Bool -- ^ @True@ on success, else @False@. +console c ttynum stdin stdout stderr escape = do + fn <- mkFn getContainer 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 :: Container -- ^ Container. + -> AttachExecFn -- ^ Function to run. + -> AttachCommand -- ^ Data to pass to @exec@ function. + -> AttachOptions -- ^ Attach options. + -> IO (Maybe ProcessID) -- ^ Process ID of process running inside container @c@ that is running @exec@ function, or @Nothing@ on error. +attach c exec cmd opts = do + fn <- mkFn getContainer 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 :: Container -- ^ Container. + -> AttachOptions -- ^ Attach options. + -> String -- ^ Full path inside container of program to run. + -> [String] -- ^ Array of arguments to pass to program. + -> IO (Maybe ExitCode) -- ^ @waitpid(2)@ status of exited process that ran program, or @Nothing@ on error. +attachRunWait c opts prg argv = do + fn <- mkFn getContainer 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\/\\/snaps\/snap\@ +-- where @\@ represents the container name and @\@ +-- represents the zero-based snapshot number. +snapshot :: Container + -> FilePath + -> IO (Maybe Int) +snapshot c path = do + fn <- mkFn getContainer mkSnapshotFn p'lxc_container'snapshot c + 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 :: Container + -> IO [Snapshot] +snapshotList c = do + alloca $ \css -> do + fn <- mkFn getContainer mkSnapshotListFn p'lxc_container'snapshot_list c + n <- fromIntegral <$> fn css + if (n < 0) + then return [] + else do + css' <- peek css + let css'' = take n $ iterate (flip advancePtr 1) css' + css <- mapM peekC'lxc_snapshot css'' + forM_ css'' $ join . mkFn id mkFreeFn p'lxc_snapshot'free + free css' + return css + +-- | 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 :: Container -- ^ Container. + -> String -- ^ Name of snapshot. + -> String -- ^ Name to be used for the restored snapshot. + -> IO Bool -- ^ @True@ on success, else @False@. +snapshotRestore = setItemFn' p'lxc_container'snapshot_restore + +-- | Destroy the specified snapshot. +snapshotDestroy :: Container -- ^ Container. + -> String -- ^ Name of snapshot. + -> IO Bool -- ^ @True@ on success, else @False@. +snapshotDestroy c n = stringBoolFn p'lxc_container'snapshot_destroy c (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 :: Container -> IO Bool +mayControl = boolFn p'lxc_container'may_control + +-- | Add specified device to the container. +addDeviceNode :: Container -- ^ Container. + -> FilePath -- ^ Full path of the device. + -> Maybe FilePath -- ^ Alternate path in the container (or @Nothing@ to use source path). + -> IO Bool -- ^ @True@ on success, else @False@. +addDeviceNode = setItemFn p'lxc_container'add_device_node + +-- | Remove specified device from the container. +removeDeviceNode :: Container -- ^ Container. + -> FilePath -- ^ Full path of the device. + -> Maybe FilePath -- ^ Alternate path in the container (or @Nothing@ to use source path). + -> IO Bool -- ^ @True@ on success, else @False@. +removeDeviceNode = setItemFn p'lxc_container'remove_device_node + +-- | Create a container. +create :: Container -- ^ Container (with lxcpath, name and a starting configuration set). + -> 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. + -> IO Bool -- ^ @True@ on success. @False@ otherwise. +create c t bdevtype bdevspecs flags argv = 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 $ getContainer c + mkCreateFn fn + (getContainer c) + ct + cbdevtype + nullPtr + (mkFlags createFlag flags) + cargv' + +-- | Add a reference to the specified container. +getRef :: Container -> IO Bool +getRef (Container 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 :: Container + -> IO (Maybe Bool) +dropRef (Container 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 [(String, 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 + containers <- map Container <$> peekArray n ccontainers' + free ccontainers' + + return $ zip names containers + + +-- | Get a list of defined containers in a lxcpath. +listDefinedContainers :: Maybe String -- ^ lxcpath under which to look. + -> IO [(String, Container)] -- ^ List of 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 [(String, Container)] -- ^ List of 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 [(String, Container)] -- ^ List of pairs. +listAllContainers = listContainersFn c'list_all_containers + +-- | Close log file. +logClose :: IO () +logClose = c'lxc_log_close + diff --git a/src/System/LXC/Internal/Utils.hs b/src/System/LXC/Internal/Utils.hs new file mode 100644 --- /dev/null +++ b/src/System/LXC/Internal/Utils.hs @@ -0,0 +1,8 @@ +module System.LXC.Internal.Utils where + +import Data.Bits +import Data.List + +-- | Collect flags in a single integer value. +mkFlags :: (Num b, Bits b) => (a -> b) -> [a] -> b +mkFlags f = foldl' (.|.) 0 . map f