lxc (empty) → 0.1
raw patch · 9 files changed
+1005/−0 lines, 9 filesdep +basedep +bindings-lxcsetup-changed
Dependencies added: base, bindings-lxc
Files
- LICENSE +28/−0
- README.md +4/−0
- Setup.hs +2/−0
- lxc.cabal +33/−0
- src/System/LXC.hs +7/−0
- src/System/LXC/AttachOptions.hs +18/−0
- src/System/LXC/Container.hs +79/−0
- src/System/LXC/Internal/Container.hs +826/−0
- src/System/LXC/Internal/Utils.hs +8/−0
+ LICENSE view
@@ -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.+
+ README.md view
@@ -0,0 +1,4 @@+lxc+===++High level Haskell bindings to LXC (Linux containers).
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ lxc.cabal view
@@ -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 <http://hackage.haskell.org/package/bindings-lxc bindings-lxc package>.+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
+ src/System/LXC.hs view
@@ -0,0 +1,7 @@+module System.LXC (+ module System.LXC.Container,+ module System.LXC.AttachOptions+) where++import System.LXC.Container+import System.LXC.AttachOptions
+ src/System/LXC/AttachOptions.hs view
@@ -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
+ src/System/LXC/Container.hs view
@@ -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
+ src/System/LXC/Internal/Container.hs view
@@ -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 /@<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 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\/\<c\>\/snaps\/snap\<n\>@+-- where @\<c\>@ represents the container name and @\<n\>@+-- 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 <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 [(String, 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 [(String, Container)] -- ^ List of <name, container> pairs.+listAllContainers = listContainersFn c'list_all_containers++-- | Close log file.+logClose :: IO ()+logClose = c'lxc_log_close+
+ src/System/LXC/Internal/Utils.hs view
@@ -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