{-# OPTIONS_GHC -optc-D_GNU_SOURCE #-}
{-# LINE 1 "System/Linux/Namespaces.hsc" #-}
{- |
Module      : System.Linux.Namespaces

Stability   : provisional
Portability : non-portable (requires Linux)

This module provides bindings to the @unshare(2)@ and @setns(2)@ linux
system calls. The former can be used to create new namespaces and move
the calling process to them, whereas the latter can be used to move the
calling process to an already existing namespace created by some other
process.

Note that linux provides another function related to namespaces which is
not supported by this module: @clone(2)@. This function works like
@fork(2)@ and is used to create new namespaces (like @unshare(2)@).
Unfortunately, like @fork(2)@, it does not interact well with GHC'c RTS
which is why it has been omitted from this module.

/Note/: Using this module in a program that uses the threaded RTS does
not make much sense. Namespaces are per process/thread and manipulating
them in one thread will not affect the namespaces of the other threads
of the same process. The threaded RTS makes it is hard to predict what
OS thread will be used to run the haskell threads. Therefore, using this
module in such applications will result in unpredictable behavior.
Similarly, using this module in @ghci@ is problematic too.
-}

{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module System.Linux.Namespaces
    (
    -- * Main types and functions
      Namespace(..)
    , unshare
    , setNamespace

    -- * Utility functions
    , enterNamespace
    , NamespaceID
    , getNamespaceID

    -- * User/Group mappings
    , UserMapping(..)
    , GroupMapping(..)
    , writeUserMappings
    , writeGroupMappings

    -- * Setting offsets for virtualized clocks
    , Clock(..)
    , setClockOffset

    -- * Example
    -- $example
    ) where




import Foreign
import Foreign.C
import System.Posix.Types (Fd(..), ProcessID, UserID, GroupID, EpochTime)
import System.Posix.IO
import System.Posix.Files (readSymbolicLink)
import Control.Exception (bracket)
import Data.List (foldl')
import Data.Char (isDigit)
import Control.Arrow (first)
import Control.Monad (when)
import qualified Data.ByteString.Char8 as C
import qualified Data.ByteString       as S
import Data.ByteString (ByteString)
import System.IO.Error (modifyIOError, ioeSetLocation)

--------------------------------------------------------------------------------

-- | Types of namespaces.
data Namespace = IPC | Network | Mount | PID | User | UTS | CGroup | Time
  deriving (Int -> Namespace -> ShowS
[Namespace] -> ShowS
Namespace -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Namespace] -> ShowS
$cshowList :: [Namespace] -> ShowS
show :: Namespace -> String
$cshow :: Namespace -> String
showsPrec :: Int -> Namespace -> ShowS
$cshowsPrec :: Int -> Namespace -> ShowS
Show, ReadPrec [Namespace]
ReadPrec Namespace
Int -> ReadS Namespace
ReadS [Namespace]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Namespace]
$creadListPrec :: ReadPrec [Namespace]
readPrec :: ReadPrec Namespace
$creadPrec :: ReadPrec Namespace
readList :: ReadS [Namespace]
$creadList :: ReadS [Namespace]
readsPrec :: Int -> ReadS Namespace
$creadsPrec :: Int -> ReadS Namespace
Read, Namespace -> Namespace -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Namespace -> Namespace -> Bool
$c/= :: Namespace -> Namespace -> Bool
== :: Namespace -> Namespace -> Bool
$c== :: Namespace -> Namespace -> Bool
Eq, Namespace
forall a. a -> a -> Bounded a
maxBound :: Namespace
$cmaxBound :: Namespace
minBound :: Namespace
$cminBound :: Namespace
Bounded, Int -> Namespace
Namespace -> Int
Namespace -> [Namespace]
Namespace -> Namespace
Namespace -> Namespace -> [Namespace]
Namespace -> Namespace -> Namespace -> [Namespace]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Namespace -> Namespace -> Namespace -> [Namespace]
$cenumFromThenTo :: Namespace -> Namespace -> Namespace -> [Namespace]
enumFromTo :: Namespace -> Namespace -> [Namespace]
$cenumFromTo :: Namespace -> Namespace -> [Namespace]
enumFromThen :: Namespace -> Namespace -> [Namespace]
$cenumFromThen :: Namespace -> Namespace -> [Namespace]
enumFrom :: Namespace -> [Namespace]
$cenumFrom :: Namespace -> [Namespace]
fromEnum :: Namespace -> Int
$cfromEnum :: Namespace -> Int
toEnum :: Int -> Namespace
$ctoEnum :: Int -> Namespace
pred :: Namespace -> Namespace
$cpred :: Namespace -> Namespace
succ :: Namespace -> Namespace
$csucc :: Namespace -> Namespace
Enum)

toCloneFlags :: Namespace -> CInt
toCloneFlags :: Namespace -> CInt
toCloneFlags Namespace
ns =
    case Namespace
ns of
        Namespace
IPC     -> (CInt
134217728)
{-# LINE 84 "System/Linux/Namespaces.hsc" #-}
        Namespace
Network -> (CInt
1073741824)
{-# LINE 85 "System/Linux/Namespaces.hsc" #-}
        Namespace
Mount   -> (CInt
131072)
{-# LINE 86 "System/Linux/Namespaces.hsc" #-}
        Namespace
PID     -> (CInt
536870912)
{-# LINE 87 "System/Linux/Namespaces.hsc" #-}
        Namespace
User    -> (CInt
268435456)
{-# LINE 88 "System/Linux/Namespaces.hsc" #-}
        Namespace
UTS     -> (CInt
67108864)
{-# LINE 89 "System/Linux/Namespaces.hsc" #-}
        Namespace
CGroup  -> (CInt
33554432)
{-# LINE 90 "System/Linux/Namespaces.hsc" #-}
        Namespace
Time    -> (CInt
128)
{-# LINE 91 "System/Linux/Namespaces.hsc" #-}

toProcName :: Namespace -> String
toProcName :: Namespace -> String
toProcName Namespace
ns =
    case Namespace
ns of
        Namespace
IPC     -> String
"ipc"
        Namespace
Network -> String
"net"
        Namespace
Mount   -> String
"mnt"
        Namespace
PID     -> String
"pid"
        Namespace
User    -> String
"user"
        Namespace
UTS     -> String
"uts"
        Namespace
CGroup  -> String
"cgroup"
        Namespace
Time    -> String
"time"

-- | Detach the process from one or more namespaces and move it to new
-- ones. See the man page of @unshare(2)@ for more details.
unshare :: [Namespace] -> IO ()
unshare :: [Namespace] -> IO ()
unshare [Namespace]
nss =
    forall a. (Eq a, Num a) => String -> IO a -> IO ()
throwErrnoIfMinus1_ String
"unshare" forall a b. (a -> b) -> a -> b
$ CInt -> IO CInt
c_unshare CInt
flags
  where
    flags :: CInt
flags = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall a. Bits a => a -> a -> a
(.|.) CInt
0 (forall a b. (a -> b) -> [a] -> [b]
map Namespace -> CInt
toCloneFlags [Namespace]
nss)

-- | Move the process to an already existing namespace. See the man page
-- of @setns(2)@ for more details. See also 'enterNamespace' for a
-- slightly higher level version of this function.
setNamespace
    :: Fd -- ^ A file descriptor referring to a namespace file in a
          -- @\/proc\/[pid]\/ns\/@ directory.
    -> Maybe Namespace -- ^ Specify the namespace type that the file
                       -- descriptor must refer to. If the two types do not
                       -- match, the function will fail. Use 'Nothing' to
                       -- allow any type.
    -> IO ()
setNamespace :: Fd -> Maybe Namespace -> IO ()
setNamespace Fd
fd Maybe Namespace
mns =
    forall a. (Eq a, Num a) => String -> IO a -> IO ()
throwErrnoIfMinus1_ String
"setNamespace" forall a b. (a -> b) -> a -> b
$ Fd -> CInt -> IO CInt
c_setns Fd
fd CInt
nstype
  where
    nstype :: CInt
nstype = forall b a. b -> (a -> b) -> Maybe a -> b
maybe CInt
0 Namespace -> CInt
toCloneFlags Maybe Namespace
mns

--------------------------------------------------------------------------------

-- | Move the process to an already existing namespace. This is a wrapper
-- around 'setNamespace'. This function requires @\/proc@ to be mounted.
enterNamespace
    :: ProcessID -- ^ The @pid@ of any process in the target namespace.
    -> Namespace -- ^ The type of the namespace.
    -> IO ()
enterNamespace :: ProcessID -> Namespace -> IO ()
enterNamespace ProcessID
pid Namespace
ns =
    forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO Fd
openFd' Fd -> IO ()
closeFd forall a b. (a -> b) -> a -> b
$ \Fd
fd ->
        Fd -> Maybe Namespace -> IO ()
setNamespace Fd
fd (forall a. a -> Maybe a
Just Namespace
ns)
  where
    openFd' :: IO Fd
openFd' = forall r. String -> IO r -> IO r
ioeSetLoc String
"enterNamespace" forall a b. (a -> b) -> a -> b
$

{-# LINE 144 "System/Linux/Namespaces.hsc" #-}
        String -> OpenMode -> Maybe FileMode -> OpenFileFlags -> IO Fd
openFd String
path OpenMode
ReadOnly forall a. Maybe a
Nothing OpenFileFlags
defaultFileFlags {nonBlock :: Bool
nonBlock = Bool
True}

{-# LINE 146 "System/Linux/Namespaces.hsc" #-}
    path = toProcPath (Just pid) ns

-- | A unique namespace id.
newtype NamespaceID = NamespaceID CInt
  deriving (NamespaceID -> NamespaceID -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NamespaceID -> NamespaceID -> Bool
$c/= :: NamespaceID -> NamespaceID -> Bool
== :: NamespaceID -> NamespaceID -> Bool
$c== :: NamespaceID -> NamespaceID -> Bool
Eq, Eq NamespaceID
NamespaceID -> NamespaceID -> Bool
NamespaceID -> NamespaceID -> Ordering
NamespaceID -> NamespaceID -> NamespaceID
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: NamespaceID -> NamespaceID -> NamespaceID
$cmin :: NamespaceID -> NamespaceID -> NamespaceID
max :: NamespaceID -> NamespaceID -> NamespaceID
$cmax :: NamespaceID -> NamespaceID -> NamespaceID
>= :: NamespaceID -> NamespaceID -> Bool
$c>= :: NamespaceID -> NamespaceID -> Bool
> :: NamespaceID -> NamespaceID -> Bool
$c> :: NamespaceID -> NamespaceID -> Bool
<= :: NamespaceID -> NamespaceID -> Bool
$c<= :: NamespaceID -> NamespaceID -> Bool
< :: NamespaceID -> NamespaceID -> Bool
$c< :: NamespaceID -> NamespaceID -> Bool
compare :: NamespaceID -> NamespaceID -> Ordering
$ccompare :: NamespaceID -> NamespaceID -> Ordering
Ord, Int -> NamespaceID
NamespaceID -> Int
NamespaceID -> [NamespaceID]
NamespaceID -> NamespaceID
NamespaceID -> NamespaceID -> [NamespaceID]
NamespaceID -> NamespaceID -> NamespaceID -> [NamespaceID]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: NamespaceID -> NamespaceID -> NamespaceID -> [NamespaceID]
$cenumFromThenTo :: NamespaceID -> NamespaceID -> NamespaceID -> [NamespaceID]
enumFromTo :: NamespaceID -> NamespaceID -> [NamespaceID]
$cenumFromTo :: NamespaceID -> NamespaceID -> [NamespaceID]
enumFromThen :: NamespaceID -> NamespaceID -> [NamespaceID]
$cenumFromThen :: NamespaceID -> NamespaceID -> [NamespaceID]
enumFrom :: NamespaceID -> [NamespaceID]
$cenumFrom :: NamespaceID -> [NamespaceID]
fromEnum :: NamespaceID -> Int
$cfromEnum :: NamespaceID -> Int
toEnum :: Int -> NamespaceID
$ctoEnum :: Int -> NamespaceID
pred :: NamespaceID -> NamespaceID
$cpred :: NamespaceID -> NamespaceID
succ :: NamespaceID -> NamespaceID
$csucc :: NamespaceID -> NamespaceID
Enum, Enum NamespaceID
Real NamespaceID
NamespaceID -> Integer
NamespaceID -> NamespaceID -> (NamespaceID, NamespaceID)
NamespaceID -> NamespaceID -> NamespaceID
forall a.
Real a
-> Enum a
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> (a, a))
-> (a -> a -> (a, a))
-> (a -> Integer)
-> Integral a
toInteger :: NamespaceID -> Integer
$ctoInteger :: NamespaceID -> Integer
divMod :: NamespaceID -> NamespaceID -> (NamespaceID, NamespaceID)
$cdivMod :: NamespaceID -> NamespaceID -> (NamespaceID, NamespaceID)
quotRem :: NamespaceID -> NamespaceID -> (NamespaceID, NamespaceID)
$cquotRem :: NamespaceID -> NamespaceID -> (NamespaceID, NamespaceID)
mod :: NamespaceID -> NamespaceID -> NamespaceID
$cmod :: NamespaceID -> NamespaceID -> NamespaceID
div :: NamespaceID -> NamespaceID -> NamespaceID
$cdiv :: NamespaceID -> NamespaceID -> NamespaceID
rem :: NamespaceID -> NamespaceID -> NamespaceID
$crem :: NamespaceID -> NamespaceID -> NamespaceID
quot :: NamespaceID -> NamespaceID -> NamespaceID
$cquot :: NamespaceID -> NamespaceID -> NamespaceID
Integral, Integer -> NamespaceID
NamespaceID -> NamespaceID
NamespaceID -> NamespaceID -> NamespaceID
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> NamespaceID
$cfromInteger :: Integer -> NamespaceID
signum :: NamespaceID -> NamespaceID
$csignum :: NamespaceID -> NamespaceID
abs :: NamespaceID -> NamespaceID
$cabs :: NamespaceID -> NamespaceID
negate :: NamespaceID -> NamespaceID
$cnegate :: NamespaceID -> NamespaceID
* :: NamespaceID -> NamespaceID -> NamespaceID
$c* :: NamespaceID -> NamespaceID -> NamespaceID
- :: NamespaceID -> NamespaceID -> NamespaceID
$c- :: NamespaceID -> NamespaceID -> NamespaceID
+ :: NamespaceID -> NamespaceID -> NamespaceID
$c+ :: NamespaceID -> NamespaceID -> NamespaceID
Num, Num NamespaceID
Ord NamespaceID
NamespaceID -> Rational
forall a. Num a -> Ord a -> (a -> Rational) -> Real a
toRational :: NamespaceID -> Rational
$ctoRational :: NamespaceID -> Rational
Real)

instance Show NamespaceID where
    show :: NamespaceID -> String
show (NamespaceID CInt
x) = forall a. Show a => a -> String
show CInt
x

instance Read NamespaceID where
    readsPrec :: Int -> ReadS NamespaceID
readsPrec Int
prec String
s = forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first CInt -> NamespaceID
NamespaceID) forall a b. (a -> b) -> a -> b
$ forall a. Read a => Int -> ReadS a
readsPrec Int
prec String
s

-- | Retrieve the id of a Namespace. Useful for debugging. This
-- function requires @\/proc@ to be mounted.
getNamespaceID
    :: Maybe ProcessID -- ^ The @pid@ of any process in the target
                       -- namespace. Use 'Nothing' for the namespace
                       -- of the calling process.
    -> Namespace       -- ^ The type of the namespace.
    -> IO NamespaceID
getNamespaceID :: Maybe ProcessID -> Namespace -> IO NamespaceID
getNamespaceID Maybe ProcessID
mpid Namespace
ns = do
    String
s <- forall r. String -> IO r -> IO r
ioeSetLoc String
"getNamespaceID" forall a b. (a -> b) -> a -> b
$ String -> IO String
readSymbolicLink String
path
    let s' :: String
s' = forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
isDigit forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isDigit) String
s
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Read a => String -> a
read String
s')
  where
    path :: String
path = Maybe ProcessID -> Namespace -> String
toProcPath Maybe ProcessID
mpid Namespace
ns

--------------------------------------------------------------------------------

-- | A single user mapping, used with user namespaces. See
-- @user_namespaces(7)@ for more details.
data UserMapping = UserMapping UserID UserID Int
  deriving (Int -> UserMapping -> ShowS
[UserMapping] -> ShowS
UserMapping -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UserMapping] -> ShowS
$cshowList :: [UserMapping] -> ShowS
show :: UserMapping -> String
$cshow :: UserMapping -> String
showsPrec :: Int -> UserMapping -> ShowS
$cshowsPrec :: Int -> UserMapping -> ShowS
Show, ReadPrec [UserMapping]
ReadPrec UserMapping
Int -> ReadS UserMapping
ReadS [UserMapping]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [UserMapping]
$creadListPrec :: ReadPrec [UserMapping]
readPrec :: ReadPrec UserMapping
$creadPrec :: ReadPrec UserMapping
readList :: ReadS [UserMapping]
$creadList :: ReadS [UserMapping]
readsPrec :: Int -> ReadS UserMapping
$creadsPrec :: Int -> ReadS UserMapping
Read, UserMapping -> UserMapping -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UserMapping -> UserMapping -> Bool
$c/= :: UserMapping -> UserMapping -> Bool
== :: UserMapping -> UserMapping -> Bool
$c== :: UserMapping -> UserMapping -> Bool
Eq)

-- | A single group mapping, used with user namespaces. See
-- @user_namespaces(7)@ for more details.
data GroupMapping = GroupMapping GroupID GroupID Int
  deriving (Int -> GroupMapping -> ShowS
[GroupMapping] -> ShowS
GroupMapping -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GroupMapping] -> ShowS
$cshowList :: [GroupMapping] -> ShowS
show :: GroupMapping -> String
$cshow :: GroupMapping -> String
showsPrec :: Int -> GroupMapping -> ShowS
$cshowsPrec :: Int -> GroupMapping -> ShowS
Show, ReadPrec [GroupMapping]
ReadPrec GroupMapping
Int -> ReadS GroupMapping
ReadS [GroupMapping]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [GroupMapping]
$creadListPrec :: ReadPrec [GroupMapping]
readPrec :: ReadPrec GroupMapping
$creadPrec :: ReadPrec GroupMapping
readList :: ReadS [GroupMapping]
$creadList :: ReadS [GroupMapping]
readsPrec :: Int -> ReadS GroupMapping
$creadsPrec :: Int -> ReadS GroupMapping
Read, GroupMapping -> GroupMapping -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GroupMapping -> GroupMapping -> Bool
$c/= :: GroupMapping -> GroupMapping -> Bool
== :: GroupMapping -> GroupMapping -> Bool
$c== :: GroupMapping -> GroupMapping -> Bool
Eq)

-- | Define the user mappings for the specified user namespace. This
-- function requires @\/proc@ to be mounted. See @user_namespaces(7)@
-- for more details.
writeUserMappings
    :: Maybe ProcessID -- ^ The @pid@ of any process in the target user
                       -- namespace. Use 'Nothing' for the namespace
                       -- of the calling process.
    -> [UserMapping]   -- ^ The mappings.
    -> IO ()
writeUserMappings :: Maybe ProcessID -> [UserMapping] -> IO ()
writeUserMappings Maybe ProcessID
mpid [UserMapping]
ms =
    forall r. String -> IO r -> IO r
ioeSetLoc String
"writeUserMappings" forall a b. (a -> b) -> a -> b
$
        String -> ByteString -> IO ()
writeProcFile String
path (String -> ByteString
C.pack String
s)
  where
    path :: String
path = Maybe ProcessID -> String
toProcDir Maybe ProcessID
mpid forall a. [a] -> [a] -> [a]
++ String
"/uid_map"
    s :: String
s = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap UserMapping -> String
toStr [UserMapping]
ms
    toStr :: UserMapping -> String
toStr (UserMapping UserID
o UserID
i Int
l) = forall a. Show a => a -> String
show UserID
o forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show UserID
i forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
l forall a. [a] -> [a] -> [a]
++ String
"\n"

-- | Define the group mappings for the specified user namespace. This
-- function requires @\/proc@ to be mounted. See @user_namespaces(7)@
-- for more details.
writeGroupMappings
    :: Maybe ProcessID -- ^ The @pid@ of any process in the target user
                       -- namespace. Use 'Nothing' for the namespace
                       -- of the calling process.
    -> [GroupMapping]  -- ^ The mappings.
    -> Bool            -- ^ Prevent processes in the child user namespace
                       -- from calling @setgroups@. This is needed if the
                       -- calling process does not have the @CAP_SETGID@
                       -- capability in the parent namespace.
    -> IO ()
writeGroupMappings :: Maybe ProcessID -> [GroupMapping] -> Bool -> IO ()
writeGroupMappings Maybe ProcessID
mpid [GroupMapping]
ms Bool
denySetgroups =
    forall r. String -> IO r -> IO r
ioeSetLoc String
"writeGroupMappings" forall a b. (a -> b) -> a -> b
$ do
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
denySetgroups forall a b. (a -> b) -> a -> b
$
            String -> ByteString -> IO ()
writeProcFile (String
dir forall a. [a] -> [a] -> [a]
++ String
"/setgroups") (String -> ByteString
C.pack String
"deny")
        String -> ByteString -> IO ()
writeProcFile (String
dir forall a. [a] -> [a] -> [a]
++ String
"/gid_map") (String -> ByteString
C.pack String
s)
  where
    dir :: String
dir = Maybe ProcessID -> String
toProcDir Maybe ProcessID
mpid
    s :: String
s = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap GroupMapping -> String
toStr [GroupMapping]
ms
    toStr :: GroupMapping -> String
toStr (GroupMapping GroupID
o GroupID
i Int
l) =
        forall a. Show a => a -> String
show GroupID
o forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show GroupID
i forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
l forall a. [a] -> [a] -> [a]
++ String
"\n"

--------------------------------------------------------------------------------

-- | The virtualized clock whose offset is set
-- @time_namespaces(7)@ for more details.
data Clock = Monotonic | Boottime
  deriving (Int -> Clock -> ShowS
[Clock] -> ShowS
Clock -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Clock] -> ShowS
$cshowList :: [Clock] -> ShowS
show :: Clock -> String
$cshow :: Clock -> String
showsPrec :: Int -> Clock -> ShowS
$cshowsPrec :: Int -> Clock -> ShowS
Show, ReadPrec [Clock]
ReadPrec Clock
Int -> ReadS Clock
ReadS [Clock]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Clock]
$creadListPrec :: ReadPrec [Clock]
readPrec :: ReadPrec Clock
$creadPrec :: ReadPrec Clock
readList :: ReadS [Clock]
$creadList :: ReadS [Clock]
readsPrec :: Int -> ReadS Clock
$creadsPrec :: Int -> ReadS Clock
Read, Clock -> Clock -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Clock -> Clock -> Bool
$c/= :: Clock -> Clock -> Bool
== :: Clock -> Clock -> Bool
$c== :: Clock -> Clock -> Bool
Eq)

-- | Set the offset for a virtualized clock. This can only be called before any
-- process has been created in the time namespace. This function requires
-- @\/proc@ to be mounted. See @time_namespaces(7)@ for more details.
setClockOffset
    :: Clock           -- ^ Specify the clock whose offset is set.
    -> EpochTime       -- ^ The seconds component of the offset. This value
                       -- can be negative.
    -> CLong           -- ^ The nanoseconds component of the offset. This
                       -- value must not be negative.
    -> IO ()
setClockOffset :: Clock -> EpochTime -> CLong -> IO ()
setClockOffset Clock
clock EpochTime
offsetSecs CLong
offsetNanosecs =
    forall r. String -> IO r -> IO r
ioeSetLoc String
"setClockOffset" forall a b. (a -> b) -> a -> b
$ do
        String -> ByteString -> IO ()
writeProcFile String
"/proc/self/timens_offsets" (String -> ByteString
C.pack String
s)
  where
    s :: String
s = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
clockId, String
" ", forall a. Show a => a -> String
show EpochTime
offsetSecs, String
" ", forall a. Show a => a -> String
show CLong
offsetNanosecs]
    clockId :: String
clockId = case Clock
clock of
        Clock
Monotonic -> String
"monotonic"
        Clock
Boottime -> String
"boottime"

--------------------------------------------------------------------------------

writeProcFile :: FilePath -> ByteString -> IO ()
writeProcFile :: String -> ByteString -> IO ()
writeProcFile String
path ByteString
bs =

{-# LINE 259 "System/Linux/Namespaces.hsc" #-}
    forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (String -> OpenMode -> Maybe FileMode -> OpenFileFlags -> IO Fd
openFd String
path OpenMode
WriteOnly forall a. Maybe a
Nothing OpenFileFlags
defaultFileFlags) Fd -> IO ()
closeFd forall a b. (a -> b) -> a -> b
$ \Fd
fd ->

{-# LINE 261 "System/Linux/Namespaces.hsc" #-}
        forall a. ByteString -> (CStringLen -> IO a) -> IO a
S.useAsCStringLen ByteString
bs forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
ptr, Int
nb) ->
            Fd -> Ptr Word8 -> ByteCount -> IO ByteCount
fdWriteBuf Fd
fd (forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
ptr) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nb) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()

toProcPath :: Maybe ProcessID -> Namespace -> String
toProcPath :: Maybe ProcessID -> Namespace -> String
toProcPath Maybe ProcessID
mpid Namespace
ns = Maybe ProcessID -> String
toProcDir Maybe ProcessID
mpid forall a. [a] -> [a] -> [a]
++ String
"/ns/" forall a. [a] -> [a] -> [a]
++ Namespace -> String
toProcName Namespace
ns
{-# INLINE toProcPath #-}

toProcDir :: Maybe ProcessID -> String
toProcDir :: Maybe ProcessID -> String
toProcDir Maybe ProcessID
mpid = String
"/proc/" forall a. [a] -> [a] -> [a]
++ forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"self" forall a. Show a => a -> String
show Maybe ProcessID
mpid
{-# INLINE toProcDir #-}

ioeSetLoc :: String -> IO r -> IO r
ioeSetLoc :: forall r. String -> IO r -> IO r
ioeSetLoc String
loc = forall a. (IOError -> IOError) -> IO a -> IO a
modifyIOError (forall a b c. (a -> b -> c) -> b -> a -> c
flip IOError -> String -> IOError
ioeSetLocation String
loc)

--------------------------------------------------------------------------------

foreign import ccall unsafe "unshare"
    c_unshare :: CInt -> IO CInt

foreign import ccall unsafe "setns"
    c_setns :: Fd -> CInt -> IO CInt

--------------------------------------------------------------------------------

-- $example
-- Here's an example of creating a new network namespace. We also create
-- a user namespace. This allows us to execute the program as an
-- unprivileged user.
--
-- > import System.Process
-- > import System.Posix.User
-- > import System.Linux.Namespaces
-- >
-- > main :: IO ()
-- > main = do
-- >     putStrLn "*** Network interfaces in the parent namespace ***"
-- >     callCommand "ip addr"
-- >     putStrLn ""
-- >
-- >     -- find the uid, we must do that before unshare
-- >     uid <- getEffectiveUserID
-- >
-- >     unshare [User, Network]
-- >     -- map current user to user 0 (i.e. root) inside the namespace
-- >     writeUserMappings Nothing [UserMapping 0 uid 1]
-- >
-- >     -- enable the loopback interface
-- >     -- we can do that because we are root inside the namespace
-- >     callCommand "ip link set dev lo up"
-- >
-- >     putStrLn "*** Network interfaces in the new namespace ***"
-- >     callCommand "ip addr"