landlock (empty) → 0.1.0.0
raw patch · 14 files changed
+994/−0 lines, 14 filesdep +QuickCheckdep +basedep +exceptionssetup-changed
Dependencies added: QuickCheck, base, exceptions, filepath, landlock, process, tasty, tasty-expected-failure, tasty-hunit, tasty-quickcheck, unix
Files
- CHANGELOG.md +5/−0
- LICENSE +29/−0
- README.md +15/−0
- Setup.hs +2/−0
- cbits/hs-landlock.c +33/−0
- cbits/hs-landlock.h +26/−0
- internal/System/Landlock/Flags.hsc +119/−0
- internal/System/Landlock/OpenPath.hsc +93/−0
- internal/System/Landlock/Rules.hsc +66/−0
- internal/System/Landlock/Syscalls.hsc +85/−0
- internal/System/Landlock/Version.hsc +15/−0
- landlock.cabal +102/−0
- src/System/Landlock.hsc +249/−0
- test/Main.hs +155/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for landlock++## 0.1.0.0 -- 2022-08-18++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -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.
+ README.md view
@@ -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).
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cbits/hs-landlock.c view
@@ -0,0 +1,33 @@+#define _GNU_SOURCE++#include <stddef.h>+#include <unistd.h>+#include <linux/landlock.h>+#include <sys/syscall.h>+#include <sys/types.h>++#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
+ cbits/hs-landlock.h view
@@ -0,0 +1,26 @@+#ifndef _HS_LANDLOCK_H_+#define _HS_LANDLOCK_H_++#include <stddef.h>+#include <linux/landlock.h>+#include <sys/types.h>++#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
+ internal/System/Landlock/Flags.hsc view
@@ -0,0 +1,119 @@+{-# LANGUAGE LambdaCase #-}++module System.Landlock.Flags (+ toBits+ , fromBits+ , AccessFsFlag(..)+ , accessFsFlagToBit+ , accessFsFlags+ , accessFsFlagIsReadOnly+ ) where++#include <linux/landlock.h>++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
+ internal/System/Landlock/OpenPath.hsc view
@@ -0,0 +1,93 @@+module System.Landlock.OpenPath (+ withOpenPath+ , withOpenPathAt+ , OpenPathFlags(..)+ , defaultOpenPathFlags+ ) where++#define _GNU_SOURCE++#include <fcntl.h>++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+ ]
+ internal/System/Landlock/Rules.hsc view
@@ -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 <linux/landlock.h>+#include <sys/types.h>++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
+ internal/System/Landlock/Syscalls.hsc view
@@ -0,0 +1,85 @@+module System.Landlock.Syscalls (+ LandlockRulesetAttr(..)+ , landlock_create_ruleset+ , landlock_add_rule+ , landlock_restrict_self+ , prctl+ ) where++#include <stddef.h>+#include <linux/landlock.h>+#include <sys/prctl.h>+#include <sys/types.h>++#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
+ internal/System/Landlock/Version.hsc view
@@ -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
+ landlock.cabal view
@@ -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 <https://landlock.io/ Landlock homepage> and its+ <https://docs.kernel.org/userspace-api/landlock.html kernel documentation>.+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
+ src/System/Landlock.hsc view
@@ -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 <linux/landlock.h>+#include <sys/prctl.h>++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)+-- @
+ test/Main.hs view
@@ -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