{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} ----------------------------------------------------------------------------- -- | -- Module : System.LXC.Internal.Container -- Copyright : (c) Nickolay Kudasov 2014 -- License : BSD-style (see the file LICENSE) -- -- Maintainer : nickolay.kudasov@gmail.com -- -- Internal module to provide a set of functions to create, -- control and manage LXC containers. -- Normally you should import @System.LXC@ module only. -- ----------------------------------------------------------------------------- module System.LXC.Internal.Container where import Bindings.LXC.AttachOptions import Bindings.LXC.Container import Bindings.LXC.Sys.Types import Control.Applicative import Control.Monad import Control.Monad.Reader import Control.Monad.IO.Class import Data.Maybe import Data.Word import Foreign import Foreign.C import System.LXC.Internal.AttachOptions import System.LXC.Internal.Utils import System.Exit import System.Posix.Types (ProcessID, Fd) type ContainerCreateFn = Ptr C'lxc_container -> CString -> CString -> Ptr C'bdev_specs -> CInt -> Ptr CString -> IO CBool foreign import ccall "dynamic" mkCreateFn :: FunPtr ContainerCreateFn -> ContainerCreateFn type ContainerCloneFn = Ptr C'lxc_container -> CString -> CString -> CInt -> CString -> CString -> C'uint64_t -> Ptr CString -> IO (Ptr C'lxc_container) foreign import ccall "dynamic" mkCloneFn :: FunPtr ContainerCloneFn -> ContainerCloneFn type ContainerBoolFn = Ptr C'lxc_container -> IO CBool foreign import ccall "dynamic" mkBoolFn :: FunPtr ContainerBoolFn -> ContainerBoolFn type ContainerStringFn = Ptr C'lxc_container -> IO CString foreign import ccall "dynamic" mkStringFn :: FunPtr ContainerStringFn -> ContainerStringFn type ContainerProcessIDFn = Ptr C'lxc_container -> IO C'pid_t foreign import ccall "dynamic" mkProcessIDFn :: FunPtr ContainerProcessIDFn -> ContainerProcessIDFn type ContainerStringBoolFn = Ptr C'lxc_container -> CString -> IO CBool foreign import ccall "dynamic" mkStringBoolFn :: FunPtr ContainerStringBoolFn -> ContainerStringBoolFn type ContainerBoolBoolFn = Ptr C'lxc_container -> CBool -> IO CBool foreign import ccall "dynamic" mkBoolBoolFn :: FunPtr ContainerBoolBoolFn -> ContainerBoolBoolFn type ContainerStartFn = Ptr C'lxc_container -> CInt -> Ptr CString -> IO CBool foreign import ccall "dynamic" mkStartFn :: FunPtr ContainerStartFn -> ContainerStartFn type ContainerShutdownFn = Ptr C'lxc_container -> CInt -> IO CBool foreign import ccall "dynamic" mkShutdownFn :: FunPtr ContainerShutdownFn -> ContainerShutdownFn type ContainerClearConfigFn = Ptr C'lxc_container -> IO () foreign import ccall "dynamic" mkClearConfigFn :: FunPtr ContainerClearConfigFn -> ContainerClearConfigFn type ContainerGetRunningConfigItemFn = Ptr C'lxc_container -> CString -> IO CString foreign import ccall "dynamic" mkGetRunningConfigItemFn :: FunPtr ContainerGetRunningConfigItemFn -> ContainerGetRunningConfigItemFn type ContainerGetItemFn = Ptr C'lxc_container -> CString -> CString -> CInt -> IO CInt foreign import ccall "dynamic" mkGetItemFn :: FunPtr ContainerGetItemFn -> ContainerGetItemFn type ContainerSetItemFn = Ptr C'lxc_container -> CString -> CString -> IO CBool foreign import ccall "dynamic" mkSetItemFn :: FunPtr ContainerSetItemFn -> ContainerSetItemFn type ContainerGetInterfacesFn = Ptr C'lxc_container -> IO (Ptr CString) foreign import ccall "dynamic" mkGetInterfacesFn :: FunPtr ContainerGetInterfacesFn -> ContainerGetInterfacesFn type ContainerGetIPsFn = Ptr C'lxc_container -> CString -> CString -> CInt -> IO (Ptr CString) foreign import ccall "dynamic" mkGetIPsFn :: FunPtr ContainerGetIPsFn -> ContainerGetIPsFn type ContainerWaitFn = Ptr C'lxc_container -> CString -> CInt -> IO CBool foreign import ccall "dynamic" mkWaitFn :: FunPtr ContainerWaitFn -> ContainerWaitFn type ContainerSnapshotFn = Ptr C'lxc_container -> CString -> IO CInt foreign import ccall "dynamic" mkSnapshotFn :: FunPtr ContainerSnapshotFn -> ContainerSnapshotFn type ContainerSnapshotListFn = Ptr C'lxc_container -> Ptr (Ptr C'lxc_snapshot) -> IO CInt foreign import ccall "dynamic" mkSnapshotListFn :: FunPtr ContainerSnapshotListFn -> ContainerSnapshotListFn type ContainerConsoleGetFDFn = Ptr C'lxc_container -> Ptr CInt -> Ptr CInt -> IO CInt foreign import ccall "dynamic" mkConsoleGetFDFn :: FunPtr ContainerConsoleGetFDFn -> ContainerConsoleGetFDFn type ContainerConsoleFn = Ptr C'lxc_container -> CInt -> CInt -> CInt -> CInt -> CInt -> IO CInt foreign import ccall "dynamic" mkConsoleFn :: FunPtr ContainerConsoleFn -> ContainerConsoleFn type ContainerAttachFn = Ptr C'lxc_container -> C_lxc_attach_exec_t -> Ptr () -> Ptr C'lxc_attach_options_t -> Ptr C'pid_t -> IO CInt foreign import ccall "dynamic" mkAttachFn :: FunPtr ContainerAttachFn -> ContainerAttachFn type ContainerAttachRunWaitFn = Ptr C'lxc_container -> Ptr C'lxc_attach_options_t -> CString -> Ptr CString -> IO CInt foreign import ccall "dynamic" mkAttachRunWaitFn :: FunPtr ContainerAttachRunWaitFn -> ContainerAttachRunWaitFn type SnapshotFreeFn = Ptr C'lxc_snapshot -> IO () foreign import ccall "dynamic" mkFreeFn :: FunPtr SnapshotFreeFn -> SnapshotFreeFn -- | LXC container-related computations. -- @'LXC' ~ 'ReaderT' ('String', 'Ptr' 'C'lxc_container') 'IO'@. -- -- Run @'LXC' a@ computations using 'withContainer'. newtype LXC a = LXC { runLXC :: ReaderT (String, Ptr C'lxc_container) IO a } deriving (Functor, Applicative, Monad, MonadReader (String, Ptr C'lxc_container), MonadIO) lxc :: (Ptr C'lxc_container -> IO a) -> LXC a lxc f = LXC . ReaderT $ \(_, p) -> f p -- | Run @'LXC' a@ computation for a given 'Container'. -- -- * for the whole computation a single @lxc_container@ structure -- will be allocated; it will be automatically freed at the end of -- computation. withContainer :: MonadIO m => Container -> LXC a -> m a withContainer c m = liftIO $ do withC'lxc_container c $ \cc -> do runReaderT (runLXC m) $ (containerName c, cc) -- | LXC error structure. data LXCError = LXCError { lxcErrorString :: String -- ^ Error message. , lxcErrorNum :: Int -- ^ Error number. } deriving (Show) -- | Pretty print LXC error message. prettyLXCError :: LXCError -> String prettyLXCError (LXCError msg num) = "Error " ++ show num ++ ": " ++ msg -- | Options for 'clone' operation. data CloneOption = CloneKeepName -- ^ Do not edit the rootfs to change the hostname. | CloneKeepMacAddr -- ^ Do not change the MAC address on network interfaces. | CloneSnapshot -- ^ Snapshot the original filesystem(s). | CloneKeepBDevType -- ^ Use the same bdev type. | CloneMaybeSnapshot -- ^ Snapshot only if bdev supports it, else copy. | CloneMaxFlags -- ^ Number of @LXC_CLONE_*@ flags. deriving (Eq, Ord) -- | Options for 'create' operation. data CreateOption = CreateQuiet -- ^ Redirect @stdin@ to @\/dev\/zero@ and @stdout@ and @stderr@ to @\/dev\/null@. | CreateMaxFlags -- ^ Number of @LXC_CREATE*@ flags. deriving (Eq, Ord) -- | Turn 'CloneOption' into a bit flag. cloneFlag :: Num a => CloneOption -> a cloneFlag CloneKeepName = c'LXC_CLONE_KEEPNAME cloneFlag CloneKeepMacAddr = c'LXC_CLONE_KEEPMACADDR cloneFlag CloneSnapshot = c'LXC_CLONE_SNAPSHOT cloneFlag CloneKeepBDevType = c'LXC_CLONE_KEEPBDEVTYPE cloneFlag CloneMaybeSnapshot = c'LXC_CLONE_MAYBE_SNAPSHOT cloneFlag CloneMaxFlags = c'LXC_CLONE_MAXFLAGS -- | Turn 'CreateOption' into a bit flag. createFlag :: Num a => CreateOption -> a createFlag CreateQuiet = c'LXC_CREATE_QUIET createFlag CreateMaxFlags = c'LXC_CREATE_MAXFLAGS -- | An LXC container snapshot. data Snapshot = Snapshot { snapshotName :: String -- ^ Name of snapshot. , snapshotCommentPathname :: Maybe FilePath -- ^ Full path to snapshots comment file. , snapshotTimestamp :: String -- ^ Time snapshot was created. , snapshotLXCPath :: FilePath -- ^ Full path to @LXCPATH@ for snapshot. } deriving (Show) -- | Container object. data Container = Container { containerName :: String -- ^ Container name. , containerConfigPath :: Maybe String -- ^ Container config path. } deriving (Show) -- | Allocate a new @lxc_container@. newC'lxc_container :: Container -> IO (Ptr C'lxc_container) newC'lxc_container (Container name configPath) = do c <- withCString name $ \cname -> maybeWith withCString configPath $ \cconfigPath -> c'lxc_container_new cname cconfigPath when (c == nullPtr) $ error "failed to allocate new container" return c peekC'lxc_container :: Ptr C'lxc_container -> IO (String -> Container) peekC'lxc_container ptr = do configPath <- peek (p'lxc_container'config_path ptr) >>= maybePeek peekCString return $ \name -> Container name configPath -- | Marshal 'Container' to @lxc_container@ using temporary storage. withC'lxc_container :: Container -> (Ptr C'lxc_container -> IO a) -> IO a withC'lxc_container c f = do cc <- newC'lxc_container c ret <- f cc dropRef cc return ret -- | Container state. data ContainerState = ContainerStopped -- ^ Container is stopped. | ContainerStarting -- ^ Container is starting. | ContainerRunning -- ^ Container is running. | ContainerStopping -- ^ Container is stopping. | ContainerAborting -- ^ Container is aborting. | ContainerFreezing -- ^ Container is freezing. | ContainerFrozen -- ^ Container is frozen. | ContainerThawed -- ^ Container is thawed. | ContainerOtherState String -- ^ Container is in some other state. deriving (Eq, Show) -- | Parse state as string representation. parseState :: String -> ContainerState parseState "STOPPED" = ContainerStopped parseState "STARTING" = ContainerStarting parseState "RUNNING" = ContainerRunning parseState "STOPPING" = ContainerStopping parseState "ABORTING" = ContainerAborting parseState "FREEZING" = ContainerFreezing parseState "FROZEN" = ContainerFrozen parseState "THAWED" = ContainerThawed parseState s = ContainerOtherState s -- | Get string representation of a state. printState :: ContainerState -> String printState ContainerStopped = "STOPPED" printState ContainerStarting = "STARTING" printState ContainerRunning = "RUNNING" printState ContainerStopping = "STOPPING" printState ContainerAborting = "ABORTING" printState ContainerFreezing = "FREEZING" printState ContainerFrozen = "FROZEN" printState ContainerThawed = "THAWED" printState (ContainerOtherState s) = s -- | Specifications for how to create a new backing store. data BDevSpecs = BDevSpecs { bdevFSType :: String -- ^ Filesystem type. , bdevFSSize :: Word64 -- ^ Filesystem size in bytes. , bdevZFSRootPath :: FilePath -- ^ ZFS root path. , bdevLVMVolumeGroupName :: String -- ^ LVM Volume Group name. , bdevLVMLogicalVolumeName :: String -- ^ LVM Logical Volume name. , bdevLVMThinPool :: Maybe String -- ^ LVM thin pool to use, if any. , bdevDirectory :: FilePath -- ^ Directory path. } deriving (Show) -- | Marshal Haskell 'BDevSpecs' into C structure using temporary storage. -- -- * the memory is freed when the subcomputation terminates (either -- normally or via an exception), so the pointer to the temporary -- storage must /not/ be used after this. withC'bdev_specs :: BDevSpecs -> (Ptr C'bdev_specs -> IO a) -> IO a withC'bdev_specs specs f = do withCString (bdevFSType specs) $ \cFSType -> withCString (bdevZFSRootPath specs) $ \cZFSRootPath -> withCString (bdevLVMVolumeGroupName specs) $ \cLVMVolumeGroupName -> withCString (bdevLVMLogicalVolumeName specs) $ \cLVMLogicalVolumeName -> maybeWith withCString (bdevLVMThinPool specs) $ \cLVMThinPool -> withCString (bdevDirectory specs) $ \cDirectory -> do let cspecs = C'bdev_specs cFSType (bdevFSSize specs) (C'zfs_t cZFSRootPath) (C'lvm_t cLVMVolumeGroupName cLVMLogicalVolumeName cLVMThinPool) cDirectory with cspecs f type Field s a = Ptr s -> Ptr a mkFn :: (FunPtr (Ptr s -> a) -> (Ptr s -> a)) -> Field s (FunPtr (Ptr s -> a)) -> Ptr s -> IO a mkFn mk g s = do fn <- peek (g s) return $ mk fn s boolFn :: Field C'lxc_container (FunPtr ContainerBoolFn) -> LXC Bool boolFn g = lxc $ \c -> do fn <- mkFn mkBoolFn g c toBool <$> fn stringBoolFn :: Field C'lxc_container (FunPtr ContainerStringBoolFn) -> Maybe String -> LXC Bool stringBoolFn g s = lxc $ \c -> do fn <- mkFn mkStringBoolFn g c maybeWith withCString s $ \cs -> toBool <$> fn cs boolBoolFn :: Field C'lxc_container (FunPtr ContainerBoolBoolFn) -> Bool -> LXC Bool boolBoolFn g b = lxc $ \c -> do fn <- mkFn mkBoolBoolFn g c toBool <$> fn (if b then 1 else 0) getItemFn :: Field C'lxc_container (FunPtr ContainerGetItemFn) -> String -> LXC (Maybe String) getItemFn g s = lxc $ \c -> do fn <- mkFn mkGetItemFn g c withCString s $ \cs -> do -- call with NULL for retv to determine size of a buffer we need to allocate sz <- fn cs nullPtr 0 if (sz < 0) then return Nothing else allocaBytes (fromIntegral sz) $ \cretv -> do -- we call fn second time to actually get item into cretv buffer fn cs cretv sz Just <$> peekCString cretv setItemFn :: Field C'lxc_container (FunPtr ContainerSetItemFn) -> String -> Maybe String -> LXC Bool setItemFn g k v = lxc $ \c -> do fn <- mkFn mkSetItemFn g c withCString k $ \ck -> maybeWith withCString v $ \cv -> toBool <$> fn ck cv setItemFn' :: Field C'lxc_container (FunPtr ContainerSetItemFn) -> String -> String -> LXC Bool setItemFn' g k v = setItemFn g k (Just v) -- | Whether container wishes to be daemonized. getDaemonize :: LXC Bool getDaemonize = lxc $ \c -> toBool <$> peek (p'lxc_container'daemonize c) -- | Get last container's error. getLastError :: LXC (Maybe LXCError) getLastError = lxc $ \c -> do cmsg <- peek (p'lxc_container'error_string c) msg <- maybePeek peekCString cmsg num <- fromIntegral <$> peek (p'lxc_container'error_num c) return $ LXCError <$> msg <*> pure num -- | Determine if @\/var\/lib\/lxc\/\$name\/config@ exists. -- -- @True@ if container is defined, else @False@. isDefined :: LXC Bool isDefined = boolFn p'lxc_container'is_defined -- | Determine if container is running. -- -- @True@ on success, else @False@. isRunning :: LXC Bool isRunning = boolFn p'lxc_container'is_running -- | Determine state of container. state :: LXC ContainerState state = lxc $ \c -> do fn <- peek (p'lxc_container'state c) cs <- mkStringFn fn c -- we do not need to free cs parseState <$> peekCString cs -- | Freeze running container. -- -- @True@ on success, else @False@. freeze :: LXC Bool freeze = boolFn p'lxc_container'freeze -- | Thaw a frozen container. -- -- @True@ on success, else @False@. unfreeze :: LXC Bool unfreeze = boolFn p'lxc_container'unfreeze -- | Determine process ID of the containers init process. initPID :: LXC (Maybe ProcessID) initPID = lxc $ \c -> do fn <- mkFn mkProcessIDFn p'lxc_container'init_pid c pid <- fromIntegral <$> fn if (pid < 0) then return Nothing else return (Just pid) -- | Load the specified configuration for the container. loadConfig :: Maybe FilePath -- ^ Full path to alternate configuration file, or @Nothing@ to use the default configuration file. -> LXC Bool -- ^ @True@ on success, else @False@. loadConfig = stringBoolFn p'lxc_container'load_config -- | Start the container. start :: Bool -- ^ Use @lxcinit@ rather than @\/sbin\/init@. -> [String] -- ^ Array of arguments to pass to init. -> LXC Bool -- ^ @True@ on success, else @False@. start useinit argv = lxc $ \c -> do fn <- mkFn mkStartFn p'lxc_container'start c case argv of [] -> toBool <$> fn (fromBool useinit) nullPtr _ -> do withMany withCString argv $ \cargv -> withArray0 nullPtr cargv $ \cargv' -> toBool <$> fn (fromBool useinit) cargv' -- | Stop the container. -- -- @True@ on success, else @False@. stop :: LXC Bool stop = boolFn p'lxc_container'stop -- | Determine if the container wants to run disconnected from the terminal. wantDaemonize :: Bool -- ^ Value for the daemonize bit. -> LXC Bool -- ^ @True@ if container wants to be daemonised, else @False@. wantDaemonize = boolBoolFn p'lxc_container'want_daemonize -- | Determine whether container wishes all file descriptors to be closed on startup. wantCloseAllFDs :: Bool -- ^ Value for the @close_all_fds@ bit. -> LXC Bool -- ^ @True@ if container wants to be daemonised, else @False@. wantCloseAllFDs = boolBoolFn p'lxc_container'want_close_all_fds -- | Return current config file name. configFileName :: LXC (Maybe FilePath) configFileName = lxc $ \c -> do fn <- peek (p'lxc_container'config_file_name c) cs <- mkStringFn fn c s <- maybePeek peekCString cs when (isJust s) $ free cs return s -- | Wait for container to reach a particular state. -- -- * A timeout of @-1@ means wait forever. -- A timeout @0@ means do not wait. wait :: ContainerState -- ^ State to wait for. -> Int -- ^ Timeout in seconds. -> LXC Bool -- ^ @True@ if state reached within timeout, else @False@. wait s t = lxc $ \c -> do fn <- mkFn mkWaitFn p'lxc_container'wait c withCString (printState s) $ \cs -> toBool <$> fn cs (fromIntegral t) -- | Set a key/value configuration option. setConfigItem :: String -- ^ Name of option to set. -> String -- ^ Value to set. -> LXC Bool -- ^ @True@ on success, else @False@. setConfigItem = setItemFn' p'lxc_container'set_config_item -- | Delete the container. -- -- @True@ on success, else @False@. -- -- * NOTE: Container must be stopped and have no dependent snapshots. destroy :: LXC Bool destroy = boolFn p'lxc_container'destroy -- | Save configuaration to a file. saveConfig :: FilePath -- ^ Full path to file to save configuration in. -> LXC Bool -- ^ @True@ on success, else @False@. saveConfig s = stringBoolFn p'lxc_container'save_config (Just s) -- | Rename a container. rename :: String -- ^ New name to be used for the container. -> LXC Bool -- ^ @True@ on success, else @False@. rename s = stringBoolFn p'lxc_container'rename (Just s) -- | Request the container reboot by sending it @SIGINT@. -- -- @True@ if reboot request successful, else @False@. reboot :: LXC Bool reboot = boolFn p'lxc_container'reboot -- | Request the container shutdown by sending it @SIGPWR@. shutdown :: Int -- ^ Seconds to wait before returning false. (@-1@ to wait forever, @0@ to avoid waiting). -> LXC Bool -- ^ @True@ if the container was shutdown successfully, else @False@. shutdown n = lxc $ \c -> do fn <- mkFn mkShutdownFn p'lxc_container'shutdown c toBool <$> fn (fromIntegral n) -- | Completely clear the containers in-memory configuration. clearConfig :: LXC () clearConfig = lxc $ join . mkFn mkClearConfigFn p'lxc_container'clear_config -- | Retrieve the value of a config item. getConfigItem :: String -- ^ Name of option to get. -> LXC (Maybe String) -- ^ The item or @Nothing@ on error. getConfigItem = getItemFn p'lxc_container'get_config_item -- | Retrieve the value of a config item from running container. getRunningConfigItem :: String -- ^ Name of option to get. -> LXC (Maybe String) -- ^ The item or @Nothing@ on error. getRunningConfigItem k = lxc $ \c -> do fn <- mkFn mkGetRunningConfigItemFn p'lxc_container'get_running_config_item c withCString k $ \ck -> do cv <- fn ck v <- maybePeek peekCString cv when (isJust v) $ free cv return v -- | Retrieve a list of config item keys given a key prefix. getKeys :: String -- ^ Key prefix. -> LXC [String] -- ^ List of keys. getKeys kp = concatMap lines . maybeToList <$> getItemFn p'lxc_container'get_keys kp -- | Obtain a list of network interfaces. getInterfaces :: LXC [String] getInterfaces = lxc $ \c -> do cifs <- join $ mkFn mkGetInterfacesFn p'lxc_container'get_interfaces c if (cifs == nullPtr) then return [] else do cifs' <- peekArray0 nullPtr cifs ifs <- mapM peekCString cifs' mapM_ free cifs' free cifs return ifs -- | Determine the list of container IP addresses. getIPs :: String -- ^ Network interface name to consider. -> String -- ^ Network family (for example @"inet"@, @"inet6"@). -> Word32 -- ^ IPv6 scope id (ignored if family is not "inet6"). -> LXC [String] -- ^ A list of network interfaces. getIPs iface fam sid = lxc $ \c -> do fn <- mkFn mkGetIPsFn p'lxc_container'get_ips c withCString iface $ \ciface -> withCString fam $ \cfam -> do cips <- fn ciface cfam (fromIntegral sid) if (cips == nullPtr) then return [] else do cips' <- peekArray0 nullPtr cips ips <- mapM peekCString cips' mapM_ free cips' free cips return ips -- | Retrieve the specified cgroup subsystem value for the container. getCGroupItem :: String -- ^ @cgroup@ subsystem to retrieve. -> LXC (Maybe String) -- ^ @cgroup@ subsystem value or @Nothing@ on error. getCGroupItem = getItemFn p'lxc_container'get_cgroup_item -- | Set the specified cgroup subsystem value for the container. setCGroupItem :: String -- ^ @cgroup@ subsystem to consider. -> String -- ^ Value to set. -> LXC Bool -- ^ @True@ on success, else @False@. setCGroupItem = setItemFn' p'lxc_container'set_cgroup_item -- | Clear a configuration item. -- -- Analog of 'setConfigItem'. clearConfigItem :: String -- ^ Name of option to clear. -> LXC Bool -- ^ @True@ on success, else @False@. clearConfigItem s = stringBoolFn p'lxc_container'clear_config_item (Just s) -- | Determine full path to the containers configuration file. -- -- Each container can have a custom configuration path. However -- by default it will be set to either the @LXCPATH@ configure -- variable, or the lxcpath value in the @LXC_GLOBAL_CONF@ configuration -- file (i.e. @\/etc\/lxc\/lxc.conf@). -- -- The value for a specific container can be changed using -- 'setConfigPath'. getConfigPath :: LXC FilePath getConfigPath = lxc $ \c -> do cs <- join $ mkFn mkStringFn p'lxc_container'get_config_path c s <- peekCString cs free cs return s -- | Set the full path to the containers configuration file. setConfigPath :: FilePath -- ^ Full path to configuration file. -> LXC Bool -- ^ @True@ on success, else @False@. setConfigPath s = stringBoolFn p'lxc_container'set_config_path (Just s) -- | Copy a stopped container. clone :: Maybe String -- ^ New name for the container. If @Nothing@, the same name is used and a new lxcpath MUST be specified. -> Maybe FilePath -- ^ lxcpath in which to create the new container. If @Nothing@, the original container's lxcpath will be used. -> [CloneOption] -- ^ Additional 'CloneOption' flags to change the cloning behaviour. -> Maybe String -- ^ Optionally force the cloned bdevtype to a specified plugin. By default the original is used (subject to snapshot requirements). -> Maybe String -- ^ Information about how to create the new storage (i.e. fstype and fsdata). -> Maybe Word64 -- ^ In case of a block device backing store, an optional size. If @Nothing@, the original backing store's size will be used if possible. Note this only applies to the rootfs. For any other filesystems, the original size will be duplicated. -> [String] -- ^ Additional arguments to pass to the clone hook script. -> LXC (Maybe Container) -- ^ Newly-allocated copy of container $c$, or @Nothing@ on error. clone newname lxcpath flags bdevtype bdevdata newsize hookargs = do oldname <- asks fst lxc $ \c -> do c' <- maybeWith withCString newname $ \cnewname -> maybeWith withCString lxcpath $ \clxcpath -> maybeWith withCString bdevtype $ \cbdevtype -> maybeWith withCString bdevdata $ \cbdevdata -> withMany withCString hookargs $ \chookargs -> withArray0 nullPtr chookargs $ \chookargs' -> do fn <- mkFn mkCloneFn p'lxc_container'clone c fn cnewname clxcpath (mkFlags cloneFlag flags) cbdevtype cbdevdata (fromMaybe 0 newsize) chookargs' c'' <- maybePeek peekC'lxc_container c' when (isJust c'') $ do dropRef c' return () return $ c'' <*> pure (fromMaybe oldname newname) -- | Allocate a console tty for the container. -- -- * The returned file descriptor is used to keep the tty -- allocated. The caller should call close(2) on the returned file -- descriptor when no longer required so that it may be allocated -- by another caller. consoleGetFD :: Maybe Int -- ^ Terminal number to attempt to allocate, or @Nothing@ to allocate the first available tty. -> LXC (Maybe (Int, Int, Int)) -- ^ Tuple /@@/ where @fd@ is file descriptor number, @ttynum@ is terminal number and @masterfd@ is file descriptor refering to the master side of the pty. consoleGetFD ttynum = lxc $ \c -> do fn <- mkFn mkConsoleGetFDFn p'lxc_container'console_getfd c alloca $ \cttynum -> alloca $ \cmasterfd -> do poke cttynum (fromIntegral $ fromMaybe (-1) ttynum) fd <- fromIntegral <$> fn cttynum cmasterfd ttynum' <- fromIntegral <$> peek cttynum masterfd <- fromIntegral <$> peek cmasterfd if (fd < 0) then return Nothing else return $ Just (fd, ttynum', masterfd) -- | Allocate and run a console tty. console :: Maybe Int -- ^ Terminal number to attempt to allocate, @Nothing@ to allocate the first available tty or @Just 0@ to allocate the console. -> Fd -- ^ File descriptor to read input from. -> Fd -- ^ File descriptor to write output to. -> Fd -- ^ File descriptor to write error output to. -> Int -- ^ The escape character (@1 == \'a\'@, @2 == \'b\'@, ...). -> LXC Bool -- ^ @True@ on success, else @False@. console ttynum stdin stdout stderr escape = lxc $ \c -> do fn <- mkFn mkConsoleFn p'lxc_container'console c toBool <$> fn (fromIntegral $ fromMaybe (-1) ttynum) (fromIntegral stdin) (fromIntegral stdout) (fromIntegral stderr) (fromIntegral escape) -- | Create a sub-process attached to a container and run a function inside it. attach :: AttachExecFn -- ^ Function to run. -> AttachCommand -- ^ Data to pass to @exec@ function. -> AttachOptions -- ^ Attach options. -> LXC (Maybe ProcessID) -- ^ Process ID of process running inside container @c@ that is running @exec@ function, or @Nothing@ on error. attach exec cmd opts = lxc $ \c -> do fn <- mkFn mkAttachFn p'lxc_container'attach c withC'lxc_attach_command_t cmd $ \ccmd -> withC'lxc_attach_options_t opts $ \copts -> alloca $ \cpid -> do ret <- fn (getAttachExecFn exec) (castPtr ccmd) copts cpid if (ret < 0) then return Nothing else Just . fromIntegral <$> peek cpid -- | Run a program inside a container and wait for it to exit. attachRunWait :: AttachOptions -- ^ Attach options. -> String -- ^ Full path inside container of program to run. -> [String] -- ^ Array of arguments to pass to program. -> LXC (Maybe ExitCode) -- ^ @waitpid(2)@ status of exited process that ran program, or @Nothing@ on error. attachRunWait opts prg argv = lxc $ \c -> do fn <- mkFn mkAttachRunWaitFn p'lxc_container'attach_run_wait c withCString prg $ \cprg -> withMany withCString argv $ \cargv -> withArray0 nullPtr cargv $ \cargv' -> withC'lxc_attach_options_t opts $ \copts -> do ret <- fromIntegral <$> fn copts cprg cargv' case ret of _ | ret < 0 -> return Nothing 0 -> return $ Just ExitSuccess _ -> return $ Just (ExitFailure ret) -- | Create a container snapshot. -- -- Assuming default paths, snapshots will be created as -- @\/var\/lib\/lxc\/\\/snaps\/snap\@ -- where @\@ represents the container name and @\@ -- represents the zero-based snapshot number. snapshot :: Maybe FilePath -- ^ Full path to file containing a description of the snapshot. -> LXC (Maybe Int) -- ^ @Nothing@ on error, or zero-based snapshot number. snapshot path = lxc $ \c -> do fn <- mkFn mkSnapshotFn p'lxc_container'snapshot c maybeWith withCString path $ \cpath -> do n <- fn cpath if (n == -1) then return Nothing else return (Just $ fromIntegral n) peekC'lxc_snapshot :: Ptr C'lxc_snapshot -> IO Snapshot peekC'lxc_snapshot ptr = Snapshot <$> peekField peekCString p'lxc_snapshot'name <*> peekField (maybePeek peekCString) p'lxc_snapshot'comment_pathname <*> peekField peekCString p'lxc_snapshot'timestamp <*> peekField peekCString p'lxc_snapshot'lxcpath where peekField g f = peek (f ptr) >>= g -- | Obtain a list of container snapshots. snapshotList :: LXC [Snapshot] snapshotList = lxc $ \c -> do alloca $ \css -> do fn <- mkFn mkSnapshotListFn p'lxc_container'snapshot_list c n <- fromIntegral <$> fn css if (n <= 0) then return [] else do css' <- peek css let css'' = take n $ iterate (flip advancePtr 1) css' css <- mapM peekC'lxc_snapshot css'' forM_ css'' $ join . mkFn 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 :: String -- ^ Name of snapshot. -> String -- ^ Name to be used for the restored snapshot. -> LXC Bool -- ^ @True@ on success, else @False@. snapshotRestore = setItemFn' p'lxc_container'snapshot_restore -- | Destroy the specified snapshot. snapshotDestroy :: String -- ^ Name of snapshot. -> LXC Bool -- ^ @True@ on success, else @False@. snapshotDestroy n = stringBoolFn p'lxc_container'snapshot_destroy (Just n) -- | Determine if the caller may control the container. -- -- @False@ if there is a control socket for the container monitor -- and the caller may not access it, otherwise returns @True@. mayControl :: LXC Bool mayControl = boolFn p'lxc_container'may_control -- | Add specified device to the container. addDeviceNode :: FilePath -- ^ Full path of the device. -> Maybe FilePath -- ^ Alternate path in the container (or @Nothing@ to use source path). -> LXC Bool -- ^ @True@ on success, else @False@. addDeviceNode = setItemFn p'lxc_container'add_device_node -- | Remove specified device from the container. removeDeviceNode :: FilePath -- ^ Full path of the device. -> Maybe FilePath -- ^ Alternate path in the container (or @Nothing@ to use source path). -> LXC Bool -- ^ @True@ on success, else @False@. removeDeviceNode = setItemFn p'lxc_container'remove_device_node -- | Create a container. create :: String -- ^ Template to execute to instantiate the root filesystem and adjust the configuration. -> Maybe String -- ^ Backing store type to use (if @Nothing@, @dir@ type will be used by default). -> Maybe BDevSpecs -- ^ Additional parameters for the backing store (for example LVM volume group to use). -> [CreateOption] -- ^ 'CreateOption' flags. /Note: LXC 1.0 supports only @CreateQuiet@ option./ -> [String] -- ^ Arguments to pass to the template. -> LXC Bool -- ^ @True@ on success. @False@ otherwise. create t bdevtype bdevspecs flags argv = lxc $ \c -> toBool <$> do withMany withCString argv $ \cargv -> withArray0 nullPtr cargv $ \cargv' -> withCString t $ \ct -> maybeWith withCString bdevtype $ \cbdevtype -> maybeWith withC'bdev_specs bdevspecs $ \cbdevspecs -> do fn <- peek $ p'lxc_container'create $ c mkCreateFn fn (c) ct cbdevtype nullPtr (mkFlags createFlag flags) cargv' -- | Add a reference to the specified container. getRef :: Ptr C'lxc_container -> IO Bool getRef c = toBool <$> c'lxc_container_get c -- | Drop a reference to the specified container. -- -- @Just False@ on success, @Just True@ if reference was successfully dropped -- and container has been freed, and @Nothing@ on error. dropRef :: Ptr C'lxc_container -> IO (Maybe Bool) dropRef c = do n <- c'lxc_container_put c return $ case n of 0 -> Just False 1 -> Just True _ -> Nothing -- | Obtain a list of all container states. getWaitStates :: IO [ContainerState] getWaitStates = do sz <- fromIntegral <$> c'lxc_get_wait_states nullPtr allocaArray sz $ \cstates -> do c'lxc_get_wait_states cstates cstates' <- peekArray sz cstates map parseState <$> mapM peekCString cstates' -- we do not need to free the strings themselves -- | Get the value for a global config key. getGlobalConfigItem :: String -- ^ The name of the config key. -> IO (Maybe String) -- ^ String representing the current value for the key. @Nothing@ on error. getGlobalConfigItem k = do withCString k $ \ck -> do cv <- c'lxc_get_global_config_item ck maybePeek peekCString cv -- | Determine version of LXC. getVersion :: IO String getVersion = c'lxc_get_version >>= peekCString listContainersFn :: (CString -> Ptr (Ptr CString) -> Ptr (Ptr (Ptr C'lxc_container)) -> IO CInt) -> Maybe String -> IO [Container] listContainersFn f lxcpath = do maybeWith withCString lxcpath $ \clxcpath -> alloca $ \cnames -> alloca $ \ccontainers -> do n <- fromIntegral <$> f clxcpath cnames ccontainers if (n <= 0) then return [] else do cnames' <- peek cnames cnames'' <- peekArray n cnames' names <- mapM peekCString cnames'' mapM_ free cnames'' free cnames' ccontainers' <- peek ccontainers ccontainers'' <- peekArray n ccontainers' containers <- mapM peekC'lxc_container ccontainers'' mapM_ free ccontainers'' free ccontainers' return $ zipWith ($) containers names -- | Get a list of defined containers in a lxcpath. listDefinedContainers :: Maybe String -- ^ lxcpath under which to look. -> IO [Container] -- ^ List of pairs. listDefinedContainers = listContainersFn c'list_defined_containers -- | Get a list of active containers for a given lxcpath. listActiveContainers :: Maybe String -- ^ Full @LXCPATH@ path to consider. -> IO [Container] -- ^ List of pairs. listActiveContainers = listContainersFn c'list_active_containers -- | Get a complete list of all containers for a given lxcpath. listAllContainers :: Maybe String -- ^ Full @LXCPATH@ path to consider. -> IO [Container] -- ^ List of pairs. listAllContainers = listContainersFn c'list_all_containers -- | Close log file. logClose :: IO () logClose = c'lxc_log_close