{-# OPTIONS_GHC -optc-D_GNU_SOURCE #-}
{-# LINE 1 "src/System/Landlock.hsc" #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE EmptyDataDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}

-- |
-- Module:      System.Landlock
-- Description: Haskell bindings for the Linux kernel Landlock API
-- Copyright:   (c) Nicolas Trangez, 2022
-- License:     BSD-3-Clause
-- Maintainer:  ikke@nicolast.be
-- Stability:   alpha
-- Portability: Linux
--
-- This library exposes Haskell bindings for the Linux kernel Landlock API.
--
-- The Linux kernel Landlock API provides unprivileged access control. The goal
-- of Landlock is to enable to restrict ambient rights (e.g. global filesystem
-- access) for a set of processes. Because Landlock is a stackable LSM, it makes
-- possible to create safe security sandboxes as new security layers in addition
-- to the existing system-wide access-controls. This kind of sandbox is expected
-- to help mitigate the security impact of bugs or unexpected/malicious
-- behaviors in user space applications. Landlock empowers any process,
-- including unprivileged ones, to securely restrict themselves.
--
-- For more information, see the [Landlock homepage](https://landlock.io/) and its
-- [kernel documentation](https://docs.kernel.org/userspace-api/landlock.html).

module System.Landlock (
    -- * Core API
    --
    -- | Use 'landlock' to sandbox a process.
    --
    -- $example
      landlock
    , RulesetAttr(..)
    -- ** Filesystem Access Flags
    --
    -- | Filesystem access flags to sandbox filesystem access.
    , AccessFsFlag(..)
    , accessFsFlags
    , accessFsFlagIsReadOnly
    -- * Sandboxing Rules
    --
    -- | Sandboxing rules to apply.
    , Rule
    , pathBeneath
    -- * Utility Functions
    --
    -- | Various utility functions.
    , isSupported
    -- ** Landlock ABI Version
    --
    -- | Retrieve and handle the kernel's Landlock ABI version.
    , abiVersion
    , Version
    , version1
    -- ** Opening paths using @O_PATH@
    --
    -- | When creating a 'pathBeneath' rule, a file descriptor to a directory
    -- or file is needed. These can be safely @open@ed using the @O_PATH@ flag
    -- using the following functions.
    , withOpenPath
    , withOpenPathAt
    , OpenPathFlags(..)
    , defaultOpenPathFlags
    ) where






import Control.Exception.Base (handleJust)
import Control.Monad (void)
import Control.Monad.Catch (MonadMask, bracket)
import Control.Monad.IO.Class (MonadIO, liftIO)
import GHC.IO.Exception (IOErrorType(UnsupportedOperation))
import Foreign.Marshal.Utils (with)
import Foreign.Ptr (nullPtr)
import Foreign.Storable (Storable, sizeOf)
import System.IO.Error (ioeGetErrorType)
import System.Posix.IO (closeFd)
import System.Posix.Types (Fd)

import System.Landlock.Flags (AccessFsFlag(..), accessFsFlagToBit, accessFsFlags, accessFsFlagIsReadOnly, toBits)
import System.Landlock.OpenPath (OpenPathFlags(..), defaultOpenPathFlags, withOpenPath, withOpenPathAt)
import System.Landlock.Rules (Rule, ruleType, pathBeneath)
import System.Landlock.Syscalls (LandlockRulesetAttr(..), landlock_create_ruleset, landlock_add_rule, landlock_restrict_self, prctl)
import System.Landlock.Version (Version(..), version1)

-- | Retrieve the Landlock ABI version of the running system.
--
-- __Warning:__ calling this on a system without Landlock support, or with
-- Landlock disabled, will result in an exception.
abiVersion :: IO Version
abiVersion :: IO Version
abiVersion = Int64 -> Version
Version (Int64 -> Version) -> IO Int64 -> IO Version
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr LandlockRulesetAttr -> Word64 -> Word32 -> IO Int64
landlock_create_ruleset Ptr LandlockRulesetAttr
forall a. Ptr a
nullPtr Word64
0 Word32
1
{-# LINE 99 "src/System/Landlock.hsc" #-}

-- | Check whether Landlock is supported and enabled on the running system.
isSupported :: IO Bool
isSupported :: IO Bool
isSupported = (IOError -> Maybe ()) -> (() -> IO Bool) -> IO Bool -> IO Bool
forall e b a.
Exception e =>
(e -> Maybe b) -> (b -> IO a) -> IO a -> IO a
handleJust IOError -> Maybe ()
unsupportedOperation (\() -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False) (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
    IO Version -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void IO Version
abiVersion
    Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  where
    unsupportedOperation :: IOError -> Maybe ()
unsupportedOperation IOError
exc = if IOError -> Bool
isUnsupportedOperationError IOError
exc then () -> Maybe ()
forall a. a -> Maybe a
Just () else Maybe ()
forall a. Maybe a
Nothing
    isUnsupportedOperationError :: IOError -> Bool
isUnsupportedOperationError = IOErrorType -> Bool
isUnsupportedOperationErrorType (IOErrorType -> Bool)
-> (IOError -> IOErrorType) -> IOError -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> IOErrorType
ioeGetErrorType
    isUnsupportedOperationErrorType :: IOErrorType -> Bool
isUnsupportedOperationErrorType = (IOErrorType -> IOErrorType -> Bool
forall a. Eq a => a -> a -> Bool
== IOErrorType
UnsupportedOperation)

-- | Ruleset attributes.
--
-- This represents a @struct landlock_ruleset_attr@ as passed to
-- @landlock_create_ruleset@.
data RulesetAttr = RulesetAttr { RulesetAttr -> [AccessFsFlag]
rulesetAttrHandledAccessFs :: [AccessFsFlag]
                                 -- ^ Actions (cf. 'AccessFsFlag') that ought to
                                 -- be handled by a ruleset and should be
                                 -- forbidden if no rule explicitly allow them.
                                 -- This is needed forbackward compatibility
                                 -- reasons.
                               }
  deriving (Int -> RulesetAttr -> ShowS
[RulesetAttr] -> ShowS
RulesetAttr -> String
(Int -> RulesetAttr -> ShowS)
-> (RulesetAttr -> String)
-> ([RulesetAttr] -> ShowS)
-> Show RulesetAttr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RulesetAttr] -> ShowS
$cshowList :: [RulesetAttr] -> ShowS
show :: RulesetAttr -> String
$cshow :: RulesetAttr -> String
showsPrec :: Int -> RulesetAttr -> ShowS
$cshowsPrec :: Int -> RulesetAttr -> ShowS
Show, RulesetAttr -> RulesetAttr -> Bool
(RulesetAttr -> RulesetAttr -> Bool)
-> (RulesetAttr -> RulesetAttr -> Bool) -> Eq RulesetAttr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RulesetAttr -> RulesetAttr -> Bool
$c/= :: RulesetAttr -> RulesetAttr -> Bool
== :: RulesetAttr -> RulesetAttr -> Bool
$c== :: RulesetAttr -> RulesetAttr -> Bool
Eq)

-- | Flags passed to @landlock_create_ruleset@.
--
-- In the current kernel API, only @LANDLOCK_CREATE_RULESET_VERSION@ is
-- defined, which should not be used when creating an actual Landlock
-- encironment (cf. 'landlock').
data CreateRulesetFlag = CreateRulesetVersion
  deriving (Int -> CreateRulesetFlag -> ShowS
[CreateRulesetFlag] -> ShowS
CreateRulesetFlag -> String
(Int -> CreateRulesetFlag -> ShowS)
-> (CreateRulesetFlag -> String)
-> ([CreateRulesetFlag] -> ShowS)
-> Show CreateRulesetFlag
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CreateRulesetFlag] -> ShowS
$cshowList :: [CreateRulesetFlag] -> ShowS
show :: CreateRulesetFlag -> String
$cshow :: CreateRulesetFlag -> String
showsPrec :: Int -> CreateRulesetFlag -> ShowS
$cshowsPrec :: Int -> CreateRulesetFlag -> ShowS
Show, CreateRulesetFlag -> CreateRulesetFlag -> Bool
(CreateRulesetFlag -> CreateRulesetFlag -> Bool)
-> (CreateRulesetFlag -> CreateRulesetFlag -> Bool)
-> Eq CreateRulesetFlag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CreateRulesetFlag -> CreateRulesetFlag -> Bool
$c/= :: CreateRulesetFlag -> CreateRulesetFlag -> Bool
== :: CreateRulesetFlag -> CreateRulesetFlag -> Bool
$c== :: CreateRulesetFlag -> CreateRulesetFlag -> Bool
Eq, Int -> CreateRulesetFlag
CreateRulesetFlag -> Int
CreateRulesetFlag -> [CreateRulesetFlag]
CreateRulesetFlag -> CreateRulesetFlag
CreateRulesetFlag -> CreateRulesetFlag -> [CreateRulesetFlag]
CreateRulesetFlag
-> CreateRulesetFlag -> CreateRulesetFlag -> [CreateRulesetFlag]
(CreateRulesetFlag -> CreateRulesetFlag)
-> (CreateRulesetFlag -> CreateRulesetFlag)
-> (Int -> CreateRulesetFlag)
-> (CreateRulesetFlag -> Int)
-> (CreateRulesetFlag -> [CreateRulesetFlag])
-> (CreateRulesetFlag -> CreateRulesetFlag -> [CreateRulesetFlag])
-> (CreateRulesetFlag -> CreateRulesetFlag -> [CreateRulesetFlag])
-> (CreateRulesetFlag
    -> CreateRulesetFlag -> CreateRulesetFlag -> [CreateRulesetFlag])
-> Enum CreateRulesetFlag
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 :: CreateRulesetFlag
-> CreateRulesetFlag -> CreateRulesetFlag -> [CreateRulesetFlag]
$cenumFromThenTo :: CreateRulesetFlag
-> CreateRulesetFlag -> CreateRulesetFlag -> [CreateRulesetFlag]
enumFromTo :: CreateRulesetFlag -> CreateRulesetFlag -> [CreateRulesetFlag]
$cenumFromTo :: CreateRulesetFlag -> CreateRulesetFlag -> [CreateRulesetFlag]
enumFromThen :: CreateRulesetFlag -> CreateRulesetFlag -> [CreateRulesetFlag]
$cenumFromThen :: CreateRulesetFlag -> CreateRulesetFlag -> [CreateRulesetFlag]
enumFrom :: CreateRulesetFlag -> [CreateRulesetFlag]
$cenumFrom :: CreateRulesetFlag -> [CreateRulesetFlag]
fromEnum :: CreateRulesetFlag -> Int
$cfromEnum :: CreateRulesetFlag -> Int
toEnum :: Int -> CreateRulesetFlag
$ctoEnum :: Int -> CreateRulesetFlag
pred :: CreateRulesetFlag -> CreateRulesetFlag
$cpred :: CreateRulesetFlag -> CreateRulesetFlag
succ :: CreateRulesetFlag -> CreateRulesetFlag
$csucc :: CreateRulesetFlag -> CreateRulesetFlag
Enum, CreateRulesetFlag
CreateRulesetFlag -> CreateRulesetFlag -> Bounded CreateRulesetFlag
forall a. a -> a -> Bounded a
maxBound :: CreateRulesetFlag
$cmaxBound :: CreateRulesetFlag
minBound :: CreateRulesetFlag
$cminBound :: CreateRulesetFlag
Bounded)

-- | Handle to a Landlock ruleset. Use 'addRule' to register new rules.
newtype LandlockFd = LandlockFd { LandlockFd -> Fd
unLandlockFd :: Fd }
  deriving (Int -> LandlockFd -> ShowS
[LandlockFd] -> ShowS
LandlockFd -> String
(Int -> LandlockFd -> ShowS)
-> (LandlockFd -> String)
-> ([LandlockFd] -> ShowS)
-> Show LandlockFd
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LandlockFd] -> ShowS
$cshowList :: [LandlockFd] -> ShowS
show :: LandlockFd -> String
$cshow :: LandlockFd -> String
showsPrec :: Int -> LandlockFd -> ShowS
$cshowsPrec :: Int -> LandlockFd -> ShowS
Show, LandlockFd -> LandlockFd -> Bool
(LandlockFd -> LandlockFd -> Bool)
-> (LandlockFd -> LandlockFd -> Bool) -> Eq LandlockFd
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LandlockFd -> LandlockFd -> Bool
$c/= :: LandlockFd -> LandlockFd -> Bool
== :: LandlockFd -> LandlockFd -> Bool
$c== :: LandlockFd -> LandlockFd -> Bool
Eq)

createRuleset :: RulesetAttr -> [CreateRulesetFlag] -> IO LandlockFd
createRuleset :: RulesetAttr -> [CreateRulesetFlag] -> IO LandlockFd
createRuleset RulesetAttr
attr [CreateRulesetFlag]
flags = LandlockRulesetAttr
-> (Ptr LandlockRulesetAttr -> IO LandlockFd) -> IO LandlockFd
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with LandlockRulesetAttr
attr' ((Ptr LandlockRulesetAttr -> IO LandlockFd) -> IO LandlockFd)
-> (Ptr LandlockRulesetAttr -> IO LandlockFd) -> IO LandlockFd
forall a b. (a -> b) -> a -> b
$ \Ptr LandlockRulesetAttr
attrp -> Int64 -> LandlockFd
wrap (Int64 -> LandlockFd) -> IO Int64 -> IO LandlockFd
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr LandlockRulesetAttr -> Word64 -> Word32 -> IO Int64
landlock_create_ruleset Ptr LandlockRulesetAttr
attrp (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64) -> Int -> Word64
forall a b. (a -> b) -> a -> b
$ LandlockRulesetAttr -> Int
forall a. Storable a => a -> Int
sizeOf LandlockRulesetAttr
attr') Word32
flags'
  where
    wrap :: Int64 -> LandlockFd
wrap = Fd -> LandlockFd
LandlockFd (Fd -> LandlockFd) -> (Int64 -> Fd) -> Int64 -> LandlockFd
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Fd
forall a b. (Integral a, Num b) => a -> b
fromIntegral
    attr' :: LandlockRulesetAttr
attr' = LandlockRulesetAttr :: Word64 -> LandlockRulesetAttr
LandlockRulesetAttr { landlockRulesetAttrHandledAccessFs :: Word64
landlockRulesetAttrHandledAccessFs = Word64
handledAccessFs }
    handledAccessFs :: Word64
handledAccessFs = [AccessFsFlag] -> (AccessFsFlag -> Word64) -> Word64
forall b (f :: * -> *) a.
(Num b, Bits b, Foldable f) =>
f a -> (a -> b) -> b
toBits (RulesetAttr -> [AccessFsFlag]
rulesetAttrHandledAccessFs RulesetAttr
attr) AccessFsFlag -> Word64
forall a. Num a => AccessFsFlag -> a
accessFsFlagToBit
    flags' :: Word32
flags' = [CreateRulesetFlag] -> (CreateRulesetFlag -> Word32) -> Word32
forall b (f :: * -> *) a.
(Num b, Bits b, Foldable f) =>
f a -> (a -> b) -> b
toBits [CreateRulesetFlag]
flags ((CreateRulesetFlag -> Word32) -> Word32)
-> (CreateRulesetFlag -> Word32) -> Word32
forall a b. (a -> b) -> a -> b
$ \case
       CreateRulesetFlag
CreateRulesetVersion -> Word32
1
{-# LINE 143 "src/System/Landlock.hsc" #-}

-- | Flags passed to @landlock_restrict_self@.
--
-- In the current kernel API, no such flags are defined, hence this is a type
-- without any constructors.
data RestrictSelfFlag
  deriving (Int -> RestrictSelfFlag -> ShowS
[RestrictSelfFlag] -> ShowS
RestrictSelfFlag -> String
(Int -> RestrictSelfFlag -> ShowS)
-> (RestrictSelfFlag -> String)
-> ([RestrictSelfFlag] -> ShowS)
-> Show RestrictSelfFlag
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RestrictSelfFlag] -> ShowS
$cshowList :: [RestrictSelfFlag] -> ShowS
show :: RestrictSelfFlag -> String
$cshow :: RestrictSelfFlag -> String
showsPrec :: Int -> RestrictSelfFlag -> ShowS
$cshowsPrec :: Int -> RestrictSelfFlag -> ShowS
Show, RestrictSelfFlag -> RestrictSelfFlag -> Bool
(RestrictSelfFlag -> RestrictSelfFlag -> Bool)
-> (RestrictSelfFlag -> RestrictSelfFlag -> Bool)
-> Eq RestrictSelfFlag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RestrictSelfFlag -> RestrictSelfFlag -> Bool
$c/= :: RestrictSelfFlag -> RestrictSelfFlag -> Bool
== :: RestrictSelfFlag -> RestrictSelfFlag -> Bool
$c== :: RestrictSelfFlag -> RestrictSelfFlag -> Bool
Eq)

restrictSelf :: LandlockFd -> [RestrictSelfFlag] -> IO ()
restrictSelf :: LandlockFd -> [RestrictSelfFlag] -> IO ()
restrictSelf LandlockFd
fd [RestrictSelfFlag]
flags =
    IO Int64 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int64 -> IO ()) -> IO Int64 -> IO ()
forall a b. (a -> b) -> a -> b
$ Int32 -> Word32 -> IO Int64
landlock_restrict_self (Fd -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Fd -> Int32) -> Fd -> Int32
forall a b. (a -> b) -> a -> b
$ LandlockFd -> Fd
unLandlockFd LandlockFd
fd) Word32
flags'
  where
    flags' :: Word32
flags' = [RestrictSelfFlag] -> (RestrictSelfFlag -> Word32) -> Word32
forall b (f :: * -> *) a.
(Num b, Bits b, Foldable f) =>
f a -> (a -> b) -> b
toBits [RestrictSelfFlag]
flags ((RestrictSelfFlag -> Word32) -> Word32)
-> (RestrictSelfFlag -> Word32) -> Word32
forall a b. (a -> b) -> a -> b
$ \case {}

-- | Apply a Landlock sandbox to the current process.
--
-- The provided action can be used to register Landlock 'Rule's on the given
-- instance (see 'addRule').
--
-- Once this returns, the Landlock sandbox will be in effect (see
-- @landlock_restrict_self@), and no privileged processes can be spawned
-- (@prctl(PR_SET_NO_NEW_PRIVS, 1, 0, 0, 0)@ has been invoked).
--
-- __Warning:__ calling this on a system without Landlock support, or with
-- Landlock disabled, will result in an exception.
landlock :: (MonadMask m, MonadIO m)
         => RulesetAttr
            -- ^ Ruleset attribute passed to @landlock_create_ruleset@.
         -> [CreateRulesetFlag]
            -- ^ Flags passed to @landlock_create_ruleset@. Since no flags but
            --   'CreateRulesetVersion' (@LANDLOCK_CREATE_RULESET_VERSION@) are
            --   defined, and this flag must not be used when creating an actual
            --   ruleset, this should be an empty list.
         -> [RestrictSelfFlag]
            -- ^ Flags passed to @landlock_restrict_self@. Since no flags are
            -- defined, this should be an empty list.
         -> ((Storable (Rule r) => Rule r -> [AddRuleFlag] -> m ()) -> m a)
            -- ^ Action that will be called before the Landlock sandbox is
            -- enforced. The provided function can be used to register
            -- sandboxing rules (internally using @landlock_add_rule@),
            -- given a 'Rule' and a set of 'AddRuleFlag's. However, since no
            -- flags are currently defined, this should be an empty list.
         -> m a
            -- ^ Result of the given action.
landlock :: RulesetAttr
-> [CreateRulesetFlag]
-> [RestrictSelfFlag]
-> ((Storable (Rule r) => Rule r -> [AddRuleFlag] -> m ()) -> m a)
-> m a
landlock RulesetAttr
attr [CreateRulesetFlag]
createRulesetFlags [RestrictSelfFlag]
restrictSelfFlags (Storable (Rule r) => Rule r -> [AddRuleFlag] -> m ()) -> m a
act =
    m LandlockFd -> (LandlockFd -> m ()) -> (LandlockFd -> m a) -> m a
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket (IO LandlockFd -> m LandlockFd
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO LandlockFd -> m LandlockFd) -> IO LandlockFd -> m LandlockFd
forall a b. (a -> b) -> a -> b
$ RulesetAttr -> [CreateRulesetFlag] -> IO LandlockFd
createRuleset RulesetAttr
attr [CreateRulesetFlag]
createRulesetFlags) (IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (LandlockFd -> IO ()) -> LandlockFd -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fd -> IO ()
closeFd (Fd -> IO ()) -> (LandlockFd -> Fd) -> LandlockFd -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LandlockFd -> Fd
unLandlockFd) ((LandlockFd -> m a) -> m a) -> (LandlockFd -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \LandlockFd
fd -> do
        a
res <- (Storable (Rule r) => Rule r -> [AddRuleFlag] -> m ()) -> m a
act (LandlockFd -> Rule r -> [AddRuleFlag] -> m ()
forall (m :: * -> *) (a :: RuleType).
(MonadIO m, Storable (Rule a)) =>
LandlockFd -> Rule a -> [AddRuleFlag] -> m ()
addRule LandlockFd
fd)
        IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
            IO Int32 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int32 -> IO ()) -> IO Int32 -> IO ()
forall a b. (a -> b) -> a -> b
$ Int32 -> Word64 -> Word64 -> Word64 -> Word64 -> IO Int32
prctl Int32
38 Word64
1 Word64
0 Word64
0 Word64
0
{-# LINE 192 "src/System/Landlock.hsc" #-}
            LandlockFd -> [RestrictSelfFlag] -> IO ()
restrictSelf LandlockFd
fd [RestrictSelfFlag]
restrictSelfFlags
        a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res

-- | Flags passed to @landlock_add_rule@.
--
-- In the current kernel API, no such flags are defined, hence this is a type
-- without any constructors.
data AddRuleFlag
  deriving (Int -> AddRuleFlag -> ShowS
[AddRuleFlag] -> ShowS
AddRuleFlag -> String
(Int -> AddRuleFlag -> ShowS)
-> (AddRuleFlag -> String)
-> ([AddRuleFlag] -> ShowS)
-> Show AddRuleFlag
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AddRuleFlag] -> ShowS
$cshowList :: [AddRuleFlag] -> ShowS
show :: AddRuleFlag -> String
$cshow :: AddRuleFlag -> String
showsPrec :: Int -> AddRuleFlag -> ShowS
$cshowsPrec :: Int -> AddRuleFlag -> ShowS
Show, AddRuleFlag -> AddRuleFlag -> Bool
(AddRuleFlag -> AddRuleFlag -> Bool)
-> (AddRuleFlag -> AddRuleFlag -> Bool) -> Eq AddRuleFlag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AddRuleFlag -> AddRuleFlag -> Bool
$c/= :: AddRuleFlag -> AddRuleFlag -> Bool
== :: AddRuleFlag -> AddRuleFlag -> Bool
$c== :: AddRuleFlag -> AddRuleFlag -> Bool
Eq)

-- | Register a new 'Rule' with a Landlock instance.
addRule :: (MonadIO m, Storable (Rule a))
        => LandlockFd
           -- ^ Handle to a Landlock instance.
        -> Rule a
           -- ^ Sandboxing 'Rule' to register with the Landlock instance.
        -> [AddRuleFlag]
           -- ^ Flags. Since no flags are defined, this should be an empty
           --   list.
        -> m ()
addRule :: LandlockFd -> Rule a -> [AddRuleFlag] -> m ()
addRule LandlockFd
fd Rule a
rule [AddRuleFlag]
flags = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Rule a -> (Ptr (Rule a) -> IO ()) -> IO ()
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with Rule a
rule ((Ptr (Rule a) -> IO ()) -> IO ())
-> (Ptr (Rule a) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr (Rule a)
ruleAttrp ->
    IO Int64 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int64 -> IO ()) -> IO Int64 -> IO ()
forall a b. (a -> b) -> a -> b
$ Int32 -> Word32 -> Ptr (Rule a) -> Word32 -> IO Int64
forall a. Int32 -> Word32 -> Ptr a -> Word32 -> IO Int64
landlock_add_rule (Fd -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Fd -> Int32) -> Fd -> Int32
forall a b. (a -> b) -> a -> b
$ LandlockFd -> Fd
unLandlockFd LandlockFd
fd) (Rule a -> Word32
forall (a :: RuleType). Rule a -> Word32
ruleType Rule a
rule) Ptr (Rule a)
ruleAttrp Word32
flags'
  where
    flags' :: Word32
flags' = [AddRuleFlag] -> (AddRuleFlag -> Word32) -> Word32
forall b (f :: * -> *) a.
(Num b, Bits b, Foldable f) =>
f a -> (a -> b) -> b
toBits [AddRuleFlag]
flags ((AddRuleFlag -> Word32) -> Word32)
-> (AddRuleFlag -> Word32) -> Word32
forall a b. (a -> b) -> a -> b
$ \case {}

-- |
-- $example
--
-- Example usage:
--
-- @
-- -- Retrieve the Landlock ABI version
-- abi <- abiVersion
--
-- -- Calculate access flag sets
-- -- Note: in production code, find the highest matching version or similar
-- let Just flags = lookup abi accessFsFlags
--     readOnlyFlags = filter accessFsFlagIsReadOnly flags
--
-- -- Sandbox the process
-- landlock (RulesetAttr flags) [] [] $ \\addRule -> do
--     -- Allow read-only access to the /usr hierarchy
--     withOpenPath "/usr" defaultOpenPathFlags{ directory = True } $ \\fd ->
--         addRule (pathBeneath fd readOnlyFlags) []
--
--     -- Allow read access to my public key
--     withOpenPath "\/home\/nicolas\/.ssh\/id_ed25519.pub" defaultOpenPathFlags $ \\fd ->
--         addRule (pathBeneath fd [AccessFsReadFile]) []
--
-- withFile "\/home\/nicolas\/.ssh\/id_ed25519.pub" ReadMode (\\fd -> putStrLn \"Success\")
-- -- Success
--
-- withFile "\/usr\/bin\/ghc" ReadMode (\\fd -> putStrLn \"Success\")
-- -- Success
--
-- openFile "\/home\/nicolas\/.ssh\/id_ed25519" ReadMode
-- -- *** Exception: \/home\/nicolas\/.ssh\/id_ed25519: openFile: permission denied (Permission denied)
-- @