lxc 0.2 → 0.3
raw patch · 8 files changed
+406/−243 lines, 8 filesdep +mtldep +transformers
Dependencies added: mtl, transformers
Files
- CHANGELOG.md +13/−0
- README.md +26/−13
- examples/test.hs +82/−0
- lxc.cabal +4/−1
- src/System/LXC.hs +49/−0
- src/System/LXC/Container.hs +3/−3
- src/System/LXC/Internal/AttachOptions.hs +2/−7
- src/System/LXC/Internal/Container.hs +227/−219
CHANGELOG.md view
@@ -1,3 +1,16 @@+0.3+---+* introduced `LXC` monad+* `transformers` and `mtl` added to dependencies+* convert container-related functions to use `LXC` monad+* `listContainers` functions now return `[Container]` instead of `[(String, Ptr C'lxc_container)]`+* removed `mkContainer` function+* remove `getRef` and `dropRef` from `System.LXC.Container`+* `Container` is now pure Haskell data structure+* added `examples/`+* `Internal` gains `C'lxc_container` marshalling helpers (e.g. `withC'lxc_container`)+* fixed potential segfaults in `snapshotList` and `list*Containers`+ 0.2 --- * LXC errors through `getLastError` function
README.md view
@@ -49,11 +49,21 @@ ## Usage -You can start using these bindings just like command line tool:+Most of container-related functions (e.g. `start`, `attach`, `destroy`) perform in a `LXC` monad.+To run `LXC a` computation you need to specify a container using `withContainer` function.+When working with a single container it might be handy to have an alias like this: +```haskell+let containerName = withContainer (Container "container-name" configPath) ```->>> trusty <- mkContainer "trusty" Nothing->>> create trusty "download" Nothing Nothing [] ["-d", "ubuntu", "-r", "trusty", "-a", "amd64"]++You can start using Haskell LXC API bindings similar to a command line tool from GHCi:++```+$ ghci+>>> import System.LXC+>>> let trusty = withContainer (Container "trusty" Nothing)+>>> trusty $ create "download" Nothing Nothing [] ["-d", "ubuntu", "-r", "trusty", "-a", "amd64"] Using image from local cache Unpacking the rootfs @@ -63,27 +73,30 @@ To gain root privileges, please use sudo. True->>> start trusty False []+>>> trusty $ start False [] True->>> state trusty+>>> trusty state ContainerRunning->>> attachRunWait trusty defaultAttachOptions "echo" ["echo", "Hello, world!"]+>>> trusty $ attachRunWait defaultAttachOptions "echo" ["echo", "Hello, world!"] Hello, world! Just ExitSuccess->>> stop trusty+>>> trusty stop True->>> trustySnap <- clone trusty (Just "trusty-snap") Nothing [CloneSnapshot] Nothing Nothing Nothing []->>> start trustySnap False []+>>> Just trustySnapC <- trusty $ clone (Just "trusty-snap") Nothing [CloneSnapshot] Nothing Nothing Nothing []+>>> let trustySnap = withContainer trustySnapC+>>> trustySnap $ start False [] True->>> getInterfaces trustySnap+>>> trustySnap getInterfaces ["eth0","lo"]->>> getIPs trustySnap "eth0" "inet" 0+>>> trustySnap $ getIPs "eth0" "inet" 0 ["10.0.3.135"]->>> shutdown trustySnap (-1)+>>> trustySnap $ shutdown (-1) True->>> state trustySnap+>>> trustySnap state ContainerStopped ```++For more examples, please see `examples/` folder. ## Contributing
+ examples/test.hs view
@@ -0,0 +1,82 @@+module Main where++import Control.Concurrent (threadDelay)+import Control.Monad+import Control.Monad.IO.Class++import System.Exit+import System.LXC++-- | Dump container state.+dumpState :: LXC ()+dumpState = do+ s <- state+ liftIO $ do+ putStr "Container state: "+ print s++-- | Dump container IPs by interface.+dumpIPs :: LXC ()+dumpIPs = do+ ifs <- getInterfaces+ liftIO $ putStrLn "Container IPs:"+ forM_ ifs $ \i -> do+ liftIO $ do+ putStr "- "+ putStrLn i+ ips <- getIPs i "inet" (-1)+ liftIO $ do+ forM_ ips $ \ip -> do+ putStr " * "+ putStrLn ip++-- | Ping github.com from inside the container every second and wait until success.+waitForNetwork :: LXC ()+waitForNetwork = do+ ret <- attachRunWait defaultAttachOptions "ping" ["ping", "-c", "1", "github.com"]+ case ret of+ Just ExitSuccess -> return ()+ _ -> do+ liftIO $ threadDelay (10^6) -- sleep 1 sec+ waitForNetwork++-- | Create Ubuntu Trusty Tahr container and perform some actions with it.+--+-- Sample output:+--+-- $ runghc examples/test.hs+-- Using image from local cache+-- Unpacking the rootfs+--+-- ---+-- You just created an Ubuntu container (release=trusty, arch=amd64, variant=default)+-- The default username/password is: ubuntu / ubuntu+-- To gain root privileges, please use sudo.+--+-- ping: unknown host github.com+-- ping: unknown host github.com+-- ping: unknown host github.com+-- ping: unknown host github.com+-- PING github.com (192.30.252.130) 56(84) bytes of data.+-- 64 bytes from github.com (192.30.252.130): icmp_seq=1 ttl=61 time=300 ms+--+-- --- github.com ping statistics ---+-- 1 packets transmitted, 1 received, 0% packet loss, time 0ms+-- rtt min/avg/max/mdev = 300.847/300.847/300.847/0.000 ms+-- Hello, world!+-- Container IPs:+-- - eth0+-- * 10.0.3.177+-- - lo+-- * 127.0.0.1+-- Container state: ContainerStopped+main :: IO ()+main = withContainer (Container "trusty" Nothing) $ do+ create "download" Nothing Nothing [] ["-d", "ubuntu", "-r", "trusty", "-a", "amd64"]+ start False []+ wait ContainerRunning (-1)+ waitForNetwork+ attachRunWait defaultAttachOptions "echo" ["echo", "Hello, world!"]+ dumpIPs+ stop+ dumpState
lxc.cabal view
@@ -1,5 +1,5 @@ name: lxc-version: 0.2+version: 0.3 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@@ -13,6 +13,7 @@ build-type: Simple extra-source-files: README.md , CHANGELOG.md+ , examples/*.hs cabal-version: >=1.10 library@@ -28,6 +29,8 @@ System.LXC.Internal.Utils build-depends: base >=4.7 && <4.8 , bindings-lxc >=0.2 && <0.3+ , transformers >=0.4 && <0.5+ , mtl >=2.2 && <2.3 source-repository head type: git
src/System/LXC.hs view
@@ -9,6 +9,55 @@ -- Create, control and manage LXC containers through Haskell API. -- You can get more info about LXC at <https://help.ubuntu.com/lts/serverguide/lxc.html>. --+-- Most of container-related functions (e.g. 'start', 'attach', 'destroy') perform in 'System.LXC.Container.LXC' monad.+-- To run @'System.LXC.Container.LXC' a@ computation you need to specify a container using 'withContainer' function.+-- When working with a single container it might be handy to have an alias like this:+--+-- @+-- let containerName = withContainer (Container "container-name" configPath)+-- @+--+-- You can start using Haskell LXC API bindings similar to a command line tool from GHCi:+--+-- @+-- $ ghci+-- >>> import System.LXC+-- >>> let trusty = withContainer (Container "trusty" Nothing)+-- >>> trusty $ create "download" Nothing Nothing [] ["-d", "ubuntu", "-r", "trusty", "-a", "amd64"]+-- Using image from local cache+-- Unpacking the rootfs+--+-- ---+-- You just created an Ubuntu container (release=trusty, arch=amd64, variant=default)+-- The default username\/password is: ubuntu \/ ubuntu+-- To gain root privileges, please use sudo.+--+-- True+-- >>> trusty $ start False []+-- True+-- >>> trusty state+-- ContainerRunning+-- >>> trusty $ attachRunWait defaultAttachOptions "echo" ["echo", "Hello, world!"]+-- Hello, world!+-- Just ExitSuccess+-- >>> trusty stop+-- True+-- >>> Just trustySnapC <- trusty $ clone (Just "trusty-snap") Nothing [CloneSnapshot] Nothing Nothing Nothing []+-- >>> let trustySnap = withContainer trustySnapC+-- >>> trustySnap $ start False []+-- True+-- >>> trustySnap getInterfaces+-- ["eth0","lo"]+-- >>> trustySnap $ getIPs "eth0" "inet" 0+-- ["10.0.3.135"]+-- >>> trustySnap $ shutdown (-1)+-- True+-- >>> trustySnap state+-- ContainerStopped+-- @+--+-- For more examples, please see @examples\/@ folder.+-- ----------------------------------------------------------------------------- module System.LXC ( module System.LXC.Container,
src/System/LXC/Container.hs view
@@ -13,13 +13,15 @@ -- ----------------------------------------------------------------------------- module System.LXC.Container (+ -- * LXC Monad+ LXC,+ withContainer, -- * Data types Container(..), Snapshot(..), BDevSpecs(..), ContainerState(..), parseState, printState,- mkContainer, -- * Flags CloneOption(..), CreateOption(..),@@ -81,8 +83,6 @@ mayControl, addDeviceNode, removeDeviceNode,- getRef,- dropRef, -- * Global LXC functions -- ** List containers listDefinedContainers,
src/System/LXC/Internal/AttachOptions.hs view
@@ -18,13 +18,8 @@ import Data.Int import Data.Maybe -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 Foreign+import Foreign.C import System.LXC.Internal.Utils
src/System/LXC/Internal/Container.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} ----------------------------------------------------------------------------- -- | -- Module : System.LXC.Internal.Container@@ -19,17 +21,14 @@ import Control.Applicative import Control.Monad+import Control.Monad.Reader+import Control.Monad.IO.Class 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 Foreign+import Foreign.C import System.LXC.Internal.AttachOptions import System.LXC.Internal.Utils@@ -129,6 +128,26 @@ 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.@@ -180,10 +199,34 @@ deriving (Show) -- | Container object.-newtype Container = Container {- getContainer :: Ptr C'lxc_container -- ^ A pointer to @lxc_container@ structure.-}+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.@@ -257,45 +300,32 @@ 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+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) -> Container -> IO Bool-boolFn g c = do- fn <- mkFn getContainer mkBoolFn g c+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) -> Container -> Maybe String -> IO Bool-stringBoolFn g c s = do- fn <- mkFn getContainer mkStringBoolFn g c+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) -> Container -> Bool -> IO Bool-boolBoolFn g c b = do- fn <- mkFn getContainer mkBoolBoolFn g c+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) -> Container -> String -> IO (Maybe String)-getItemFn g c s = do- fn <- mkFn getContainer mkGetItemFn g c+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@@ -306,23 +336,23 @@ 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+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) -> Container -> String -> String -> IO Bool-setItemFn' g c k v = setItemFn g c k (Just v)+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 :: Container -> IO Bool-getDaemonize (Container c) = toBool <$> peek (p'lxc_container'daemonize c)+getDaemonize :: LXC Bool+getDaemonize = lxc $ \c -> toBool <$> peek (p'lxc_container'daemonize c) -- | Get last container's error.-getLastError :: Container -> IO (Maybe LXCError)-getLastError (Container c) = do+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)@@ -331,18 +361,18 @@ -- | Determine if @\/var\/lib\/lxc\/\$name\/config@ exists. -- -- @True@ if container is defined, else @False@.-isDefined :: Container -> IO Bool+isDefined :: LXC Bool isDefined = boolFn p'lxc_container'is_defined -- | Determine if container is running. -- -- @True@ on success, else @False@.-isRunning :: Container -> IO Bool+isRunning :: LXC Bool isRunning = boolFn p'lxc_container'is_running -- | Determine state of container.-state :: Container -> IO ContainerState-state (Container c) = do+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@@ -350,37 +380,35 @@ -- | Freeze running container. -- -- @True@ on success, else @False@.-freeze :: Container -> IO Bool+freeze :: LXC Bool freeze = boolFn p'lxc_container'freeze -- | Thaw a frozen container. -- -- @True@ on success, else @False@.-unfreeze :: Container -> IO Bool+unfreeze :: LXC 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+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 :: 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 :: 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 :: Container -- ^ Container.- -> Bool -- ^ Use @lxcinit@ rather than @\/sbin\/init@.+start :: Bool -- ^ Use @lxcinit@ rather than @\/sbin\/init@. -> [String] -- ^ Array of arguments to pass to init.- -> IO Bool -- ^ @True@ on success, else @False@.-start c useinit argv = do- fn <- mkFn getContainer mkStartFn p'lxc_container'start c+ -> 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@@ -391,24 +419,22 @@ -- | Stop the container. -- -- @True@ on success, else @False@.-stop :: Container -> IO Bool+stop :: LXC 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 :: 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 :: Container -- ^ Container.- -> Bool -- ^ Value for the @close_all_fds@ bit.- -> IO Bool -- ^ @True@ if container wants to be daemonised, else @False@.+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 :: Container -> IO (Maybe FilePath)-configFileName (Container c) = do+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@@ -419,20 +445,18 @@ -- -- * A timeout of @-1@ means wait forever. -- A timeout @0@ means do not wait.-wait :: Container -- ^ Container.- -> ContainerState -- ^ State to wait for.+wait :: 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+ -> 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 :: Container -- ^ Container.- -> String -- ^ Name of option to set.+setConfigItem :: String -- ^ Name of option to set. -> String -- ^ Value to set.- -> IO Bool -- ^ @True@ on success, else @False@.+ -> LXC Bool -- ^ @True@ on success, else @False@. setConfigItem = setItemFn' p'lxc_container'set_config_item -- | Delete the container.@@ -440,51 +464,46 @@ -- @True@ on success, else @False@. -- -- * NOTE: Container must be stopped and have no dependent snapshots.-destroy :: Container -> IO Bool+destroy :: LXC 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)+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 :: 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)+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 :: Container -> IO Bool+reboot :: LXC 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+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 :: Container -> IO ()-clearConfig = join . mkFn getContainer mkClearConfigFn p'lxc_container'clear_config+clearConfig :: LXC ()+clearConfig = lxc $ join . mkFn 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 :: 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 :: 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+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@@ -492,15 +511,14 @@ 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+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 :: Container -> IO [String]-getInterfaces c = do- cifs <- join $ mkFn getContainer mkGetInterfacesFn p'lxc_container'get_interfaces c+getInterfaces :: LXC [String]+getInterfaces = lxc $ \c -> do+ cifs <- join $ mkFn mkGetInterfacesFn p'lxc_container'get_interfaces c if (cifs == nullPtr) then return [] else do@@ -511,13 +529,12 @@ return ifs -- | Determine the list of container IP addresses.-getIPs :: Container -- ^ Container.- -> String -- ^ Network interface name to consider.+getIPs :: 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+ -> 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)@@ -531,25 +548,22 @@ 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 :: 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 :: Container -- ^ Container.- -> String -- ^ @cgroup@ subsystem to consider.+setCGroupItem :: String -- ^ @cgroup@ subsystem to consider. -> String -- ^ Value to set.- -> IO Bool -- ^ @True@ on success, else @False@.+ -> LXC 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)+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. --@@ -560,48 +574,50 @@ -- -- 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+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 :: 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)+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 :: Container -- ^ Original container.- -> Maybe String -- ^ New name for the container. If @Nothing@, the same name is used and a new lxcpath MUST be specified.+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.- -> 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'+ -> 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. --@@ -609,11 +625,10 @@ -- 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+consoleGetFD :: Maybe Int -- ^ Terminal number to attempt to allocate, or @Nothing@ to allocate the first available tty.+ -> LXC (Maybe (Int, Int, Int)) -- ^ Tuple /@<fd, ttynum, masterfd>@/ where @fd@ is file descriptor number, @ttynum@ is terminal number and @masterfd@ is file descriptor refering to the master side of the pty.+consoleGetFD ttynum = lxc $ \c -> do+ fn <- mkFn mkConsoleGetFDFn p'lxc_container'console_getfd c alloca $ \cttynum -> alloca $ \cmasterfd -> do poke cttynum (fromIntegral $ fromMaybe (-1) ttynum)@@ -625,15 +640,14 @@ 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.+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\'@, ...).- -> IO Bool -- ^ @True@ on success, else @False@.-console c ttynum stdin stdout stderr escape = do- fn <- mkFn getContainer mkConsoleFn p'lxc_container'console c+ -> 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)@@ -641,13 +655,12 @@ (fromIntegral escape) -- | Create a sub-process attached to a container and run a function inside it.-attach :: Container -- ^ Container.- -> AttachExecFn -- ^ Function to run.+attach :: 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+ -> 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@@ -657,13 +670,12 @@ else Just . fromIntegral <$> peek cpid -- | Run a program inside a container and wait for it to exit.-attachRunWait :: Container -- ^ Container.- -> AttachOptions -- ^ Attach options.+attachRunWait :: 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+ -> 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' ->@@ -680,12 +692,11 @@ -- @\/var\/lib\/lxc\/\<c\>\/snaps\/snap\<n\>@ -- where @\<c\>@ represents the container name and @\<n\>@ -- represents the zero-based snapshot number.-snapshot :: Container -- ^ Container.- -> FilePath -- ^ Full path to file containing a description of the snapshot.- -> IO (Maybe Int) -- ^ @Nothing@ on error, or zero-based snapshot number.-snapshot c path = do- fn <- mkFn getContainer mkSnapshotFn p'lxc_container'snapshot c- withCString path $ \cpath -> do+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@@ -701,18 +712,18 @@ peekField g f = peek (f ptr) >>= g -- | Obtain a list of container snapshots.-snapshotList :: Container -> IO [Snapshot]-snapshotList c = do+snapshotList :: LXC [Snapshot]+snapshotList = lxc $ \c -> do alloca $ \css -> do- fn <- mkFn getContainer mkSnapshotListFn p'lxc_container'snapshot_list c+ fn <- mkFn mkSnapshotListFn p'lxc_container'snapshot_list c n <- fromIntegral <$> fn css- if (n < 0)+ 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+ forM_ css'' $ join . mkFn mkFreeFn p'lxc_snapshot'free free css' return css @@ -728,56 +739,51 @@ -- * /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.+snapshotRestore :: String -- ^ Name of snapshot. -> String -- ^ Name to be used for the restored snapshot.- -> IO Bool -- ^ @True@ on success, else @False@.+ -> LXC 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)+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 :: Container -> IO Bool+mayControl :: LXC Bool mayControl = boolFn p'lxc_container'may_control -- | Add specified device to the container.-addDeviceNode :: Container -- ^ Container.- -> FilePath -- ^ Full path of the device.+addDeviceNode :: 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@.+ -> LXC 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.+removeDeviceNode :: 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@.+ -> LXC 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.+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.- -> IO Bool -- ^ @True@ on success. @False@ otherwise.-create c t bdevtype bdevspecs flags argv = toBool <$> do+ -> 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 $ getContainer c+ fn <- peek $ p'lxc_container'create $ c mkCreateFn fn- (getContainer c)+ (c) ct cbdevtype nullPtr@@ -785,15 +791,15 @@ cargv' -- | Add a reference to the specified container.-getRef :: Container -> IO Bool-getRef (Container c) = toBool <$> c'lxc_container_get c+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 :: Container -> IO (Maybe Bool)-dropRef (Container c) = do+dropRef :: Ptr C'lxc_container -> IO (Maybe Bool)+dropRef c = do n <- c'lxc_container_put c return $ case n of 0 -> Just False@@ -824,13 +830,13 @@ listContainersFn :: (CString -> Ptr (Ptr CString) -> Ptr (Ptr (Ptr C'lxc_container)) -> IO CInt) -> Maybe String- -> IO [(String, Container)]+ -> IO [Container] listContainersFn f lxcpath = do maybeWith withCString lxcpath $ \clxcpath -> alloca $ \cnames -> alloca $ \ccontainers -> do n <- fromIntegral <$> f clxcpath cnames ccontainers- if (n < 0)+ if (n <= 0) then return [] else do cnames' <- peek cnames@@ -839,26 +845,28 @@ mapM_ free cnames'' free cnames' - ccontainers' <- peek ccontainers- containers <- map Container <$> peekArray n ccontainers'+ ccontainers' <- peek ccontainers+ ccontainers'' <- peekArray n ccontainers'+ containers <- mapM peekC'lxc_container ccontainers''+ mapM_ free ccontainers'' free ccontainers' - return $ zip names containers+ return $ zipWith ($) containers names -- | 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.+ -> IO [Container] -- ^ List of <name, container> pairs. listDefinedContainers = listContainersFn c'list_defined_containers -- | Get a list of active containers for a given lxcpath. listActiveContainers :: Maybe String -- ^ Full @LXCPATH@ path to consider.- -> IO [(String, Container)] -- ^ List of <name, container> pairs.+ -> IO [Container] -- ^ List of <name, container> pairs. listActiveContainers = listContainersFn c'list_active_containers -- | Get a complete list of all containers for a given lxcpath. listAllContainers :: Maybe String -- ^ Full @LXCPATH@ path to consider.- -> IO [(String, Container)] -- ^ List of <name, container> pairs.+ -> IO [Container] -- ^ List of <name, container> pairs. listAllContainers = listContainersFn c'list_all_containers -- | Close log file.