diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for landlock + +## 0.1.0.0 -- 2022-08-18 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +BSD 3-Clause License + +Copyright (c) 2022, Nicolas Trangez +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,15 @@ +# landlock-hs: Haskell bindings for the Linux Landlock API + +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). diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cbits/hs-landlock.c b/cbits/hs-landlock.c new file mode 100644 --- /dev/null +++ b/cbits/hs-landlock.c @@ -0,0 +1,33 @@ +#define _GNU_SOURCE + +#include +#include +#include +#include +#include + +#include "hs-landlock.h" + +#ifndef landlock_create_ruleset +long landlock_create_ruleset(const struct landlock_ruleset_attr *const attr, + const size_t size, + const __u32 flags) { + return syscall(__NR_landlock_create_ruleset, attr, size, flags); +} +#endif + +#ifndef landlock_add_rule +long landlock_add_rule(const int ruleset_fd, + const enum landlock_rule_type rule_type, + const void *const rule_attr, + const __u32 flags) { + return syscall(__NR_landlock_add_rule, ruleset_fd, rule_type, rule_attr, flags); +} +#endif + +#ifndef landlock_restrict_self +long landlock_restrict_self(const int ruleset_fd, + const __u32 flags) { + return syscall(__NR_landlock_restrict_self, ruleset_fd, flags); +} +#endif diff --git a/cbits/hs-landlock.h b/cbits/hs-landlock.h new file mode 100644 --- /dev/null +++ b/cbits/hs-landlock.h @@ -0,0 +1,26 @@ +#ifndef _HS_LANDLOCK_H_ +#define _HS_LANDLOCK_H_ + +#include +#include +#include + +#ifdef __cplusplus +extern "C" { +#endif + +long landlock_create_ruleset(const struct landlock_ruleset_attr *const attr, + const size_t size, + const __u32 flags); +long landlock_add_rule(const int ruleset_fd, + const enum landlock_rule_type rule_type, + const void *const rule_attr, + const __u32 flags); +long landlock_restrict_self(const int ruleset_fd, + const __u32 flags); + +#ifdef __cplusplus +} +#endif + +#endif diff --git a/internal/System/Landlock/Flags.hsc b/internal/System/Landlock/Flags.hsc new file mode 100644 --- /dev/null +++ b/internal/System/Landlock/Flags.hsc @@ -0,0 +1,119 @@ +{-# LANGUAGE LambdaCase #-} + +module System.Landlock.Flags ( + toBits + , fromBits + , AccessFsFlag(..) + , accessFsFlagToBit + , accessFsFlags + , accessFsFlagIsReadOnly + ) where + +#include + +import Data.Bits (Bits, (.|.), (.&.)) + +import System.Landlock.Version (Version, version1) + +-- | Fold a set of flags into a bitset/number. +toBits :: (Num b, Bits b, Foldable f) => f a -> (a -> b) -> b +toBits l f = foldr (\a b -> b .|. f a) 0 l + +-- | Expand a bitset/number into a set of flags. +fromBits :: (Enum a, Bounded a, Num b, Bits b) => b -> (a -> b) -> [a] +fromBits b f = filter (\a -> b .&. f a /= 0) [minBound .. maxBound] + +-- | Filesystem flags. +-- +-- These flags enable to restrict a sandboxed process to a set of actions on +-- files and directories. Files or directories opened before the sandboxing +-- are not subject to these restrictions. +-- +-- A file can only receive these access rights: +-- +-- - 'AccessFsExecute' +-- - 'AccessFsWriteFile' +-- - 'AccessFsReadFile' +-- +-- A directory can receive access rights related to files or directories. The +-- following access right is applied to the directory itself, and the +-- directories beneath it: +-- +-- - 'AccessFsReadDir' +-- +-- However, the following access rights only apply to the content of a +-- directory, not the directory itself: +-- +-- - 'AccessFsRemoveDir' +-- - 'AccessFsRemoveFile' +-- - 'AccessFsMakeChar' +-- - 'AccessFsMakeDir' +-- - 'AccessFsMakeReg' +-- - 'AccessFsMakeSock' +-- - 'AccessFsMakeFifo' +-- - 'AccessFsMakeBlock' +-- - 'AccessFsMakeSym' +-- +-- __Warning:__ It is currently not possible to restrict some file-related +-- actions acessible through these syscall families: @chdir@, @truncate@, +-- @stat@, @flock@, @chmod@, @chown@, @setxattr@, @utime@, @ioctl@, @fcntl@, +-- @access@. Future Landlock evolutions will enable to restrict them. +data AccessFsFlag = AccessFsExecute -- ^ Execute a file. + | AccessFsWriteFile -- ^ Open a file with write access. + | AccessFsReadFile -- ^ Open a file with read access. + | AccessFsReadDir -- ^ Open a directory or list its content. + | AccessFsRemoveDir -- ^ Remove an empty directory or rename one + | AccessFsRemoveFile -- ^ Unlink (or rename) a file. + | AccessFsMakeChar -- ^ Create (or rename or link) a character device. + | AccessFsMakeDir -- ^ Create (or rename) a directory. + | AccessFsMakeReg -- ^ Create (or rename or link) a regular file. + | AccessFsMakeSock -- ^ Create (or rename or link) a UNIX domain socket. + | AccessFsMakeFifo -- ^ Create (or rename or link) a named pipe. + | AccessFsMakeBlock -- ^ Create (or rename or link) a block device. + | AccessFsMakeSym -- ^ Create (or rename or link) a symbolic link. + +-- Note: when adding new flags, this likely means a new ABI version is +-- available. Hence, add this to 'System.Landlock.Version' (and export it +-- from 'System.Landlock'), and make sure to update both 'accessFsFlags' and +-- 'accessFsFlagIsReadOnly'. + deriving (Show, Eq, Enum, Bounded, Ord) + +-- | Retrieve a number with the appropriate 'AccessFsFlag' bit set. +accessFsFlagToBit :: Num a => AccessFsFlag -> a +accessFsFlagToBit = \case + AccessFsExecute -> #{const LANDLOCK_ACCESS_FS_EXECUTE} + AccessFsWriteFile -> #{const LANDLOCK_ACCESS_FS_WRITE_FILE} + AccessFsReadFile -> #{const LANDLOCK_ACCESS_FS_READ_FILE} + AccessFsReadDir -> #{const LANDLOCK_ACCESS_FS_READ_DIR} + AccessFsRemoveDir -> #{const LANDLOCK_ACCESS_FS_REMOVE_DIR} + AccessFsRemoveFile -> #{const LANDLOCK_ACCESS_FS_REMOVE_FILE} + AccessFsMakeChar -> #{const LANDLOCK_ACCESS_FS_MAKE_CHAR} + AccessFsMakeDir -> #{const LANDLOCK_ACCESS_FS_MAKE_DIR} + AccessFsMakeReg -> #{const LANDLOCK_ACCESS_FS_MAKE_REG} + AccessFsMakeSock -> #{const LANDLOCK_ACCESS_FS_MAKE_SOCK} + AccessFsMakeFifo -> #{const LANDLOCK_ACCESS_FS_MAKE_FIFO} + AccessFsMakeBlock -> #{const LANDLOCK_ACCESS_FS_MAKE_BLOCK} + AccessFsMakeSym -> #{const LANDLOCK_ACCESS_FS_MAKE_SYM} + +-- | All 'AccessFsFlag' flags keyed by a Landlock ABI 'Version'. +accessFsFlags :: [(Version, [AccessFsFlag])] +accessFsFlags = [ + (version1, [AccessFsExecute .. AccessFsMakeSym]) + ] + +-- | Predicate for read-only 'AccessFsFlag' flags. +accessFsFlagIsReadOnly :: AccessFsFlag -> Bool +accessFsFlagIsReadOnly = \case + AccessFsExecute -> True + AccessFsWriteFile -> False + AccessFsReadFile -> True + AccessFsReadDir -> True + AccessFsRemoveDir -> False + AccessFsRemoveFile -> False + AccessFsMakeChar -> False + AccessFsMakeDir -> False + AccessFsMakeReg -> False + AccessFsMakeSock -> False + AccessFsMakeFifo -> False + AccessFsMakeBlock -> False + AccessFsMakeSym -> False diff --git a/internal/System/Landlock/OpenPath.hsc b/internal/System/Landlock/OpenPath.hsc new file mode 100644 --- /dev/null +++ b/internal/System/Landlock/OpenPath.hsc @@ -0,0 +1,93 @@ +module System.Landlock.OpenPath ( + withOpenPath + , withOpenPathAt + , OpenPathFlags(..) + , defaultOpenPathFlags + ) where + +#define _GNU_SOURCE + +#include + +import Control.Monad.Catch (MonadMask, bracket) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Bits ((.|.)) +import Data.Int (Int32) +import Foreign.C.String (CString, withCString) +import System.Posix.Error (throwErrnoPathIfMinus1Retry) +import System.Posix.IO (closeFd) +import System.Posix.Types (Fd) + +foreign import ccall unsafe "fcntl.h openat" + _openat :: #{type int} + -> CString + -> #{type int} + -> IO #{type int} + +openat :: Fd + -> FilePath + -> #{type int} + -> IO Fd +openat dirfd pathname flags = withCString pathname $ \pathnamep -> do + fd <- throwErrnoPathIfMinus1Retry "openat" pathname $ _openat (fromIntegral dirfd) pathnamep flags + return $ fromIntegral fd + +-- | Extra flags used by 'withOpenPathAt' in the call to @openat@. +data OpenPathFlags = OpenPathFlags { directory :: Bool + -- ^ Set @O_DIRECTORY@. + , nofollow :: Bool + -- ^ Set @O_NOFOLLOW@. + , cloexec :: Bool + -- ^ Set @O_CLOEXEC@. + } + deriving (Show, Eq) + +-- | Default 'OpenPathFlags': +-- +-- - 'directory' is @False@. +-- - 'nofollow' is @False@. +-- - 'cloexec' is @True@. +defaultOpenPathFlags :: OpenPathFlags +defaultOpenPathFlags = OpenPathFlags { directory = False + , nofollow = False + , cloexec = True + } + +-- | Perform an action with a path @open@ed using @O_PATH@. +-- +-- The file descriptor provided to the action will be @close@d when the +-- function returns. +-- +-- This internally calls @openat@ with @AT_FDCWD@ and the @O_PATH@ and +-- @O_RDONLY@ flags set, next to any flags specified in the 'OpenPathFlags' +-- argument. +withOpenPath :: (MonadIO m, MonadMask m) + => FilePath -- ^ Path to open. + -> OpenPathFlags -- ^ Flag settings to pass. + -> (Fd -> m a) -- ^ Action to call with a file descriptor to the given path. + -> m a -- ^ Result of the invoked action. +withOpenPath = withOpenPathAt (fromIntegral (#{const AT_FDCWD} :: #{type int})) + +-- | Perform an action with a path @openat@ed using @O_PATH@. +-- +-- Like 'withOpenPath', exposing the @openat@ @dirfd@ argument. +-- +-- The file descriptor provided to the action will be @close@d when the +-- function returns. +-- +-- This internally calls @openat@ with the @O_PATH@ and @O_RDONLY@ flags set, +-- next to any flags specified in the 'OpenPathFlags' argument. +withOpenPathAt :: (MonadIO m, MonadMask m) + => Fd -- ^ @dirfd@ argument to @openat@. + -> FilePath -- ^ Path to open. + -> OpenPathFlags -- ^ Flag settings to pass. + -> (Fd -> m a) -- ^ Action to call with a file descriptor to the given path. + -> m a -- ^ Result of the invoked action. +withOpenPathAt dirfd pathname flags = bracket (liftIO $ openat dirfd pathname flags') (liftIO . closeFd) + where + flags' = foldr (.|.) 0 [ #{const O_PATH} + , #{const O_RDONLY} + , if directory flags then #{const O_DIRECTORY} else 0 + , if nofollow flags then #{const O_NOFOLLOW} else 0 + , if cloexec flags then #{const O_CLOEXEC} else 0 + ] diff --git a/internal/System/Landlock/Rules.hsc b/internal/System/Landlock/Rules.hsc new file mode 100644 --- /dev/null +++ b/internal/System/Landlock/Rules.hsc @@ -0,0 +1,66 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE StandaloneDeriving #-} + +module System.Landlock.Rules ( + Rule + , RuleType(..) + , ruleType + , pathBeneath + , AccessFsFlag(..) + ) where + +#include +#include + +import Data.Int (Int32) +import Data.Word (Word32, Word64) +import Foreign.Storable (Storable(..)) +import System.Posix.Types (Fd) + +import System.Landlock.Flags (AccessFsFlag(..), accessFsFlagToBit, fromBits, toBits) + +-- | Kind of 'Rule's. +data RuleType = PathBeneath + +-- | A rule enforced by Landlock, to be registered using 'System.Landlock.addRule'. +-- +-- 'Rule's can be constructed using the relevant functions, like 'pathBeneath'. +data Rule (a :: RuleType) where + PathBeneathRule :: [AccessFsFlag] -> Fd -> Rule 'PathBeneath + +deriving instance Show (Rule a) +deriving instance Eq (Rule a) + +-- | Retrieve the @enum landlock_rule_type@ value of a given 'Rule'. +ruleType :: Rule a -> #{type enum landlock_rule_type} +ruleType = \case + PathBeneathRule{} -> #{const LANDLOCK_RULE_PATH_BENEATH} + +instance Storable (Rule 'PathBeneath) where + sizeOf _ = #{size struct landlock_path_beneath_attr} + alignment _ = #{alignment struct landlock_path_beneath_attr} + peek ptr = do + allowedAccess <- #{peek struct landlock_path_beneath_attr, allowed_access} ptr :: IO #{type __u64} + parentFd <- #{peek struct landlock_path_beneath_attr, parent_fd} ptr :: IO #{type __s32} + return $ PathBeneathRule (fromBits allowedAccess accessFsFlagToBit) (fromIntegral parentFd) + poke ptr (PathBeneathRule flags fd) = do + let allowedAccess = toBits flags accessFsFlagToBit :: #{type __u64} + parentFd = fromIntegral fd :: #{type __s32} + #{poke struct landlock_path_beneath_attr, allowed_access} ptr allowedAccess + #{poke struct landlock_path_beneath_attr, parent_fd} ptr parentFd + +-- | Construct a path hierarchy rule definition. +-- +-- This corresponds to a rule of type @LANDLOCK_RULE_PATH_BENEATH@, with +-- attributes defined in a @struct landlock_path_beneath_attr@. +pathBeneath :: Fd -- ^ File descriptor, preferably opened with @O_PATH@, which + -- identifies the parent directory of a file hierarchy, or + -- just a file. + -> [AccessFsFlag] -- ^ Allowed actions for this file hierarchy + -- (cf. 'AccessFsFlag'). + -> Rule 'PathBeneath +pathBeneath fd flags = PathBeneathRule flags fd diff --git a/internal/System/Landlock/Syscalls.hsc b/internal/System/Landlock/Syscalls.hsc new file mode 100644 --- /dev/null +++ b/internal/System/Landlock/Syscalls.hsc @@ -0,0 +1,85 @@ +module System.Landlock.Syscalls ( + LandlockRulesetAttr(..) + , landlock_create_ruleset + , landlock_add_rule + , landlock_restrict_self + , prctl + ) where + +#include +#include +#include +#include + +#include "hs-landlock.h" + +import Data.Int (Int32, Int64) +import Data.Word (Word32, Word64) +import Foreign.C.Error (throwErrnoIfMinus1) +import Foreign.Ptr (Ptr) +import Foreign.Storable (Storable(..)) + +data LandlockRulesetAttr = LandlockRulesetAttr { landlockRulesetAttrHandledAccessFs :: #{type __u64} } + deriving (Show, Eq) + +instance Storable LandlockRulesetAttr where + sizeOf _ = #{size struct landlock_ruleset_attr} + alignment _ = #{alignment struct landlock_ruleset_attr} + peek ptr = LandlockRulesetAttr <$> #{peek struct landlock_ruleset_attr, handled_access_fs} ptr + poke ptr attr = do + #{poke struct landlock_ruleset_attr, handled_access_fs} ptr (landlockRulesetAttrHandledAccessFs attr) + +foreign import ccall unsafe "hs-landlock.h landlock_create_ruleset" + _landlock_create_ruleset :: Ptr LandlockRulesetAttr + -> #{type size_t} + -> #{type __u32} + -> IO #{type long} + +landlock_create_ruleset :: Ptr LandlockRulesetAttr + -> #{type size_t} + -> #{type __u32} + -> IO #{type long} +landlock_create_ruleset attr size flags = + throwErrnoIfMinus1 "landlock_create_ruleset" $ _landlock_create_ruleset attr size flags + +foreign import ccall unsafe "hs-landlock.h landlock_add_rule" + _landlock_add_rule :: #{type int} + -> #{type enum landlock_rule_type} + -> Ptr a + -> #{type __u32} + -> IO #{type long} + +landlock_add_rule :: #{type int} + -> #{type enum landlock_rule_type} + -> Ptr a + -> #{type __u32} + -> IO #{type long} +landlock_add_rule ruleset_fd rule_type rule_attr flags = + throwErrnoIfMinus1 "landlock_add_rule" $ _landlock_add_rule ruleset_fd rule_type rule_attr flags + +foreign import ccall unsafe "hs-landlock.h landlock_restrict_self" + _landlock_restrict_self :: #{type int} + -> #{type __u32} + -> IO #{type long} + +landlock_restrict_self :: #{type int} + -> #{type __u32} + -> IO #{type long} +landlock_restrict_self ruleset_fd flags = + throwErrnoIfMinus1 "landlock_restrict_self" $ _landlock_restrict_self ruleset_fd flags + +foreign import ccall unsafe "sys/prctl.h prctl" + _prctl :: #{type int} + -> #{type unsigned long} + -> #{type unsigned long} + -> #{type unsigned long} + -> #{type unsigned long} + -> IO #{type int} +prctl :: #{type int} + -> #{type unsigned long} + -> #{type unsigned long} + -> #{type unsigned long} + -> #{type unsigned long} + -> IO #{type int} +prctl option arg2 arg3 arg4 arg5 = + throwErrnoIfMinus1 "prctl" $ _prctl option arg2 arg3 arg4 arg5 diff --git a/internal/System/Landlock/Version.hsc b/internal/System/Landlock/Version.hsc new file mode 100644 --- /dev/null +++ b/internal/System/Landlock/Version.hsc @@ -0,0 +1,15 @@ +module System.Landlock.Version ( + Version(..) + , version1 + ) where + +import Data.Int (Int64) + +-- | Representation of a Landlock ABI version as reported by the kernel. +newtype Version = Version { getVersion :: #{type long} } + deriving (Show, Eq, Ord) + +-- All ABI versions supported by this library should be exposed as a value. +-- | ABI version 1. +version1 :: Version +version1 = Version 1 diff --git a/landlock.cabal b/landlock.cabal new file mode 100644 --- /dev/null +++ b/landlock.cabal @@ -0,0 +1,102 @@ +Cabal-Version: 2.2 +Build-Type: Simple + +Name: landlock +Version: 0.1.0.0 +Synopsis: Haskell bindings for the Linux Landlock API +Description: + 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 and its + . +Homepage: https://github.com/NicolasT/landlock-hs +Bug-Reports: https://github.com/NicolasT/landlock-hs/issues +License: BSD-3-Clause +License-File: LICENSE +Author: Nicolas Trangez +Maintainer: ikke@nicolast.be +Copyright: (c) 2022 Nicolas Trangez +Category: System +Stability: alpha + +Extra-Source-Files: + CHANGELOG.md + README.md + cbits/hs-landlock.h + +Tested-With: GHC == 8.10.5 + +Source-Repository head + Type: git + Location: https://github.com/NicolasT/landlock-hs.git + Branch: main + +Library + Exposed-Modules: System.Landlock + Build-Depends: landlock-internal + , base ^>=4.14.2.0 + , exceptions ^>=0.10.4 + , unix ^>=2.7.2.2 + Build-Tool-Depends: hsc2hs:hsc2hs + Hs-Source-Dirs: src + Default-Language: Haskell2010 + Other-Extensions: EmptyCase + EmptyDataDeriving + FlexibleContexts + LambdaCase + RankNTypes + Ghc-Options: -Wall + +Library landlock-internal + Exposed-Modules: System.Landlock.Flags + , System.Landlock.OpenPath + , System.Landlock.Rules + , System.Landlock.Syscalls + , System.Landlock.Version + Include-Dirs: cbits + C-Sources: cbits/hs-landlock.c + Cc-Options: -Wall + Build-Depends: base + , exceptions + , unix + Build-Tool-Depends: hsc2hs:hsc2hs + Hs-Source-Dirs: internal + Default-Language: Haskell2010 + Other-Extensions: DataKinds + FlexibleInstances + GADTs + KindSignatures + LambdaCase + StandaloneDeriving + Ghc-Options: -Wall + +Test-Suite landlock-test + Type: exitcode-stdio-1.0 + Hs-Source-Dirs: test + Main-Is: Main.hs + Build-Depends: landlock + , landlock-internal + , base + , filepath ^>=1.4.2.1 + , process ^>=1.6.9.0 + , QuickCheck ^>=2.14.2 + , tasty ^>=1.4.1 + , tasty-expected-failure ^>=0.12.3 + , tasty-hunit ^>=0.10.0.3 + , tasty-quickcheck ^>=0.10.1.2 + Default-Language: Haskell2010 + Other-Extensions: DataKinds + FlexibleInstances + LambdaCase + ScopedTypeVariables + TypeApplications + Ghc-Options: -Wall diff --git a/src/System/Landlock.hsc b/src/System/Landlock.hsc new file mode 100644 --- /dev/null +++ b/src/System/Landlock.hsc @@ -0,0 +1,249 @@ +{-# 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 + +#define _GNU_SOURCE + +#include +#include + +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 = Version <$> landlock_create_ruleset nullPtr 0 #{const LANDLOCK_CREATE_RULESET_VERSION} + +-- | Check whether Landlock is supported and enabled on the running system. +isSupported :: IO Bool +isSupported = handleJust unsupportedOperation (\() -> return False) $ do + void abiVersion + return True + where + unsupportedOperation exc = if isUnsupportedOperationError exc then Just () else Nothing + isUnsupportedOperationError = isUnsupportedOperationErrorType . ioeGetErrorType + isUnsupportedOperationErrorType = (== UnsupportedOperation) + +-- | Ruleset attributes. +-- +-- This represents a @struct landlock_ruleset_attr@ as passed to +-- @landlock_create_ruleset@. +data RulesetAttr = RulesetAttr { 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 (Show, 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 (Show, Eq, Enum, Bounded) + +-- | Handle to a Landlock ruleset. Use 'addRule' to register new rules. +newtype LandlockFd = LandlockFd { unLandlockFd :: Fd } + deriving (Show, Eq) + +createRuleset :: RulesetAttr -> [CreateRulesetFlag] -> IO LandlockFd +createRuleset attr flags = with attr' $ \attrp -> wrap <$> landlock_create_ruleset attrp (fromIntegral $ sizeOf attr') flags' + where + wrap = LandlockFd . fromIntegral + attr' = LandlockRulesetAttr { landlockRulesetAttrHandledAccessFs = handledAccessFs } + handledAccessFs = toBits (rulesetAttrHandledAccessFs attr) accessFsFlagToBit + flags' = toBits flags $ \case + CreateRulesetVersion -> #{const LANDLOCK_CREATE_RULESET_VERSION} + +-- | 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 (Show, Eq) + +restrictSelf :: LandlockFd -> [RestrictSelfFlag] -> IO () +restrictSelf fd flags = + void $ landlock_restrict_self (fromIntegral $ unLandlockFd fd) flags' + where + flags' = toBits flags $ \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 attr createRulesetFlags restrictSelfFlags act = + bracket (liftIO $ createRuleset attr createRulesetFlags) (liftIO . closeFd . unLandlockFd) $ \fd -> do + res <- act (addRule fd) + liftIO $ do + void $ prctl #{const PR_SET_NO_NEW_PRIVS} 1 0 0 0 + restrictSelf fd restrictSelfFlags + return 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 (Show, 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 fd rule flags = liftIO $ with rule $ \ruleAttrp -> + void $ landlock_add_rule (fromIntegral $ unLandlockFd fd) (ruleType rule) ruleAttrp flags' + where + flags' = toBits flags $ \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) +-- @ diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Main (main) where + +import Control.Exception.Base (handleJust) +import Control.Monad (unless) +import Data.List (nub, sort) +import Data.Proxy (Proxy(Proxy)) +import Foreign.Marshal.Alloc (alloca) +import Foreign.Storable (Storable, peek, poke) +import System.Environment (lookupEnv) +import System.Exit (ExitCode(..)) +import System.FilePath (()) +import System.IO (IOMode(..), withFile) +import System.IO.Error (isPermissionError) +import System.Posix.Types (Fd) +import System.Process (CreateProcess(..), proc, readCreateProcessWithExitCode) + +import Test.QuickCheck.Monadic (assert, monadicIO, run) +import Test.Tasty (TestTree, defaultMain, testGroup) +import Test.Tasty.ExpectedFailure (expectFailBecause) +import Test.Tasty.HUnit ((@?), (@=?), (@?=), testCase, testCaseSteps) +import Test.Tasty.QuickCheck as QC + +import System.Landlock (AccessFsFlag(..), RulesetAttr(..), OpenPathFlags(..), abiVersion, accessFsFlags, defaultOpenPathFlags, isSupported, landlock, version1, withOpenPath) +import System.Landlock.Rules (Rule, RuleType(..), pathBeneath) +import System.Landlock.Syscalls (LandlockRulesetAttr(..)) + +-- This test-suite is a bit "weird". We want to test various privilege-related +-- functions. Now, whenever we drop some privileges, we can't (and shouldn't be +-- able to) regain these later. Hence, all tests which drop privileges *must +-- run in a different process*. This sounds simple: just `fork`, run the test +-- in the subprocess, and wait for it to exit. However, this doesn't work that +-- well in a GHC world, where `forkProcess` should always immediately `exec` +-- something else: running Haskell code after `forkProcess` can lock up +-- indefinitely. +-- So, instead of using a simple `fork`, this test executable is used in two +-- ways: either as-is, in which case Tasty is used to run a bunch of tests, +-- or with the `LANDLOCK_TEST` environment variable set. If the latter is +-- set, the Tasty test-suite won't be executed, but instead a specific test +-- will run. This way, the Tasty test-suite can run this very same binary +-- in a different environment to run test scenarios. + +landlockTestEnvironmentVariable :: String +landlockTestEnvironmentVariable = "LANDLOCK_TEST" + +main :: IO () +main = lookupEnv "LANDLOCK_TEST" >>= \case + Nothing -> do + hasLandlock <- isSupported + defaultMain (tests hasLandlock) + Just testName -> case lookup testName functionalTestCases of + Nothing -> fail $ "Unknown test: " ++ testName + Just act -> act + +tests :: Bool -> TestTree +tests hasLandlock = testGroup "Tests" [ + properties + , (if hasLandlock then id else expectFailBecause "Landlock not supported") functionalTests + ] + +properties :: TestTree +properties = testGroup "Properties" [ + storable "LandlockRulesetAttr" (Proxy @LandlockRulesetAttr) + , storable "Rule 'PathBeneath" (Proxy @(Rule 'PathBeneath)) + ] + +storable :: forall proxy a. (Eq a, Show a, Arbitrary a, Storable a) => String -> proxy a -> TestTree +storable name _ = testGroup ("Storable for " ++ name) [ + QC.testProperty "peek . poke == id" $ + \a -> monadicIO $ do + a' <- run $ alloca $ \ptr -> do + poke ptr (a :: a) + peek ptr + assert $ a' == a + ] + +instance Arbitrary LandlockRulesetAttr where + arbitrary = LandlockRulesetAttr <$> arbitrary + +instance Arbitrary (Rule 'PathBeneath) where + arbitrary = pathBeneath <$> fmap (fromIntegral :: Int -> Fd) arbitrary + <*> fmap (nub . sort) arbitrary + +instance Arbitrary AccessFsFlag where + arbitrary = arbitraryBoundedEnum + + +functionalTests :: TestTree +functionalTests = testGroup "Functional Tests" $ [ + testCase "abiVersion >= 1" $ do + v <- abiVersion + v >= version1 @? "Unexpected version" + , testCase "abiVersion is idempotent" $ do + v1 <- abiVersion + v2 <- abiVersion + v1 @=? v2 + ] ++ map (\(name, _) -> testCaseSteps name (`runFunctionalTest` name)) functionalTestCases + where + runFunctionalTest step name = do + step "Running test subprocess" + (rc, stdout, stderr) <- readCreateProcessWithExitCode (mkCreateProcess name) "" + step $ "Test subprocess exited with " ++ show rc + unless (null stdout) $ + step $ "Test subprocess stdout:\n" ++ stdout + unless (null stderr) $ + step $ "Test subprocess stderr:\n" ++ stderr + rc @?= ExitSuccess + + mkCreateProcess name = (proc "/proc/self/exe" []) { env = Just [(landlockTestEnvironmentVariable, name)] + , close_fds = True + } + +functionalTestCases :: [(String, IO ())] +functionalTestCases = [ + ("All v1 restrictions in sandbox", testAllV1Restrictions) + , ("Restrict read, except for /etc", testRestrictReadExceptEtc) + ] + +testAllV1Restrictions :: IO () +testAllV1Restrictions = do + let fn = "/etc/resolv.conf" + try act = withFile fn ReadMode act + + -- First, try to open as-is + try (\_ -> return ()) + + -- Then, sandbox and try again + let Just v1Restrictions = lookup version1 accessFsFlags + landlock (RulesetAttr v1Restrictions) [] [] $ \_ -> return () + catchPermissionDenied $ try $ \_ -> fail $ "Still able to open " ++ fn + +testRestrictReadExceptEtc :: IO () +testRestrictReadExceptEtc = do + let dir = "/etc" + file = dir "passwd" + act = withFile file ReadMode $ \_ -> return () + Just v1Restrictions = lookup version1 accessFsFlags + + act + + landlock (RulesetAttr v1Restrictions) [] [] $ \addRule -> do + withOpenPath dir defaultOpenPathFlags { directory = True } $ \fd -> do + addRule (pathBeneath fd [AccessFsReadFile, AccessFsReadDir, AccessFsExecute]) [] + + act + +catchPermissionDenied :: IO () -> IO () +catchPermissionDenied = handleJust (\exc -> if isPermissionError exc then Just () else Nothing) return