{-# LANGUAGE FlexibleContexts #-}
{-# 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/), its
-- [kernel documentation](https://docs.kernel.org/userspace-api/landlock.html)
-- and its [manual page](https://man.archlinux.org/man/landlock.7.en).
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,
    getVersion,
    version1,
    version2,
    version3,

    -- ** Opening paths using @O_PATH@

    -- | When creating a 'pathBeneath' rule, a file descriptor to a directory
    -- or file is needed. These can be safely opened using the
    -- [@O_PATH@](https://man.archlinux.org/man/openat.2#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 Foreign.Marshal.Utils (with)
import Foreign.Ptr (nullPtr)
import Foreign.Storable (Storable, sizeOf)
import GHC.IO.Exception (IOErrorType (UnsupportedOperation))
import System.IO.Error (ioeGetErrorType)
import System.Landlock.Flags
  ( AccessFsFlag (..),
    AddRuleFlag,
    CreateRulesetFlag (..),
    RestrictSelfFlag,
    accessFsFlagIsReadOnly,
    accessFsFlagToBit,
    accessFsFlags,
    addRuleFlagToBit,
    createRulesetFlagToBit,
    restrictSelfFlagToBit,
    toBits,
  )
import System.Landlock.OpenPath
  ( OpenPathFlags (..),
    defaultOpenPathFlags,
    withOpenPath,
    withOpenPathAt,
  )
import System.Landlock.Rules (Rule, pathBeneath, ruleType)
import System.Landlock.Syscalls
  ( LandlockRulesetAttr (..),
    landlock_add_rule,
    landlock_create_ruleset,
    landlock_restrict_self,
    pR_SET_NO_NEW_PRIVS,
    prctl,
    throwIfNonZero,
  )
import System.Landlock.Version (Version (..), version1, version2, version3)
import System.Posix.IO (closeFd)
import System.Posix.Types (Fd)

-- | Retrieve the Landlock ABI version of the running system.
--
-- This invokes
-- [@landlock_create_ruleset@](https://man.archlinux.org/man/landlock_create_ruleset.2.en)
-- with the
-- [@LANDLOCK_CREATE_RULESET_VERSION@](https://man.archlinux.org/man/landlock_create_ruleset.2.en#LANDLOCK_CREATE_RULESET_VERSION)
-- option.
--
-- __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 = Word -> Version
Version (Word -> Version) -> (CLong -> Word) -> CLong -> Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CLong -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CLong -> Version) -> IO CLong -> IO Version
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr LandlockRulesetAttr -> CSize -> U32 -> IO CLong
landlock_create_ruleset Ptr LandlockRulesetAttr
forall a. Ptr a
nullPtr CSize
0 U32
flags
  where
    flags :: U32
flags = (CreateRulesetFlag -> U32) -> [CreateRulesetFlag] -> U32
forall b (f :: * -> *) a.
(Num b, Bits b, Foldable f) =>
(a -> b) -> f a -> b
toBits CreateRulesetFlag -> U32
createRulesetFlagToBit [CreateRulesetFlag
CreateRulesetVersion]

-- | Check whether Landlock is supported and enabled on the running system.
--
-- This calls 'abiVersion', catching relevant exceptions to return 'False' when
-- applicable.
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 a. a -> IO a
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 a. a -> IO a
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@](https://man.archlinux.org/man/landlock_create_ruleset.2.en).

{- HLINT ignore "Use newtype instead of data" -}
data RulesetAttr = RulesetAttr
  { -- | Actions (cf. 'AccessFsFlag') that ought to
    -- be handled by a ruleset and should be
    -- forbidden if no rule explicitly allow them.
    -- This is needed for backward compatibility
    -- reasons.
    RulesetAttr -> [AccessFsFlag]
rulesetAttrHandledAccessFs :: [AccessFsFlag]
  }
  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
$cshowsPrec :: Int -> RulesetAttr -> ShowS
showsPrec :: Int -> RulesetAttr -> ShowS
$cshow :: RulesetAttr -> String
show :: RulesetAttr -> String
$cshowList :: [RulesetAttr] -> ShowS
showList :: [RulesetAttr] -> ShowS
Show, RulesetAttr -> RulesetAttr -> Bool
(RulesetAttr -> RulesetAttr -> Bool)
-> (RulesetAttr -> RulesetAttr -> Bool) -> Eq RulesetAttr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RulesetAttr -> RulesetAttr -> Bool
== :: RulesetAttr -> RulesetAttr -> Bool
$c/= :: RulesetAttr -> RulesetAttr -> Bool
/= :: RulesetAttr -> RulesetAttr -> Bool
Eq)

-- | 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
$cshowsPrec :: Int -> LandlockFd -> ShowS
showsPrec :: Int -> LandlockFd -> ShowS
$cshow :: LandlockFd -> String
show :: LandlockFd -> String
$cshowList :: [LandlockFd] -> ShowS
showList :: [LandlockFd] -> ShowS
Show, LandlockFd -> LandlockFd -> Bool
(LandlockFd -> LandlockFd -> Bool)
-> (LandlockFd -> LandlockFd -> Bool) -> Eq LandlockFd
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LandlockFd -> LandlockFd -> Bool
== :: LandlockFd -> LandlockFd -> Bool
$c/= :: LandlockFd -> LandlockFd -> Bool
/= :: 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 ->
  CLong -> LandlockFd
wrap (CLong -> LandlockFd) -> IO CLong -> IO LandlockFd
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr LandlockRulesetAttr -> CSize -> U32 -> IO CLong
landlock_create_ruleset Ptr LandlockRulesetAttr
attrp (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> CSize) -> Int -> CSize
forall a b. (a -> b) -> a -> b
$ LandlockRulesetAttr -> Int
forall a. Storable a => a -> Int
sizeOf LandlockRulesetAttr
attr') U32
flags'
  where
    wrap :: CLong -> LandlockFd
wrap = Fd -> LandlockFd
LandlockFd (Fd -> LandlockFd) -> (CLong -> Fd) -> CLong -> LandlockFd
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CLong -> Fd
forall a b. (Integral a, Num b) => a -> b
fromIntegral
    attr' :: LandlockRulesetAttr
attr' =
      LandlockRulesetAttr
        { landlockRulesetAttrHandledAccessFs :: U64
landlockRulesetAttrHandledAccessFs = U64
handledAccessFs
        }
    handledAccessFs :: U64
handledAccessFs = (AccessFsFlag -> U64) -> [AccessFsFlag] -> U64
forall b (f :: * -> *) a.
(Num b, Bits b, Foldable f) =>
(a -> b) -> f a -> b
toBits AccessFsFlag -> U64
accessFsFlagToBit (RulesetAttr -> [AccessFsFlag]
rulesetAttrHandledAccessFs RulesetAttr
attr)
    flags' :: U32
flags' = (CreateRulesetFlag -> U32) -> [CreateRulesetFlag] -> U32
forall b (f :: * -> *) a.
(Num b, Bits b, Foldable f) =>
(a -> b) -> f a -> b
toBits CreateRulesetFlag -> U32
createRulesetFlagToBit [CreateRulesetFlag]
flags

restrictSelf :: LandlockFd -> [RestrictSelfFlag] -> IO ()
restrictSelf :: LandlockFd -> [RestrictSelfFlag] -> IO ()
restrictSelf LandlockFd
fd [RestrictSelfFlag]
flags =
  CInt -> U32 -> IO ()
landlock_restrict_self (Fd -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Fd -> CInt) -> Fd -> CInt
forall a b. (a -> b) -> a -> b
$ LandlockFd -> Fd
unLandlockFd LandlockFd
fd) U32
flags'
  where
    flags' :: U32
flags' = (RestrictSelfFlag -> U32) -> [RestrictSelfFlag] -> U32
forall b (f :: * -> *) a.
(Num b, Bits b, Foldable f) =>
(a -> b) -> f a -> b
toBits RestrictSelfFlag -> U32
restrictSelfFlagToBit [RestrictSelfFlag]
flags

-- | 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@](https://man.archlinux.org/man/landlock_restrict_self.2.en)),
-- and no privileged processes can be spawned
-- (@[prctl](https://man.archlinux.org/man/prctl.2)([PR_SET_NO_NEW_PRIVS](https://man.archlinux.org/man/prctl.2#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) =>
  -- | Ruleset attribute passed to
  -- [@landlock_create_ruleset@](https://man.archlinux.org/man/landlock_create_ruleset.2.en).
  RulesetAttr ->
  -- | Flags passed to
  -- [@landlock_create_ruleset@](https://man.archlinux.org/man/landlock_create_ruleset.2.en).
  -- Since no flags but 'CreateRulesetVersion'
  -- ([@LANDLOCK_CREATE_RULESET_VERSION@](https://man.archlinux.org/man/landlock_create_ruleset.2.en#LANDLOCK_CREATE_RULESET_VERSION))
  -- are defined, and this flag must not be used when creating an actual
  -- ruleset, this should be an empty list.
  [CreateRulesetFlag] ->
  -- | Flags passed to
  -- [@landlock_restrict_self@](https://man.archlinux.org/man/landlock_restrict_self.2.en).
  -- Since no flags are defined, this should be an empty list.
  [RestrictSelfFlag] ->
  -- | 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@](https://man.archlinux.org/man/landlock_add_rule.2.en)),
  -- given a 'Rule' and a set of 'AddRuleFlag's. However, since no
  -- flags are currently defined, this should be an empty list.
  (((Storable (Rule r)) => Rule r -> [AddRuleFlag] -> m ()) -> m a) ->
  -- | Result of the given action.
  m a
landlock :: forall (m :: * -> *) (r :: RuleType) a.
(MonadMask m, MonadIO m) =>
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 a. IO a -> m a
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 a. IO a -> m a
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 a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        String -> IO CInt -> IO ()
forall a. (Num a, Eq a, Show a) => String -> IO a -> IO ()
throwIfNonZero String
"prtcl" (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$ CInt -> CULong -> CULong -> CULong -> CULong -> IO CInt
prctl CInt
pR_SET_NO_NEW_PRIVS CULong
1 CULong
0 CULong
0 CULong
0
        LandlockFd -> [RestrictSelfFlag] -> IO ()
restrictSelf LandlockFd
fd [RestrictSelfFlag]
restrictSelfFlags
      a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res

-- | Register a new 'Rule' with a Landlock instance.
addRule ::
  (MonadIO m, Storable (Rule a)) =>
  -- | Handle to a Landlock instance.
  LandlockFd ->
  -- | Sandboxing 'Rule' to register with the Landlock instance.
  Rule a ->
  -- | Flags. Since no flags are defined, this should be an empty
  --   list.
  [AddRuleFlag] ->
  m ()
addRule :: forall (m :: * -> *) (a :: RuleType).
(MonadIO m, Storable (Rule a)) =>
LandlockFd -> Rule a -> [AddRuleFlag] -> m ()
addRule LandlockFd
fd Rule a
rule [AddRuleFlag]
flags = IO () -> m ()
forall a. IO a -> m a
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 ->
    CInt -> U32 -> Ptr (Rule a) -> U32 -> IO ()
forall a. CInt -> U32 -> Ptr a -> U32 -> IO ()
landlock_add_rule
      (Fd -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Fd -> CInt) -> Fd -> CInt
forall a b. (a -> b) -> a -> b
$ LandlockFd -> Fd
unLandlockFd LandlockFd
fd)
      (Rule a -> U32
forall (a :: RuleType). Rule a -> U32
ruleType Rule a
rule)
      Ptr (Rule a)
ruleAttrp
      U32
flags'
  where
    flags' :: U32
flags' = (AddRuleFlag -> U32) -> [AddRuleFlag] -> U32
forall b (f :: * -> *) a.
(Num b, Bits b, Foldable f) =>
(a -> b) -> f a -> b
toBits AddRuleFlag -> U32
addRuleFlagToBit [AddRuleFlag]
flags

-- $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)
-- @