├── .gitignore ├── .travis.yml ├── CHANGELOG.md ├── LICENSE ├── README.md ├── Setup.hs ├── examples └── test.hs ├── lxc.cabal ├── src └── System │ ├── LXC.hs │ └── LXC │ ├── AttachOptions.hs │ ├── Container.hs │ └── Internal │ ├── AttachOptions.hs │ ├── Container.hs │ └── Utils.hs └── stack.yaml /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | *.o 4 | *.hi 5 | *.chi 6 | *.chs.h 7 | .virtualenv 8 | .hsenv 9 | .cabal-sandbox/ 10 | cabal.sandbox.config 11 | cabal.config 12 | .stack-work/ 13 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | sudo: required 2 | dist: trusty 3 | 4 | addons: 5 | apt: 6 | packages: 7 | - libgmp-dev 8 | 9 | env: 10 | - STACK_YAML=stack.yaml 11 | 12 | before_install: 13 | # install LXC 14 | - sudo apt-get install -y software-properties-common python-software-properties 15 | - sudo add-apt-repository -y ppa:ubuntu-lxc/stable 16 | - sudo apt-get update -qq 17 | - sudo apt-get install -y -o Dpkg::Options::="--force-confdef" -o Dpkg::Options::="--force-confnew" lxc-dev 18 | # Download and unpack the stack executable 19 | - mkdir -p ~/.local/bin 20 | - export PATH=$HOME/.local/bin:$PATH 21 | - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 22 | - export PATH=~/.local/bin:$PATH 23 | - stack --version 24 | 25 | install: 26 | - stack setup 27 | 28 | script: 29 | - stack --no-terminal build --test 30 | 31 | cache: 32 | directories: 33 | - $HOME/.stack 34 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | 0.3.2 2 | --- 3 | * Relax upper bound for `base` 4 | * Fix warnings 5 | 6 | 0.3.1.1 7 | --- 8 | * Loose `mtl` and `transformers` dependencies for `lxc` to play nice with other libraries 9 | 10 | 0.3.1 11 | --- 12 | * Add `snapshotDestroy` to `System.LXC.Container` 13 | * Improve documentation slightly 14 | 15 | 0.3 16 | --- 17 | * Introduce `LXC` monad 18 | * Add `transformers` and `mtl` dependencies 19 | * Change container-related functions to use `LXC` monad 20 | * Change `listContainers` functions to return `[Container]` instead of `[(String, Ptr C'lxc_container)]` 21 | * Remove `mkContainer` function 22 | * Remove `getRef` and `dropRef` from `System.LXC.Container` 23 | * Make `Container` a pure Haskell data structure 24 | * Add `examples/` 25 | * Add `C'lxc_container` marshalling helpers (e.g. `withC'lxc_container`) to `Internal` 26 | * Fix potential segfaults in `snapshotList` and `list*Containers` 27 | 28 | 0.2 29 | --- 30 | * Handle LXC errors through `getLastError` function 31 | * Add `getDaemonize` function 32 | * Fix `start` function (and changed type) 33 | * Add `Show` instance for `BDevSpecs` 34 | * Update documentation (haddock and README) 35 | 36 | 0.1.1 37 | --- 38 | * Fix `bindings-lxc` dependency 39 | * Expose `System.LXC.Internal.AttachOptions` module 40 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014, Nickolay Kudasov 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | * Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | 10 | * Redistributions in binary form must reproduce the above copyright notice, 11 | this list of conditions and the following disclaimer in the documentation 12 | and/or other materials provided with the distribution. 13 | 14 | * Neither the name of lxc nor the names of its 15 | contributors may be used to endorse or promote products derived from 16 | this software without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 19 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 20 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 21 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 22 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 24 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 25 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 26 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 27 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 28 | 29 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | lxc 2 | === 3 | 4 | [![Hackage package](http://img.shields.io/hackage/v/lxc.svg)](http://hackage.haskell.org/package/lxc) 5 | [![Build Status](https://travis-ci.org/fizruk/lxc.svg?branch=master)](https://travis-ci.org/fizruk/lxc) 6 | 7 | High level Haskell bindings to LXC (Linux containers). 8 | 9 | The library provides Haskell LXC API, wrapping [bindings-lxc package](http://hackage.haskell.org/package/bindings-lxc). 10 | 11 | ## Requirements 12 | 13 | Before installation make sure you have LXC installed on your system with header files and static library. 14 | 15 | Although there is `lxc-dev` package in standard Ubuntu repositories, 16 | you might want to use `ppa:ubuntu-lxc/stable` repository instead: 17 | 18 | ``` 19 | $ sudo apt-get install software-properties-common python-software-properties 20 | $ sudo add-apt-repository ppa:ubuntu-lxc/stable 21 | $ sudo apt-get update 22 | $ sudo apt-get install lxc-dev 23 | ``` 24 | 25 | ## Installation 26 | 27 | Get the latest stable version from Hackage: 28 | 29 | ``` 30 | $ cabal install lxc 31 | ``` 32 | 33 | or clone this repository: 34 | 35 | ``` 36 | $ git clone https://github.com/fizruk/lxc.git 37 | $ cd lxc 38 | $ cabal install 39 | ``` 40 | 41 | ## Documentation 42 | 43 | Haddock documentation is available at http://fizruk.github.io/lxc/docs/ 44 | 45 | ## Usage 46 | 47 | Most of container-related functions (e.g. `start`, `attach`, `destroy`) perform in a `LXC` monad. 48 | To run `LXC a` computation you need to specify a container using `withContainer` function. 49 | When working with a single container it might be handy to have an alias like this: 50 | 51 | ```haskell 52 | let containerName = withContainer (Container "container-name" configPath) 53 | ``` 54 | 55 | You can start using Haskell LXC API bindings similar to a command line tool from GHCi: 56 | 57 | ``` 58 | $ ghci 59 | >>> import System.LXC 60 | >>> let trusty = withContainer (Container "trusty" Nothing) 61 | >>> trusty $ create "download" Nothing Nothing [] ["-d", "ubuntu", "-r", "trusty", "-a", "amd64"] 62 | Using image from local cache 63 | Unpacking the rootfs 64 | 65 | --- 66 | You just created an Ubuntu container (release=trusty, arch=amd64, variant=default) 67 | The default username/password is: ubuntu / ubuntu 68 | To gain root privileges, please use sudo. 69 | 70 | True 71 | >>> trusty $ start False [] 72 | True 73 | >>> trusty state 74 | ContainerRunning 75 | >>> trusty $ attachRunWait defaultAttachOptions "echo" ["echo", "Hello, world!"] 76 | Hello, world! 77 | Just ExitSuccess 78 | >>> trusty stop 79 | True 80 | >>> Just trustySnapC <- trusty $ clone (Just "trusty-snap") Nothing [CloneSnapshot] Nothing Nothing Nothing [] 81 | >>> let trustySnap = withContainer trustySnapC 82 | >>> trustySnap $ start False [] 83 | True 84 | >>> trustySnap getInterfaces 85 | ["eth0","lo"] 86 | >>> trustySnap $ getIPs "eth0" "inet" 0 87 | ["10.0.3.135"] 88 | >>> trustySnap $ shutdown (-1) 89 | True 90 | >>> trustySnap state 91 | ContainerStopped 92 | ``` 93 | 94 | For more examples, please see `examples/` folder. 95 | 96 | ## Contributing 97 | 98 | Contributions and bug reports are welcome! 99 | 100 | Please feel free to contact me via GitHub or on the #haskell IRC channel on irc.freenode.net. 101 | 102 | -Nickolay Kudasov 103 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /examples/test.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Concurrent (threadDelay) 4 | import Control.Monad 5 | import Control.Monad.IO.Class 6 | 7 | import System.Exit 8 | import System.LXC 9 | 10 | -- | Dump container state. 11 | dumpState :: LXC () 12 | dumpState = do 13 | s <- state 14 | liftIO $ do 15 | putStr "Container state: " 16 | print s 17 | 18 | -- | Dump container IPs by interface. 19 | dumpIPs :: LXC () 20 | dumpIPs = do 21 | ifs <- getInterfaces 22 | liftIO $ putStrLn "Container IPs:" 23 | forM_ ifs $ \i -> do 24 | liftIO $ do 25 | putStr "- " 26 | putStrLn i 27 | ips <- getIPs i "inet" (-1) 28 | liftIO $ do 29 | forM_ ips $ \ip -> do 30 | putStr " * " 31 | putStrLn ip 32 | 33 | -- | Ping github.com from inside the container every second and wait until success. 34 | waitForNetwork :: LXC () 35 | waitForNetwork = do 36 | ret <- attachRunWait defaultAttachOptions "ping" ["ping", "-c", "1", "github.com"] 37 | case ret of 38 | Just ExitSuccess -> return () 39 | _ -> do 40 | liftIO $ threadDelay (10^6) -- sleep 1 sec 41 | waitForNetwork 42 | 43 | -- | Create Ubuntu Trusty Tahr container and perform some actions with it. 44 | -- 45 | -- Sample output: 46 | -- 47 | -- $ runghc examples/test.hs 48 | -- Using image from local cache 49 | -- Unpacking the rootfs 50 | -- 51 | -- --- 52 | -- You just created an Ubuntu container (release=trusty, arch=amd64, variant=default) 53 | -- The default username/password is: ubuntu / ubuntu 54 | -- To gain root privileges, please use sudo. 55 | -- 56 | -- ping: unknown host github.com 57 | -- ping: unknown host github.com 58 | -- ping: unknown host github.com 59 | -- ping: unknown host github.com 60 | -- PING github.com (192.30.252.130) 56(84) bytes of data. 61 | -- 64 bytes from github.com (192.30.252.130): icmp_seq=1 ttl=61 time=300 ms 62 | -- 63 | -- --- github.com ping statistics --- 64 | -- 1 packets transmitted, 1 received, 0% packet loss, time 0ms 65 | -- rtt min/avg/max/mdev = 300.847/300.847/300.847/0.000 ms 66 | -- Hello, world! 67 | -- Container IPs: 68 | -- - eth0 69 | -- * 10.0.3.177 70 | -- - lo 71 | -- * 127.0.0.1 72 | -- Container state: ContainerStopped 73 | main :: IO () 74 | main = withContainer (Container "trusty" Nothing) $ do 75 | create "download" Nothing Nothing [] ["-d", "ubuntu", "-r", "trusty", "-a", "amd64"] 76 | start False [] 77 | wait ContainerRunning (-1) 78 | waitForNetwork 79 | attachRunWait defaultAttachOptions "echo" ["echo", "Hello, world!"] 80 | dumpIPs 81 | stop 82 | dumpState 83 | -------------------------------------------------------------------------------- /lxc.cabal: -------------------------------------------------------------------------------- 1 | name: lxc 2 | version: 0.3.2 3 | synopsis: High level Haskell bindings to LXC (Linux containers). 4 | description: The library provides Haskell LXC API, wrapping . 5 | homepage: https://github.com/fizruk/lxc 6 | bug-reports: https://github.com/fizruk/lxc/issues 7 | license: BSD3 8 | license-file: LICENSE 9 | author: Nickolay Kudasov 10 | maintainer: nickolay.kudasov@gmail.com 11 | -- copyright: 12 | category: System 13 | build-type: Simple 14 | extra-source-files: README.md 15 | , CHANGELOG.md 16 | , examples/*.hs 17 | cabal-version: >=1.10 18 | 19 | library 20 | hs-source-dirs: src 21 | default-language: Haskell2010 22 | exposed-modules: 23 | System.LXC 24 | System.LXC.Container 25 | System.LXC.AttachOptions 26 | -- internal modules 27 | System.LXC.Internal.AttachOptions 28 | System.LXC.Internal.Container 29 | System.LXC.Internal.Utils 30 | build-depends: base >=4.7 && <5 31 | , bindings-lxc >=0.2 && <0.3 32 | , transformers >=0.2 33 | , mtl 34 | 35 | source-repository head 36 | type: git 37 | location: https://github.com/fizruk/lxc.git 38 | branch: master 39 | -------------------------------------------------------------------------------- /src/System/LXC.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : System.LXC 4 | -- Copyright : (c) Nickolay Kudasov 2014 5 | -- License : BSD-style (see the file LICENSE) 6 | -- 7 | -- Maintainer : nickolay.kudasov@gmail.com 8 | -- 9 | -- Create, control and manage LXC containers through Haskell API. 10 | -- You can get more info about LXC at and . 11 | -- 12 | -- Most of container-related functions (e.g. 'start', 'attach', 'destroy') perform in 'System.LXC.Container.LXC' monad. 13 | -- To run @'System.LXC.Container.LXC' a@ computation you need to specify a container using 'withContainer' function. 14 | -- When working with a single container it might be handy to have an alias like this: 15 | -- 16 | -- @ 17 | -- let containerName = withContainer (Container "container-name" configPath) 18 | -- @ 19 | -- 20 | -- You can start using Haskell LXC API bindings similar to a command line tool from GHCi: 21 | -- 22 | -- @ 23 | -- $ ghci 24 | -- >>> import System.LXC 25 | -- >>> let trusty = withContainer (Container "trusty" Nothing) 26 | -- >>> trusty $ create "download" Nothing Nothing [] ["-d", "ubuntu", "-r", "trusty", "-a", "amd64"] 27 | -- Using image from local cache 28 | -- Unpacking the rootfs 29 | -- 30 | -- --- 31 | -- You just created an Ubuntu container (release=trusty, arch=amd64, variant=default) 32 | -- The default username\/password is: ubuntu \/ ubuntu 33 | -- To gain root privileges, please use sudo. 34 | -- 35 | -- True 36 | -- >>> trusty $ start False [] 37 | -- True 38 | -- >>> trusty state 39 | -- ContainerRunning 40 | -- >>> trusty $ attachRunWait defaultAttachOptions "echo" ["echo", "Hello, world!"] 41 | -- Hello, world! 42 | -- Just ExitSuccess 43 | -- >>> trusty stop 44 | -- True 45 | -- >>> Just trustySnapC <- trusty $ clone (Just "trusty-snap") Nothing [CloneSnapshot] Nothing Nothing Nothing [] 46 | -- >>> let trustySnap = withContainer trustySnapC 47 | -- >>> trustySnap $ start False [] 48 | -- True 49 | -- >>> trustySnap getInterfaces 50 | -- ["eth0","lo"] 51 | -- >>> trustySnap $ getIPs "eth0" "inet" 0 52 | -- ["10.0.3.135"] 53 | -- >>> trustySnap $ shutdown (-1) 54 | -- True 55 | -- >>> trustySnap state 56 | -- ContainerStopped 57 | -- @ 58 | -- 59 | -- For more examples, please see @examples\/@ folder. 60 | -- 61 | ----------------------------------------------------------------------------- 62 | module System.LXC ( 63 | module System.LXC.Container, 64 | module System.LXC.AttachOptions 65 | ) where 66 | 67 | import System.LXC.Container 68 | import System.LXC.AttachOptions 69 | -------------------------------------------------------------------------------- /src/System/LXC/AttachOptions.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : System.LXC.AttachOptions 4 | -- Copyright : (c) Nickolay Kudasov 2014 5 | -- License : BSD-style (see the file LICENSE) 6 | -- 7 | -- Maintainer : nickolay.kudasov@gmail.com 8 | -- 9 | -- Options and structures to run commands inside LXC containers. 10 | -- You can get more info about LXC at and . 11 | -- 12 | -- Normally you should import @System.LXC@ module only. 13 | -- 14 | ----------------------------------------------------------------------------- 15 | module System.LXC.AttachOptions ( 16 | -- * Attach options 17 | AttachOptions(..), 18 | defaultAttachOptions, 19 | -- * Attach command 20 | AttachCommand(..), 21 | -- * Attach @exec@ functions 22 | AttachExecFn(..), 23 | attachRunCommand, 24 | attachRunShell, 25 | -- * Flags and environment policies 26 | AttachEnvPolicy(..), 27 | AttachFlag(..), 28 | fromAttachEnvPolicy, 29 | fromAttachFlag, 30 | ) where 31 | 32 | import System.LXC.Internal.AttachOptions 33 | -------------------------------------------------------------------------------- /src/System/LXC/Container.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : System.LXC.Container 4 | -- Copyright : (c) Nickolay Kudasov 2014 5 | -- License : BSD-style (see the file LICENSE) 6 | -- 7 | -- Maintainer : nickolay.kudasov@gmail.com 8 | -- 9 | -- This module provides a set of functions to create, control and manage 10 | -- LXC containers. 11 | -- You can get more info about LXC at and . 12 | -- 13 | -- Normally you should import @System.LXC@ module only. 14 | -- 15 | ----------------------------------------------------------------------------- 16 | module System.LXC.Container ( 17 | -- * LXC Monad 18 | LXC, 19 | withContainer, 20 | -- * Data types 21 | Container(..), 22 | Snapshot(..), 23 | BDevSpecs(..), 24 | ContainerState(..), 25 | parseState, printState, 26 | -- * Flags 27 | CloneOption(..), 28 | CreateOption(..), 29 | cloneFlag, createFlag, 30 | -- * LXC errors 31 | LXCError(..), 32 | prettyLXCError, 33 | -- * Container methods 34 | -- ** Query container state. 35 | isDefined, 36 | isRunning, 37 | state, 38 | initPID, 39 | getInterfaces, 40 | getIPs, 41 | getDaemonize, 42 | getLastError, 43 | -- ** Container config 44 | configFileName, 45 | getConfigPath, 46 | setConfigPath, 47 | loadConfig, 48 | saveConfig, 49 | getKeys, 50 | setConfigItem, 51 | getConfigItem, 52 | getRunningConfigItem, 53 | clearConfig, 54 | clearConfigItem, 55 | -- ** Control container state 56 | start, 57 | stop, 58 | reboot, 59 | shutdown, 60 | freeze, 61 | unfreeze, 62 | wait, 63 | -- ** Manage containers 64 | create, 65 | clone, 66 | rename, 67 | destroy, 68 | -- ** Console 69 | consoleGetFD, 70 | console, 71 | -- ** Attach to container 72 | attach, 73 | attachRunWait, 74 | -- ** Snapshots 75 | snapshot, 76 | snapshotList, 77 | snapshotRestore, 78 | snapshotDestroy, 79 | -- ** Misc 80 | wantDaemonize, 81 | wantCloseAllFDs, 82 | getCGroupItem, 83 | setCGroupItem, 84 | mayControl, 85 | addDeviceNode, 86 | removeDeviceNode, 87 | -- * Global LXC functions 88 | -- ** List containers 89 | listDefinedContainers, 90 | listActiveContainers, 91 | listAllContainers, 92 | -- ** Misc 93 | getWaitStates, 94 | getGlobalConfigItem, 95 | getVersion, 96 | logClose, 97 | ) where 98 | 99 | import System.LXC.Internal.Container 100 | -------------------------------------------------------------------------------- /src/System/LXC/Internal/AttachOptions.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK not-home #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : System.LXC.Internal.AttachOptions 5 | -- Copyright : (c) Nickolay Kudasov 2014 6 | -- License : BSD-style (see the file LICENSE) 7 | -- 8 | -- Maintainer : nickolay.kudasov@gmail.com 9 | -- 10 | -- Internal module to support options and structures to run 11 | -- commands inside LXC containers. 12 | -- Normally you should import @System.LXC@ module only. 13 | -- 14 | ----------------------------------------------------------------------------- 15 | module System.LXC.Internal.AttachOptions where 16 | 17 | import Bindings.LXC.AttachOptions 18 | 19 | import Data.Int 20 | import Data.Maybe 21 | 22 | import Foreign 23 | import Foreign.C 24 | 25 | import System.LXC.Internal.Utils 26 | 27 | import System.Posix.Types 28 | 29 | -- | @exec@ function to use for 'System.LXC.Container.attach'. 30 | -- 31 | -- See 'attachRunCommand' and 'attachRunShell'. 32 | newtype AttachExecFn = AttachExecFn { getAttachExecFn :: C_lxc_attach_exec_t } 33 | 34 | -- | LXC environment policy. 35 | data AttachEnvPolicy 36 | = AttachKeepEnv -- ^ Retain the environment. 37 | | AttachClearEnv -- ^ Clear the environment. 38 | deriving (Eq, Show) 39 | 40 | -- | Convert 'AttachEnvPolicy' to internal representation. 41 | fromAttachEnvPolicy :: Num a => AttachEnvPolicy -> a 42 | fromAttachEnvPolicy AttachKeepEnv = c'LXC_ATTACH_KEEP_ENV 43 | fromAttachEnvPolicy AttachClearEnv = c'LXC_ATTACH_CLEAR_ENV 44 | 45 | -- | Flags for 'System.LXC.Container.attach'. 46 | data AttachFlag 47 | = AttachMoveToCGroup -- ^ Move to cgroup. On by default. 48 | | AttachDropCapabilities -- ^ Drop capabilities. On by default. 49 | | AttachSetPersonality -- ^ Set personality. On by default 50 | | AttachLSMExec -- ^ Execute under a Linux Security Module. On by default. 51 | | AttachRemountProcSys -- ^ Remount /proc filesystem. Off by default. 52 | | AttachLSMNow -- ^ FIXME: unknown. Off by default. 53 | | AttachDefault -- ^ Mask of flags to apply by default. 54 | | AttachLSM -- ^ All Linux Security Module flags. 55 | deriving (Eq, Show) 56 | 57 | -- | Convert 'AttachFlag' to bit flag. 58 | fromAttachFlag :: Num a => AttachFlag -> a 59 | fromAttachFlag AttachMoveToCGroup = c'LXC_ATTACH_MOVE_TO_CGROUP 60 | fromAttachFlag AttachDropCapabilities = c'LXC_ATTACH_DROP_CAPABILITIES 61 | fromAttachFlag AttachSetPersonality = c'LXC_ATTACH_SET_PERSONALITY 62 | fromAttachFlag AttachLSMExec = c'LXC_ATTACH_LSM_EXEC 63 | fromAttachFlag AttachRemountProcSys = c'LXC_ATTACH_REMOUNT_PROC_SYS 64 | fromAttachFlag AttachLSMNow = c'LXC_ATTACH_LSM_NOW 65 | fromAttachFlag AttachDefault = c'LXC_ATTACH_DEFAULT 66 | fromAttachFlag AttachLSM = c'LXC_ATTACH_LSM 67 | 68 | -- | LXC attach options for 'System.LXC.Container.attach'. 69 | -- 70 | -- * /NOTE:/ for @stdin@, @stdout@ and @stderr@ descriptors 71 | -- @dup2()@ will be used before calling @exec_function@, 72 | -- (assuming not @0@, @1@ and @2@ are specified) and the 73 | -- original fds are closed before passing control 74 | -- over. Any @O_CLOEXEC@ flag will be removed after that. 75 | data AttachOptions = AttachOptions 76 | { attachFlags :: [AttachFlag] -- ^ Any combination of 'AttachFlag' flags. 77 | , attachNamespaces :: Int -- ^ The namespaces to attach to (CLONE_NEW... flags). 78 | -- | Initial personality (@Nothing@ to autodetect). 79 | -- 80 | -- * This may be ignored if @lxc@ is compiled without personality support 81 | , attachPersonality :: Maybe Int64 82 | -- | Inital current directory, @Nothing@ to use @cwd@. 83 | -- 84 | -- If the current directory does not exist in the container, the 85 | -- root directory will be used instead because of kernel defaults. 86 | , attachInitialCWD :: Maybe FilePath 87 | -- | The user-id to run as. 88 | -- 89 | -- * /NOTE:/ Set to @-1@ for default behaviour (init uid for userns 90 | -- containers or @0@ (super-user) if detection fails). 91 | , attachUID :: UserID 92 | -- |The group-id to run as. 93 | -- 94 | -- * /NOTE:/ Set to @-1@ for default behaviour (init gid for userns 95 | -- containers or @0@ (super-user) if detection fails). 96 | , attachGID :: GroupID 97 | , attachEnvPolicy :: AttachEnvPolicy -- ^ Environment policy. 98 | , attachExtraEnvVars :: [String] -- ^ Extra environment variables to set in the container environment. 99 | , attachExtraKeepEnv :: [String] -- ^ Names of environment variables in existing environment to retain in container environment. 100 | , attachStdinFD :: Fd -- ^ @stdin@ file descriptor. 101 | , attachStdoutFD :: Fd -- ^ @stdout@ file descriptor. 102 | , attachStderrFD :: Fd -- ^ @stderr@ file descriptor. 103 | } 104 | deriving (Show) 105 | 106 | -- | Default attach options to use. 107 | defaultAttachOptions :: AttachOptions 108 | defaultAttachOptions = AttachOptions 109 | { attachFlags = [AttachDefault] 110 | , attachNamespaces = -1 111 | , attachPersonality = Nothing 112 | , attachInitialCWD = Nothing 113 | , attachUID = -1 114 | , attachGID = -1 115 | , attachEnvPolicy = AttachKeepEnv 116 | , attachExtraEnvVars = [] 117 | , attachExtraKeepEnv = [] 118 | , attachStdinFD = 0 119 | , attachStdoutFD = 1 120 | , attachStderrFD = 2 121 | } 122 | 123 | -- | Representation of a command to run in a container. 124 | data AttachCommand = AttachCommand 125 | { attachProgram :: FilePath -- ^ The program to run (passed to @execvp@). 126 | , attachArgv :: [String] -- ^ The @argv@ of that program, including the program itself as the first element. 127 | } 128 | 129 | -- | Allocate @lxc_attach_options_t@ structure in a temporary storage. 130 | withC'lxc_attach_options_t :: AttachOptions -> (Ptr C'lxc_attach_options_t -> IO a) -> IO a 131 | withC'lxc_attach_options_t a f = do 132 | alloca $ \ca -> 133 | maybeWith withCString (attachInitialCWD a) $ \cinitialCWD -> 134 | withMany withCString (attachExtraEnvVars a) $ \cextraEnvVars -> 135 | withArray0 nullPtr cextraEnvVars $ \cextraEnvVars' -> 136 | withMany withCString (attachExtraKeepEnv a) $ \cextraKeepEnv -> 137 | withArray0 nullPtr cextraKeepEnv $ \cextraKeepEnv' -> do 138 | poke (p'lxc_attach_options_t'attach_flags ca) (mkFlags fromAttachFlag . attachFlags $ a) 139 | poke (p'lxc_attach_options_t'namespaces ca) (fromIntegral . attachNamespaces $ a) 140 | poke (p'lxc_attach_options_t'personality ca) (fromIntegral . fromMaybe (-1) . attachPersonality $ a) 141 | poke (p'lxc_attach_options_t'initial_cwd ca) cinitialCWD 142 | poke (p'lxc_attach_options_t'uid ca) (fromIntegral . attachUID $ a) 143 | poke (p'lxc_attach_options_t'gid ca) (fromIntegral . attachGID $ a) 144 | poke (p'lxc_attach_options_t'env_policy ca) (fromAttachEnvPolicy . attachEnvPolicy $ a) 145 | poke (p'lxc_attach_options_t'extra_env_vars ca) cextraEnvVars' 146 | poke (p'lxc_attach_options_t'extra_keep_env ca) cextraKeepEnv' 147 | poke (p'lxc_attach_options_t'stdin_fd ca) (fromIntegral . attachStdinFD $ a) 148 | poke (p'lxc_attach_options_t'stdout_fd ca) (fromIntegral . attachStdoutFD $ a) 149 | poke (p'lxc_attach_options_t'stderr_fd ca) (fromIntegral . attachStderrFD $ a) 150 | f ca 151 | 152 | -- | Allocate @lxc_attach_command_t@ structure in a temporary storage. 153 | withC'lxc_attach_command_t :: AttachCommand -> (Ptr C'lxc_attach_command_t -> IO a) -> IO a 154 | withC'lxc_attach_command_t a f = do 155 | alloca $ \ca -> 156 | withCString (attachProgram a) $ \cprogram -> 157 | withMany withCString (attachArgv a) $ \cargv -> 158 | withArray0 nullPtr cargv $ \cargv' -> do 159 | poke (p'lxc_attach_command_t'program ca) cprogram 160 | poke (p'lxc_attach_command_t'argv ca) cargv' 161 | f ca 162 | 163 | -- | Run a command in the container. 164 | attachRunCommand :: AttachExecFn 165 | attachRunCommand = AttachExecFn p'lxc_attach_run_command 166 | 167 | -- | Run a shell command in the container. 168 | attachRunShell :: AttachExecFn 169 | attachRunShell = AttachExecFn p'lxc_attach_run_shell 170 | 171 | -------------------------------------------------------------------------------- /src/System/LXC/Internal/Container.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK not-home #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | ----------------------------------------------------------------------------- 6 | -- | 7 | -- Module : System.LXC.Internal.Container 8 | -- Copyright : (c) Nickolay Kudasov 2014 9 | -- License : BSD-style (see the file LICENSE) 10 | -- 11 | -- Maintainer : nickolay.kudasov@gmail.com 12 | -- 13 | -- Internal module to provide a set of functions to create, 14 | -- control and manage LXC containers. 15 | -- Normally you should import @System.LXC@ module only. 16 | -- 17 | ----------------------------------------------------------------------------- 18 | module System.LXC.Internal.Container where 19 | 20 | import Bindings.LXC.AttachOptions 21 | import Bindings.LXC.Container 22 | import Bindings.LXC.Sys.Types 23 | 24 | #if !MIN_VERSION_base(4,8,0) 25 | import Control.Applicative 26 | #endif 27 | import Control.Monad 28 | import Control.Monad.Reader 29 | 30 | import Data.Maybe 31 | import Data.Word 32 | 33 | import Foreign 34 | import Foreign.C 35 | 36 | import System.LXC.Internal.AttachOptions 37 | import System.LXC.Internal.Utils 38 | 39 | import System.Exit 40 | import System.Posix.Types (ProcessID, Fd) 41 | 42 | type ContainerCreateFn = Ptr C'lxc_container -> CString -> CString -> Ptr C'bdev_specs -> CInt -> Ptr CString -> IO CBool 43 | foreign import ccall "dynamic" 44 | mkCreateFn :: FunPtr ContainerCreateFn -> ContainerCreateFn 45 | 46 | type ContainerCloneFn = Ptr C'lxc_container -> CString -> CString -> CInt -> CString -> CString -> C'uint64_t -> Ptr CString -> IO (Ptr C'lxc_container) 47 | foreign import ccall "dynamic" 48 | mkCloneFn :: FunPtr ContainerCloneFn -> ContainerCloneFn 49 | 50 | type ContainerBoolFn = Ptr C'lxc_container -> IO CBool 51 | foreign import ccall "dynamic" 52 | mkBoolFn :: FunPtr ContainerBoolFn -> ContainerBoolFn 53 | 54 | type ContainerStringFn = Ptr C'lxc_container -> IO CString 55 | foreign import ccall "dynamic" 56 | mkStringFn :: FunPtr ContainerStringFn -> ContainerStringFn 57 | 58 | type ContainerProcessIDFn = Ptr C'lxc_container -> IO C'pid_t 59 | foreign import ccall "dynamic" 60 | mkProcessIDFn :: FunPtr ContainerProcessIDFn -> ContainerProcessIDFn 61 | 62 | type ContainerStringBoolFn = Ptr C'lxc_container -> CString -> IO CBool 63 | foreign import ccall "dynamic" 64 | mkStringBoolFn :: FunPtr ContainerStringBoolFn -> ContainerStringBoolFn 65 | 66 | type ContainerBoolBoolFn = Ptr C'lxc_container -> CBool -> IO CBool 67 | foreign import ccall "dynamic" 68 | mkBoolBoolFn :: FunPtr ContainerBoolBoolFn -> ContainerBoolBoolFn 69 | 70 | type ContainerStartFn = Ptr C'lxc_container -> CInt -> Ptr CString -> IO CBool 71 | foreign import ccall "dynamic" 72 | mkStartFn :: FunPtr ContainerStartFn -> ContainerStartFn 73 | 74 | type ContainerShutdownFn = Ptr C'lxc_container -> CInt -> IO CBool 75 | foreign import ccall "dynamic" 76 | mkShutdownFn :: FunPtr ContainerShutdownFn -> ContainerShutdownFn 77 | 78 | type ContainerClearConfigFn = Ptr C'lxc_container -> IO () 79 | foreign import ccall "dynamic" 80 | mkClearConfigFn :: FunPtr ContainerClearConfigFn -> ContainerClearConfigFn 81 | 82 | type ContainerGetRunningConfigItemFn = Ptr C'lxc_container -> CString -> IO CString 83 | foreign import ccall "dynamic" 84 | mkGetRunningConfigItemFn :: FunPtr ContainerGetRunningConfigItemFn -> ContainerGetRunningConfigItemFn 85 | 86 | type ContainerGetItemFn = Ptr C'lxc_container -> CString -> CString -> CInt -> IO CInt 87 | foreign import ccall "dynamic" 88 | mkGetItemFn :: FunPtr ContainerGetItemFn -> ContainerGetItemFn 89 | 90 | type ContainerSetItemFn = Ptr C'lxc_container -> CString -> CString -> IO CBool 91 | foreign import ccall "dynamic" 92 | mkSetItemFn :: FunPtr ContainerSetItemFn -> ContainerSetItemFn 93 | 94 | type ContainerGetInterfacesFn = Ptr C'lxc_container -> IO (Ptr CString) 95 | foreign import ccall "dynamic" 96 | mkGetInterfacesFn :: FunPtr ContainerGetInterfacesFn -> ContainerGetInterfacesFn 97 | 98 | type ContainerGetIPsFn = Ptr C'lxc_container -> CString -> CString -> CInt -> IO (Ptr CString) 99 | foreign import ccall "dynamic" 100 | mkGetIPsFn :: FunPtr ContainerGetIPsFn -> ContainerGetIPsFn 101 | 102 | type ContainerWaitFn = Ptr C'lxc_container -> CString -> CInt -> IO CBool 103 | foreign import ccall "dynamic" 104 | mkWaitFn :: FunPtr ContainerWaitFn -> ContainerWaitFn 105 | 106 | type ContainerSnapshotFn = Ptr C'lxc_container -> CString -> IO CInt 107 | foreign import ccall "dynamic" 108 | mkSnapshotFn :: FunPtr ContainerSnapshotFn -> ContainerSnapshotFn 109 | 110 | type ContainerSnapshotListFn = Ptr C'lxc_container -> Ptr (Ptr C'lxc_snapshot) -> IO CInt 111 | foreign import ccall "dynamic" 112 | mkSnapshotListFn :: FunPtr ContainerSnapshotListFn -> ContainerSnapshotListFn 113 | 114 | type ContainerConsoleGetFDFn = Ptr C'lxc_container -> Ptr CInt -> Ptr CInt -> IO CInt 115 | foreign import ccall "dynamic" 116 | mkConsoleGetFDFn :: FunPtr ContainerConsoleGetFDFn -> ContainerConsoleGetFDFn 117 | 118 | type ContainerConsoleFn = Ptr C'lxc_container -> CInt -> CInt -> CInt -> CInt -> CInt -> IO CInt 119 | foreign import ccall "dynamic" 120 | mkConsoleFn :: FunPtr ContainerConsoleFn -> ContainerConsoleFn 121 | 122 | type ContainerAttachFn = Ptr C'lxc_container -> C_lxc_attach_exec_t -> Ptr () -> Ptr C'lxc_attach_options_t -> Ptr C'pid_t -> IO CInt 123 | foreign import ccall "dynamic" 124 | mkAttachFn :: FunPtr ContainerAttachFn -> ContainerAttachFn 125 | 126 | type ContainerAttachRunWaitFn = Ptr C'lxc_container -> Ptr C'lxc_attach_options_t -> CString -> Ptr CString -> IO CInt 127 | foreign import ccall "dynamic" 128 | mkAttachRunWaitFn :: FunPtr ContainerAttachRunWaitFn -> ContainerAttachRunWaitFn 129 | 130 | type SnapshotFreeFn = Ptr C'lxc_snapshot -> IO () 131 | foreign import ccall "dynamic" 132 | mkFreeFn :: FunPtr SnapshotFreeFn -> SnapshotFreeFn 133 | 134 | -- | LXC container-related computations. 135 | -- @'LXC' ~ 'ReaderT' ('String', 'Ptr' 'C'lxc_container') 'IO'@. 136 | -- 137 | -- Run @'LXC' a@ computations using 'withContainer'. 138 | newtype LXC a = LXC { runLXC :: ReaderT (String, Ptr C'lxc_container) IO a } 139 | deriving (Functor, Applicative, Monad, MonadReader (String, Ptr C'lxc_container), MonadIO) 140 | 141 | lxc :: (Ptr C'lxc_container -> IO a) -> LXC a 142 | lxc f = LXC . ReaderT $ \(_, p) -> f p 143 | 144 | -- | Run @'LXC' a@ computation for a given 'Container'. 145 | -- 146 | -- * for the whole computation a single @lxc_container@ structure 147 | -- will be allocated; it will be automatically freed at the end of 148 | -- computation. 149 | withContainer :: MonadIO m => Container -> LXC a -> m a 150 | withContainer c m = liftIO $ do 151 | withC'lxc_container c $ \cc -> do 152 | runReaderT (runLXC m) $ (containerName c, cc) 153 | 154 | -- | LXC error structure. 155 | data LXCError = LXCError 156 | { lxcErrorString :: String -- ^ Error message. 157 | , lxcErrorNum :: Int -- ^ Error number. 158 | } 159 | deriving (Show) 160 | 161 | -- | Pretty print LXC error message. 162 | prettyLXCError :: LXCError -> String 163 | prettyLXCError (LXCError msg num) = "Error " ++ show num ++ ": " ++ msg 164 | 165 | -- | Options for 'clone' operation. 166 | data CloneOption 167 | = CloneKeepName -- ^ Do not edit the rootfs to change the hostname. 168 | | CloneKeepMacAddr -- ^ Do not change the MAC address on network interfaces. 169 | | CloneSnapshot -- ^ Snapshot the original filesystem(s). 170 | | CloneKeepBDevType -- ^ Use the same bdev type. 171 | | CloneMaybeSnapshot -- ^ Snapshot only if bdev supports it, else copy. 172 | | CloneMaxFlags -- ^ Number of @LXC_CLONE_*@ flags. 173 | deriving (Eq, Ord) 174 | 175 | -- | Options for 'create' operation. 176 | data CreateOption 177 | = CreateQuiet -- ^ Redirect @stdin@ to @\/dev\/zero@ and @stdout@ and @stderr@ to @\/dev\/null@. 178 | | CreateMaxFlags -- ^ Number of @LXC_CREATE*@ flags. 179 | deriving (Eq, Ord) 180 | 181 | -- | Turn 'CloneOption' into a bit flag. 182 | cloneFlag :: Num a => CloneOption -> a 183 | cloneFlag CloneKeepName = c'LXC_CLONE_KEEPNAME 184 | cloneFlag CloneKeepMacAddr = c'LXC_CLONE_KEEPMACADDR 185 | cloneFlag CloneSnapshot = c'LXC_CLONE_SNAPSHOT 186 | cloneFlag CloneKeepBDevType = c'LXC_CLONE_KEEPBDEVTYPE 187 | cloneFlag CloneMaybeSnapshot = c'LXC_CLONE_MAYBE_SNAPSHOT 188 | cloneFlag CloneMaxFlags = c'LXC_CLONE_MAXFLAGS 189 | 190 | -- | Turn 'CreateOption' into a bit flag. 191 | createFlag :: Num a => CreateOption -> a 192 | createFlag CreateQuiet = c'LXC_CREATE_QUIET 193 | createFlag CreateMaxFlags = c'LXC_CREATE_MAXFLAGS 194 | 195 | -- | An LXC container snapshot. 196 | data Snapshot = Snapshot 197 | { snapshotName :: String -- ^ Name of snapshot. 198 | , snapshotCommentPathname :: Maybe FilePath -- ^ Full path to snapshots comment file. 199 | , snapshotTimestamp :: String -- ^ Time snapshot was created. 200 | , snapshotLXCPath :: FilePath -- ^ Full path to @LXCPATH@ for snapshot. 201 | } 202 | deriving (Show) 203 | 204 | -- | Container object. 205 | data Container = Container 206 | { containerName :: String -- ^ Container name. 207 | , containerConfigPath :: Maybe String -- ^ Container config path. 208 | } 209 | deriving (Show) 210 | 211 | -- | Allocate a new @lxc_container@. 212 | newC'lxc_container :: Container -> IO (Ptr C'lxc_container) 213 | newC'lxc_container (Container name configPath) = do 214 | c <- withCString name $ \cname -> 215 | maybeWith withCString configPath $ \cconfigPath -> 216 | c'lxc_container_new cname cconfigPath 217 | when (c == nullPtr) $ error "failed to allocate new container" 218 | return c 219 | 220 | peekC'lxc_container :: Ptr C'lxc_container -> IO (String -> Container) 221 | peekC'lxc_container ptr = do 222 | configPath <- peek (p'lxc_container'config_path ptr) >>= maybePeek peekCString 223 | return $ \name -> Container name configPath 224 | 225 | -- | Marshal 'Container' to @lxc_container@ using temporary storage. 226 | withC'lxc_container :: Container -> (Ptr C'lxc_container -> IO a) -> IO a 227 | withC'lxc_container c f = do 228 | cc <- newC'lxc_container c 229 | ret <- f cc 230 | _ <- dropRef cc 231 | return ret 232 | 233 | -- | Container state. 234 | data ContainerState 235 | = ContainerStopped -- ^ Container is stopped. 236 | | ContainerStarting -- ^ Container is starting. 237 | | ContainerRunning -- ^ Container is running. 238 | | ContainerStopping -- ^ Container is stopping. 239 | | ContainerAborting -- ^ Container is aborting. 240 | | ContainerFreezing -- ^ Container is freezing. 241 | | ContainerFrozen -- ^ Container is frozen. 242 | | ContainerThawed -- ^ Container is thawed. 243 | | ContainerOtherState String -- ^ Container is in some other state. 244 | deriving (Eq, Show) 245 | 246 | -- | Parse state as string representation. 247 | parseState :: String -> ContainerState 248 | parseState "STOPPED" = ContainerStopped 249 | parseState "STARTING" = ContainerStarting 250 | parseState "RUNNING" = ContainerRunning 251 | parseState "STOPPING" = ContainerStopping 252 | parseState "ABORTING" = ContainerAborting 253 | parseState "FREEZING" = ContainerFreezing 254 | parseState "FROZEN" = ContainerFrozen 255 | parseState "THAWED" = ContainerThawed 256 | parseState s = ContainerOtherState s 257 | 258 | -- | Get string representation of a state. 259 | printState :: ContainerState -> String 260 | printState ContainerStopped = "STOPPED" 261 | printState ContainerStarting = "STARTING" 262 | printState ContainerRunning = "RUNNING" 263 | printState ContainerStopping = "STOPPING" 264 | printState ContainerAborting = "ABORTING" 265 | printState ContainerFreezing = "FREEZING" 266 | printState ContainerFrozen = "FROZEN" 267 | printState ContainerThawed = "THAWED" 268 | printState (ContainerOtherState s) = s 269 | 270 | -- | Specifications for how to create a new backing store. 271 | data BDevSpecs = BDevSpecs 272 | { bdevFSType :: String -- ^ Filesystem type. 273 | , bdevFSSize :: Word64 -- ^ Filesystem size in bytes. 274 | , bdevZFSRootPath :: FilePath -- ^ ZFS root path. 275 | , bdevLVMVolumeGroupName :: String -- ^ LVM Volume Group name. 276 | , bdevLVMLogicalVolumeName :: String -- ^ LVM Logical Volume name. 277 | , bdevLVMThinPool :: Maybe String -- ^ LVM thin pool to use, if any. 278 | , bdevDirectory :: FilePath -- ^ Directory path. 279 | } 280 | deriving (Show) 281 | 282 | -- | Marshal Haskell 'BDevSpecs' into C structure using temporary storage. 283 | -- 284 | -- * the memory is freed when the subcomputation terminates (either 285 | -- normally or via an exception), so the pointer to the temporary 286 | -- storage must /not/ be used after this. 287 | withC'bdev_specs :: BDevSpecs -> (Ptr C'bdev_specs -> IO a) -> IO a 288 | withC'bdev_specs specs f = do 289 | withCString (bdevFSType specs) $ \cFSType -> 290 | withCString (bdevZFSRootPath specs) $ \cZFSRootPath -> 291 | withCString (bdevLVMVolumeGroupName specs) $ \cLVMVolumeGroupName -> 292 | withCString (bdevLVMLogicalVolumeName specs) $ \cLVMLogicalVolumeName -> 293 | maybeWith withCString (bdevLVMThinPool specs) $ \cLVMThinPool -> 294 | withCString (bdevDirectory specs) $ \cDirectory -> do 295 | let cspecs = C'bdev_specs 296 | cFSType 297 | (bdevFSSize specs) 298 | (C'zfs_t cZFSRootPath) 299 | (C'lvm_t 300 | cLVMVolumeGroupName 301 | cLVMLogicalVolumeName 302 | cLVMThinPool) 303 | cDirectory 304 | with cspecs f 305 | 306 | type Field s a = Ptr s -> Ptr a 307 | 308 | mkFn :: (FunPtr (Ptr s -> a) -> (Ptr s -> a)) -> Field s (FunPtr (Ptr s -> a)) -> Ptr s -> IO a 309 | mkFn mk g s = do 310 | fn <- peek (g s) 311 | return $ mk fn s 312 | 313 | boolFn :: Field C'lxc_container (FunPtr ContainerBoolFn) -> LXC Bool 314 | boolFn g = lxc $ \c -> do 315 | fn <- mkFn mkBoolFn g c 316 | toBool <$> fn 317 | 318 | stringBoolFn :: Field C'lxc_container (FunPtr ContainerStringBoolFn) -> Maybe String -> LXC Bool 319 | stringBoolFn g s = lxc $ \c -> do 320 | fn <- mkFn mkStringBoolFn g c 321 | maybeWith withCString s $ \cs -> 322 | toBool <$> fn cs 323 | 324 | boolBoolFn :: Field C'lxc_container (FunPtr ContainerBoolBoolFn) -> Bool -> LXC Bool 325 | boolBoolFn g b = lxc $ \c -> do 326 | fn <- mkFn mkBoolBoolFn g c 327 | toBool <$> fn (if b then 1 else 0) 328 | 329 | getItemFn :: Field C'lxc_container (FunPtr ContainerGetItemFn) -> String -> LXC (Maybe String) 330 | getItemFn g s = lxc $ \c -> do 331 | fn <- mkFn mkGetItemFn g c 332 | withCString s $ \cs -> do 333 | -- call with NULL for retv to determine size of a buffer we need to allocate 334 | sz <- fn cs nullPtr 0 335 | if (sz < 0) 336 | then return Nothing 337 | else allocaBytes (fromIntegral sz) $ \cretv -> do 338 | -- we call fn second time to actually get item into cretv buffer 339 | _ <- fn cs cretv sz 340 | Just <$> peekCString cretv 341 | 342 | setItemFn :: Field C'lxc_container (FunPtr ContainerSetItemFn) -> String -> Maybe String -> LXC Bool 343 | setItemFn g k v = lxc $ \c -> do 344 | fn <- mkFn mkSetItemFn g c 345 | withCString k $ \ck -> 346 | maybeWith withCString v $ \cv -> 347 | toBool <$> fn ck cv 348 | 349 | setItemFn' :: Field C'lxc_container (FunPtr ContainerSetItemFn) -> String -> String -> LXC Bool 350 | setItemFn' g k v = setItemFn g k (Just v) 351 | 352 | -- | Whether container wishes to be daemonized. 353 | getDaemonize :: LXC Bool 354 | getDaemonize = lxc $ \c -> toBool <$> peek (p'lxc_container'daemonize c) 355 | 356 | -- | Get last container's error. 357 | getLastError :: LXC (Maybe LXCError) 358 | getLastError = lxc $ \c -> do 359 | cmsg <- peek (p'lxc_container'error_string c) 360 | msg <- maybePeek peekCString cmsg 361 | num <- fromIntegral <$> peek (p'lxc_container'error_num c) 362 | return $ LXCError <$> msg <*> pure num 363 | 364 | -- | Determine if @\/var\/lib\/lxc\/\$name\/config@ exists. 365 | -- 366 | -- @True@ if container is defined, else @False@. 367 | isDefined :: LXC Bool 368 | isDefined = boolFn p'lxc_container'is_defined 369 | 370 | -- | Determine if container is running. 371 | -- 372 | -- @True@ on success, else @False@. 373 | isRunning :: LXC Bool 374 | isRunning = boolFn p'lxc_container'is_running 375 | 376 | -- | Determine state of container. 377 | state :: LXC ContainerState 378 | state = lxc $ \c -> do 379 | fn <- peek (p'lxc_container'state c) 380 | cs <- mkStringFn fn c -- we do not need to free cs 381 | parseState <$> peekCString cs 382 | 383 | -- | Freeze running container. 384 | -- 385 | -- @True@ on success, else @False@. 386 | freeze :: LXC Bool 387 | freeze = boolFn p'lxc_container'freeze 388 | 389 | -- | Thaw a frozen container. 390 | -- 391 | -- @True@ on success, else @False@. 392 | unfreeze :: LXC Bool 393 | unfreeze = boolFn p'lxc_container'unfreeze 394 | 395 | -- | Determine process ID of the containers init process. 396 | initPID :: LXC (Maybe ProcessID) 397 | initPID = lxc $ \c -> do 398 | fn <- mkFn mkProcessIDFn p'lxc_container'init_pid c 399 | pid <- fromIntegral <$> fn 400 | if (pid < 0) 401 | then return Nothing 402 | else return (Just pid) 403 | 404 | -- | Load the specified configuration for the container. 405 | loadConfig :: Maybe FilePath -- ^ Full path to alternate configuration file, or @Nothing@ to use the default configuration file. 406 | -> LXC Bool -- ^ @True@ on success, else @False@. 407 | loadConfig = stringBoolFn p'lxc_container'load_config 408 | 409 | -- | Start the container. 410 | start :: Bool -- ^ Use @lxcinit@ rather than @\/sbin\/init@. 411 | -> [String] -- ^ Array of arguments to pass to init. 412 | -> LXC Bool -- ^ @True@ on success, else @False@. 413 | start useinit argv = lxc $ \c -> do 414 | fn <- mkFn mkStartFn p'lxc_container'start c 415 | case argv of 416 | [] -> toBool <$> fn (fromBool useinit) nullPtr 417 | _ -> do 418 | withMany withCString argv $ \cargv -> 419 | withArray0 nullPtr cargv $ \cargv' -> 420 | toBool <$> fn (fromBool useinit) cargv' 421 | 422 | -- | Stop the container. 423 | -- 424 | -- @True@ on success, else @False@. 425 | stop :: LXC Bool 426 | stop = boolFn p'lxc_container'stop 427 | 428 | -- | Determine if the container wants to run disconnected from the terminal. 429 | wantDaemonize :: Bool -- ^ Value for the daemonize bit. 430 | -> LXC Bool -- ^ @True@ if container wants to be daemonised, else @False@. 431 | wantDaemonize = boolBoolFn p'lxc_container'want_daemonize 432 | 433 | -- | Determine whether container wishes all file descriptors to be closed on startup. 434 | wantCloseAllFDs :: Bool -- ^ Value for the @close_all_fds@ bit. 435 | -> LXC Bool -- ^ @True@ if container wants to be daemonised, else @False@. 436 | wantCloseAllFDs = boolBoolFn p'lxc_container'want_close_all_fds 437 | 438 | -- | Return current config file name. 439 | configFileName :: LXC (Maybe FilePath) 440 | configFileName = lxc $ \c -> do 441 | fn <- peek (p'lxc_container'config_file_name c) 442 | cs <- mkStringFn fn c 443 | s <- maybePeek peekCString cs 444 | when (isJust s) $ free cs 445 | return s 446 | 447 | -- | Wait for container to reach a particular state. 448 | -- 449 | -- * A timeout of @-1@ means wait forever. 450 | -- A timeout @0@ means do not wait. 451 | wait :: ContainerState -- ^ State to wait for. 452 | -> Int -- ^ Timeout in seconds. 453 | -> LXC Bool -- ^ @True@ if state reached within timeout, else @False@. 454 | wait s t = lxc $ \c -> do 455 | fn <- mkFn mkWaitFn p'lxc_container'wait c 456 | withCString (printState s) $ \cs -> 457 | toBool <$> fn cs (fromIntegral t) 458 | 459 | -- | Set a key/value configuration option. 460 | setConfigItem :: String -- ^ Name of option to set. 461 | -> String -- ^ Value to set. 462 | -> LXC Bool -- ^ @True@ on success, else @False@. 463 | setConfigItem = setItemFn' p'lxc_container'set_config_item 464 | 465 | -- | Delete the container. 466 | -- 467 | -- @True@ on success, else @False@. 468 | -- 469 | -- * NOTE: Container must be stopped and have no dependent snapshots. 470 | destroy :: LXC Bool 471 | destroy = boolFn p'lxc_container'destroy 472 | 473 | -- | Save configuaration to a file. 474 | saveConfig :: FilePath -- ^ Full path to file to save configuration in. 475 | -> LXC Bool -- ^ @True@ on success, else @False@. 476 | saveConfig s = stringBoolFn p'lxc_container'save_config (Just s) 477 | 478 | -- | Rename a container. 479 | rename :: String -- ^ New name to be used for the container. 480 | -> LXC Bool -- ^ @True@ on success, else @False@. 481 | rename s = stringBoolFn p'lxc_container'rename (Just s) 482 | 483 | -- | Request the container reboot by sending it @SIGINT@. 484 | -- 485 | -- @True@ if reboot request successful, else @False@. 486 | reboot :: LXC Bool 487 | reboot = boolFn p'lxc_container'reboot 488 | 489 | -- | Request the container shutdown by sending it @SIGPWR@. 490 | shutdown :: Int -- ^ Seconds to wait before returning false. (@-1@ to wait forever, @0@ to avoid waiting). 491 | -> LXC Bool -- ^ @True@ if the container was shutdown successfully, else @False@. 492 | shutdown n = lxc $ \c -> do 493 | fn <- mkFn mkShutdownFn p'lxc_container'shutdown c 494 | toBool <$> fn (fromIntegral n) 495 | 496 | -- | Completely clear the containers in-memory configuration. 497 | clearConfig :: LXC () 498 | clearConfig = lxc $ join . mkFn mkClearConfigFn p'lxc_container'clear_config 499 | 500 | -- | Retrieve the value of a config item. 501 | getConfigItem :: String -- ^ Name of option to get. 502 | -> LXC (Maybe String) -- ^ The item or @Nothing@ on error. 503 | getConfigItem = getItemFn p'lxc_container'get_config_item 504 | 505 | -- | Retrieve the value of a config item from running container. 506 | getRunningConfigItem :: String -- ^ Name of option to get. 507 | -> LXC (Maybe String) -- ^ The item or @Nothing@ on error. 508 | getRunningConfigItem k = lxc $ \c -> do 509 | fn <- mkFn mkGetRunningConfigItemFn p'lxc_container'get_running_config_item c 510 | withCString k $ \ck -> do 511 | cv <- fn ck 512 | v <- maybePeek peekCString cv 513 | when (isJust v) $ free cv 514 | return v 515 | 516 | -- | Retrieve a list of config item keys given a key prefix. 517 | getKeys :: String -- ^ Key prefix. 518 | -> LXC [String] -- ^ List of keys. 519 | getKeys kp = concatMap lines . maybeToList <$> getItemFn p'lxc_container'get_keys kp 520 | 521 | -- | Obtain a list of network interfaces. 522 | getInterfaces :: LXC [String] 523 | getInterfaces = lxc $ \c -> do 524 | cifs <- join $ mkFn mkGetInterfacesFn p'lxc_container'get_interfaces c 525 | if (cifs == nullPtr) 526 | then return [] 527 | else do 528 | cifs' <- peekArray0 nullPtr cifs 529 | ifs <- mapM peekCString cifs' 530 | mapM_ free cifs' 531 | free cifs 532 | return ifs 533 | 534 | -- | Determine the list of container IP addresses. 535 | getIPs :: String -- ^ Network interface name to consider. 536 | -> String -- ^ Network family (for example @"inet"@, @"inet6"@). 537 | -> Word32 -- ^ IPv6 scope id (ignored if family is not "inet6"). 538 | -> LXC [String] -- ^ A list of network interfaces. 539 | getIPs iface fam sid = lxc $ \c -> do 540 | fn <- mkFn mkGetIPsFn p'lxc_container'get_ips c 541 | withCString iface $ \ciface -> 542 | withCString fam $ \cfam -> do 543 | cips <- fn ciface cfam (fromIntegral sid) 544 | if (cips == nullPtr) 545 | then return [] 546 | else do 547 | cips' <- peekArray0 nullPtr cips 548 | ips <- mapM peekCString cips' 549 | mapM_ free cips' 550 | free cips 551 | return ips 552 | 553 | -- | Retrieve the specified cgroup subsystem value for the container. 554 | getCGroupItem :: String -- ^ @cgroup@ subsystem to retrieve. 555 | -> LXC (Maybe String) -- ^ @cgroup@ subsystem value or @Nothing@ on error. 556 | getCGroupItem = getItemFn p'lxc_container'get_cgroup_item 557 | 558 | -- | Set the specified cgroup subsystem value for the container. 559 | setCGroupItem :: String -- ^ @cgroup@ subsystem to consider. 560 | -> String -- ^ Value to set. 561 | -> LXC Bool -- ^ @True@ on success, else @False@. 562 | setCGroupItem = setItemFn' p'lxc_container'set_cgroup_item 563 | 564 | -- | Clear a configuration item. 565 | -- 566 | -- Analog of 'setConfigItem'. 567 | clearConfigItem :: String -- ^ Name of option to clear. 568 | -> LXC Bool -- ^ @True@ on success, else @False@. 569 | clearConfigItem s = stringBoolFn p'lxc_container'clear_config_item (Just s) 570 | 571 | -- | Determine full path to the containers configuration file. 572 | -- 573 | -- Each container can have a custom configuration path. However 574 | -- by default it will be set to either the @LXCPATH@ configure 575 | -- variable, or the lxcpath value in the @LXC_GLOBAL_CONF@ configuration 576 | -- file (i.e. @\/etc\/lxc\/lxc.conf@). 577 | -- 578 | -- The value for a specific container can be changed using 579 | -- 'setConfigPath'. 580 | getConfigPath :: LXC FilePath 581 | getConfigPath = lxc $ \c -> do 582 | cs <- join $ mkFn mkStringFn p'lxc_container'get_config_path c 583 | s <- peekCString cs 584 | free cs 585 | return s 586 | 587 | -- | Set the full path to the containers configuration file. 588 | setConfigPath :: FilePath -- ^ Full path to configuration file. 589 | -> LXC Bool -- ^ @True@ on success, else @False@. 590 | setConfigPath s = stringBoolFn p'lxc_container'set_config_path (Just s) 591 | 592 | -- | Copy a stopped container. 593 | clone :: Maybe String -- ^ New name for the container. If @Nothing@, the same name is used and a new lxcpath MUST be specified. 594 | -> Maybe FilePath -- ^ lxcpath in which to create the new container. If @Nothing@, the original container's lxcpath will be used. 595 | -> [CloneOption] -- ^ Additional 'CloneOption' flags to change the cloning behaviour. 596 | -> Maybe String -- ^ Optionally force the cloned bdevtype to a specified plugin. By default the original is used (subject to snapshot requirements). 597 | -> Maybe String -- ^ Information about how to create the new storage (i.e. fstype and fsdata). 598 | -> 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. 599 | -> [String] -- ^ Additional arguments to pass to the clone hook script. 600 | -> LXC (Maybe Container) -- ^ Newly-allocated copy of container @c@, or @Nothing@ on error. 601 | clone newname lxcpath flags bdevtype bdevdata newsize hookargs = do 602 | oldname <- asks fst 603 | lxc $ \c -> do 604 | c' <- maybeWith withCString newname $ \cnewname -> 605 | maybeWith withCString lxcpath $ \clxcpath -> 606 | maybeWith withCString bdevtype $ \cbdevtype -> 607 | maybeWith withCString bdevdata $ \cbdevdata -> 608 | withMany withCString hookargs $ \chookargs -> 609 | withArray0 nullPtr chookargs $ \chookargs' -> do 610 | fn <- mkFn mkCloneFn p'lxc_container'clone c 611 | fn 612 | cnewname 613 | clxcpath 614 | (mkFlags cloneFlag flags) 615 | cbdevtype 616 | cbdevdata 617 | (fromMaybe 0 newsize) 618 | chookargs' 619 | c'' <- maybePeek peekC'lxc_container c' 620 | when (isJust c'') $ do 621 | _ <- dropRef c' 622 | return () 623 | return $ c'' <*> pure (fromMaybe oldname newname) 624 | 625 | -- | Allocate a console tty for the container. 626 | -- 627 | -- * The returned file descriptor is used to keep the tty 628 | -- allocated. The caller should call close(2) on the returned file 629 | -- descriptor when no longer required so that it may be allocated 630 | -- by another caller. 631 | consoleGetFD :: Maybe Int -- ^ Terminal number to attempt to allocate, or @Nothing@ to allocate the first available tty. 632 | -> 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. 633 | consoleGetFD ttynum = lxc $ \c -> do 634 | fn <- mkFn mkConsoleGetFDFn p'lxc_container'console_getfd c 635 | alloca $ \cttynum -> 636 | alloca $ \cmasterfd -> do 637 | poke cttynum (fromIntegral $ fromMaybe (-1) ttynum) 638 | fd <- fromIntegral <$> fn cttynum cmasterfd 639 | ttynum' <- fromIntegral <$> peek cttynum 640 | masterfd <- fromIntegral <$> peek cmasterfd 641 | if (fd < 0) 642 | then return Nothing 643 | else return $ Just (fd, ttynum', masterfd) 644 | 645 | -- | Allocate and run a console tty. 646 | console :: Maybe Int -- ^ Terminal number to attempt to allocate, @Nothing@ to allocate the first available tty or @Just 0@ to allocate the console. 647 | -> Fd -- ^ File descriptor to read input from. 648 | -> Fd -- ^ File descriptor to write output to. 649 | -> Fd -- ^ File descriptor to write error output to. 650 | -> Int -- ^ The escape character (@1 == \'a\'@, @2 == \'b\'@, ...). 651 | -> LXC Bool -- ^ @True@ on success, else @False@. 652 | console ttynum stdin stdout stderr escape = lxc $ \c -> do 653 | fn <- mkFn mkConsoleFn p'lxc_container'console c 654 | toBool <$> fn (fromIntegral $ fromMaybe (-1) ttynum) 655 | (fromIntegral stdin) 656 | (fromIntegral stdout) 657 | (fromIntegral stderr) 658 | (fromIntegral escape) 659 | 660 | -- | Create a sub-process attached to a container and run a function inside it. 661 | attach :: AttachExecFn -- ^ Function to run. 662 | -> AttachCommand -- ^ Data to pass to @exec@ function. 663 | -> AttachOptions -- ^ Attach options. 664 | -> LXC (Maybe ProcessID) -- ^ Process ID of process running inside container @c@ that is running @exec@ function, or @Nothing@ on error. 665 | attach exec cmd opts = lxc $ \c -> do 666 | fn <- mkFn mkAttachFn p'lxc_container'attach c 667 | withC'lxc_attach_command_t cmd $ \ccmd -> 668 | withC'lxc_attach_options_t opts $ \copts -> 669 | alloca $ \cpid -> do 670 | ret <- fn (getAttachExecFn exec) (castPtr ccmd) copts cpid 671 | if (ret < 0) 672 | then return Nothing 673 | else Just . fromIntegral <$> peek cpid 674 | 675 | -- | Run a program inside a container and wait for it to exit. 676 | attachRunWait :: AttachOptions -- ^ Attach options. 677 | -> String -- ^ Full path inside container of program to run. 678 | -> [String] -- ^ Array of arguments to pass to program. 679 | -> LXC (Maybe ExitCode) -- ^ @waitpid(2)@ status of exited process that ran program, or @Nothing@ on error. 680 | attachRunWait opts prg argv = lxc $ \c -> do 681 | fn <- mkFn mkAttachRunWaitFn p'lxc_container'attach_run_wait c 682 | withCString prg $ \cprg -> 683 | withMany withCString argv $ \cargv -> 684 | withArray0 nullPtr cargv $ \cargv' -> 685 | withC'lxc_attach_options_t opts $ \copts -> do 686 | ret <- fromIntegral <$> fn copts cprg cargv' 687 | case ret of 688 | _ | ret < 0 -> return Nothing 689 | 0 -> return $ Just ExitSuccess 690 | _ -> return $ Just (ExitFailure ret) 691 | 692 | -- | Create a container snapshot. 693 | -- 694 | -- Assuming default paths, snapshots will be created as 695 | -- @\/var\/lib\/lxc\/\\/snaps\/snap\@ 696 | -- where @\@ represents the container name and @\@ 697 | -- represents the zero-based snapshot number. 698 | snapshot :: Maybe FilePath -- ^ Full path to file containing a description of the snapshot. 699 | -> LXC (Maybe Int) -- ^ @Nothing@ on error, or zero-based snapshot number. 700 | snapshot path = lxc $ \c -> do 701 | fn <- mkFn mkSnapshotFn p'lxc_container'snapshot c 702 | maybeWith withCString path $ \cpath -> do 703 | n <- fn cpath 704 | if (n == -1) 705 | then return Nothing 706 | else return (Just $ fromIntegral n) 707 | 708 | peekC'lxc_snapshot :: Ptr C'lxc_snapshot -> IO Snapshot 709 | peekC'lxc_snapshot ptr = Snapshot 710 | <$> peekField peekCString p'lxc_snapshot'name 711 | <*> peekField (maybePeek peekCString) p'lxc_snapshot'comment_pathname 712 | <*> peekField peekCString p'lxc_snapshot'timestamp 713 | <*> peekField peekCString p'lxc_snapshot'lxcpath 714 | where 715 | peekField g f = peek (f ptr) >>= g 716 | 717 | -- | Obtain a list of container snapshots. 718 | snapshotList :: LXC [Snapshot] 719 | snapshotList = lxc $ \c -> do 720 | alloca $ \css -> do 721 | fn <- mkFn mkSnapshotListFn p'lxc_container'snapshot_list c 722 | n <- fromIntegral <$> fn css 723 | if (n <= 0) 724 | then return [] 725 | else do 726 | css1 <- peek css 727 | let css2 = take n $ iterate (flip advancePtr 1) css1 728 | css3 <- mapM peekC'lxc_snapshot css2 729 | forM_ css2 $ join . mkFn mkFreeFn p'lxc_snapshot'free 730 | free css1 731 | return css3 732 | 733 | -- | Create a new container based on a snapshot. 734 | -- 735 | -- The restored container will be a copy (not snapshot) of the snapshot, 736 | -- and restored in the lxcpath of the original container. 737 | -- 738 | -- * /WARNING:/ If new name is the same as the current container 739 | -- name, the container will be destroyed. However, this will 740 | -- fail if the snapshot is overlay-based, since the snapshots 741 | -- will pin the original container. 742 | -- * /NOTE:/ As an example, if the container exists as @\/var\/lib\/lxc\/c1@, snapname might be @"snap0"@ 743 | -- (representing @\/var\/lib\/lxc\/c1\/snaps\/snap0@). If new name is @c2@, 744 | -- then @snap0@ will be copied to @\/var\/lib\/lxc\/c2@. 745 | snapshotRestore :: String -- ^ Name of snapshot. 746 | -> String -- ^ Name to be used for the restored snapshot. 747 | -> LXC Bool -- ^ @True@ on success, else @False@. 748 | snapshotRestore = setItemFn' p'lxc_container'snapshot_restore 749 | 750 | -- | Destroy the specified snapshot. 751 | snapshotDestroy :: String -- ^ Name of snapshot. 752 | -> LXC Bool -- ^ @True@ on success, else @False@. 753 | snapshotDestroy n = stringBoolFn p'lxc_container'snapshot_destroy (Just n) 754 | 755 | -- | Determine if the caller may control the container. 756 | -- 757 | -- @False@ if there is a control socket for the container monitor 758 | -- and the caller may not access it, otherwise returns @True@. 759 | mayControl :: LXC Bool 760 | mayControl = boolFn p'lxc_container'may_control 761 | 762 | -- | Add specified device to the container. 763 | addDeviceNode :: FilePath -- ^ Full path of the device. 764 | -> Maybe FilePath -- ^ Alternate path in the container (or @Nothing@ to use source path). 765 | -> LXC Bool -- ^ @True@ on success, else @False@. 766 | addDeviceNode = setItemFn p'lxc_container'add_device_node 767 | 768 | -- | Remove specified device from the container. 769 | removeDeviceNode :: FilePath -- ^ Full path of the device. 770 | -> Maybe FilePath -- ^ Alternate path in the container (or @Nothing@ to use source path). 771 | -> LXC Bool -- ^ @True@ on success, else @False@. 772 | removeDeviceNode = setItemFn p'lxc_container'remove_device_node 773 | 774 | -- | Create a container. 775 | create :: String -- ^ Template to execute to instantiate the root filesystem and adjust the configuration. 776 | -> Maybe String -- ^ Backing store type to use (if @Nothing@, @dir@ type will be used by default). 777 | -> Maybe BDevSpecs -- ^ Additional parameters for the backing store (for example LVM volume group to use). 778 | -> [CreateOption] -- ^ 'CreateOption' flags. /Note: LXC 1.0 supports only @CreateQuiet@ option./ 779 | -> [String] -- ^ Arguments to pass to the template. 780 | -> LXC Bool -- ^ @True@ on success. @False@ otherwise. 781 | create t bdevtype bdevspecs flags argv = lxc $ \c -> toBool <$> do 782 | withMany withCString argv $ \cargv -> 783 | withArray0 nullPtr cargv $ \cargv' -> 784 | withCString t $ \ct -> 785 | maybeWith withCString bdevtype $ \cbdevtype -> 786 | maybeWith withC'bdev_specs bdevspecs $ \_cbdevspecs -> do 787 | fn <- peek $ p'lxc_container'create $ c 788 | mkCreateFn fn 789 | (c) 790 | ct 791 | cbdevtype 792 | nullPtr 793 | (mkFlags createFlag flags) 794 | cargv' 795 | 796 | -- | Add a reference to the specified container. 797 | getRef :: Ptr C'lxc_container -> IO Bool 798 | getRef c = toBool <$> c'lxc_container_get c 799 | 800 | -- | Drop a reference to the specified container. 801 | -- 802 | -- @Just False@ on success, @Just True@ if reference was successfully dropped 803 | -- and container has been freed, and @Nothing@ on error. 804 | dropRef :: Ptr C'lxc_container -> IO (Maybe Bool) 805 | dropRef c = do 806 | n <- c'lxc_container_put c 807 | return $ case n of 808 | 0 -> Just False 809 | 1 -> Just True 810 | _ -> Nothing 811 | 812 | -- | Obtain a list of all container states. 813 | getWaitStates :: IO [ContainerState] 814 | getWaitStates = do 815 | sz <- fromIntegral <$> c'lxc_get_wait_states nullPtr 816 | allocaArray sz $ \cstates -> do 817 | _ <- c'lxc_get_wait_states cstates 818 | cstates' <- peekArray sz cstates 819 | map parseState <$> mapM peekCString cstates' 820 | -- we do not need to free the strings themselves 821 | 822 | -- | Get the value for a global config key. 823 | getGlobalConfigItem :: String -- ^ The name of the config key. 824 | -> IO (Maybe String) -- ^ String representing the current value for the key. @Nothing@ on error. 825 | getGlobalConfigItem k = do 826 | withCString k $ \ck -> do 827 | cv <- c'lxc_get_global_config_item ck 828 | maybePeek peekCString cv 829 | 830 | -- | Determine version of LXC. 831 | getVersion :: IO String 832 | getVersion = c'lxc_get_version >>= peekCString 833 | 834 | listContainersFn :: (CString -> Ptr (Ptr CString) -> Ptr (Ptr (Ptr C'lxc_container)) -> IO CInt) 835 | -> Maybe String 836 | -> IO [Container] 837 | listContainersFn f lxcpath = do 838 | maybeWith withCString lxcpath $ \clxcpath -> 839 | alloca $ \cnames -> 840 | alloca $ \ccontainers -> do 841 | n <- fromIntegral <$> f clxcpath cnames ccontainers 842 | if (n <= 0) 843 | then return [] 844 | else do 845 | cnames' <- peek cnames 846 | cnames'' <- peekArray n cnames' 847 | names <- mapM peekCString cnames'' 848 | mapM_ free cnames'' 849 | free cnames' 850 | 851 | ccontainers' <- peek ccontainers 852 | ccontainers'' <- peekArray n ccontainers' 853 | containers <- mapM peekC'lxc_container ccontainers'' 854 | mapM_ free ccontainers'' 855 | free ccontainers' 856 | 857 | return $ zipWith ($) containers names 858 | 859 | 860 | -- | Get a list of defined containers in a lxcpath. 861 | listDefinedContainers :: Maybe String -- ^ lxcpath under which to look. 862 | -> IO [Container] -- ^ List of pairs. 863 | listDefinedContainers = listContainersFn c'list_defined_containers 864 | 865 | -- | Get a list of active containers for a given lxcpath. 866 | listActiveContainers :: Maybe String -- ^ Full @LXCPATH@ path to consider. 867 | -> IO [Container] -- ^ List of pairs. 868 | listActiveContainers = listContainersFn c'list_active_containers 869 | 870 | -- | Get a complete list of all containers for a given lxcpath. 871 | listAllContainers :: Maybe String -- ^ Full @LXCPATH@ path to consider. 872 | -> IO [Container] -- ^ List of pairs. 873 | listAllContainers = listContainersFn c'list_all_containers 874 | 875 | -- | Close log file. 876 | logClose :: IO () 877 | logClose = c'lxc_log_close 878 | 879 | -------------------------------------------------------------------------------- /src/System/LXC/Internal/Utils.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : System.LXC.Internal.Utils 4 | -- Copyright : (c) Nickolay Kudasov 2014 5 | -- License : BSD-style (see the file LICENSE) 6 | -- 7 | -- Maintainer : nickolay.kudasov@gmail.com 8 | -- 9 | -- Internal module with utility functions. 10 | -- Normally you should import @System.LXC@ module only. 11 | -- 12 | ----------------------------------------------------------------------------- 13 | module System.LXC.Internal.Utils where 14 | 15 | import Data.Bits 16 | import Data.List 17 | 18 | -- | Collect flags in a single integer value. 19 | mkFlags :: (Num b, Bits b) => (a -> b) -> [a] -> b 20 | mkFlags f = foldl' (.|.) 0 . map f 21 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-4.2 2 | packages: 3 | - '.' 4 | extra-deps: 5 | - bindings-lxc-0.2.1 6 | flags: {} 7 | --------------------------------------------------------------------------------