landlock 0.1.0.0 → 0.2.0.0
raw patch · 9 files changed
+305/−162 lines, 9 filesdep +asyncdep +psxdep ~base
Dependencies added: async, psx
Dependency ranges changed: base
Files
- CHANGELOG.md +14/−0
- cbits/hs-landlock.c +11/−1
- cbits/hs-landlock.h +6/−0
- internal/System/Landlock/Syscalls.hsc +2/−1
- landlock.cabal +25/−5
- test/Main.hs +0/−155
- test/ThreadedScenario.hs +68/−0
- test/landlock-test-threaded.hs +20/−0
- test/landlock-test.hs +159/−0
CHANGELOG.md view
@@ -1,5 +1,19 @@ # Revision history for landlock +## 0.2.0.0 -- YYYY-mm-dd++* Support `base ^>=4.15` and `base ^>=4.16`, tested in CI using GHC 9.0.2 and+ GHC 9.2.2.++* Add a dependency on `psx` to avoid `setxid`-style security issues.++ See `test/ThreadedScenario.hs` for a scenario which triggers the+ aforementioned security issue, which needs a Glibc `setxid`-style+ work-around. This scenario is executed by the new `landlock-test-threaded`+ test-suite.++ See https://github.com/NicolasT/landlock-hs/issues/9 for more background.+ ## 0.1.0.0 -- 2022-08-18 * First version. Released on an unsuspecting world.
cbits/hs-landlock.c view
@@ -6,6 +6,8 @@ #include <sys/syscall.h> #include <sys/types.h> +#include <hs-psx.h>+ #include "hs-landlock.h" #ifndef landlock_create_ruleset@@ -28,6 +30,14 @@ #ifndef landlock_restrict_self long landlock_restrict_self(const int ruleset_fd, const __u32 flags) {- return syscall(__NR_landlock_restrict_self, ruleset_fd, flags);+ return hs_psx_syscall3(__NR_landlock_restrict_self, ruleset_fd, flags, 0); } #endif++int hs_landlock_prctl(int option,+ unsigned long arg2,+ unsigned long arg3,+ unsigned long arg4,+ unsigned long arg5) {+ return hs_psx_syscall6(__NR_prctl, option, arg2, arg3, arg4, arg5, 0);+}
cbits/hs-landlock.h view
@@ -19,6 +19,12 @@ long landlock_restrict_self(const int ruleset_fd, const __u32 flags); +int hs_landlock_prctl(int option,+ unsigned long arg2,+ unsigned long arg3,+ unsigned long arg4,+ unsigned long arg5);+ #ifdef __cplusplus } #endif
internal/System/Landlock/Syscalls.hsc view
@@ -68,13 +68,14 @@ landlock_restrict_self ruleset_fd flags = throwErrnoIfMinus1 "landlock_restrict_self" $ _landlock_restrict_self ruleset_fd flags -foreign import ccall unsafe "sys/prctl.h prctl"+foreign import ccall unsafe "hs-landlock.h hs_landlock_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}
landlock.cabal view
@@ -2,7 +2,7 @@ Build-Type: Simple Name: landlock-Version: 0.1.0.0+Version: 0.2.0.0 Synopsis: Haskell bindings for the Linux Landlock API Description: This library exposes Haskell bindings for the Linux kernel Landlock API.@@ -33,17 +33,20 @@ README.md cbits/hs-landlock.h -Tested-With: GHC == 8.10.5+Tested-With: GHC ==8.10.5+ , GHC ==9.0.2+ , GHC ==9.2.2 Source-Repository head Type: git Location: https://github.com/NicolasT/landlock-hs.git+ Subdir: landlock Branch: main Library Exposed-Modules: System.Landlock Build-Depends: landlock-internal- , base ^>=4.14.2.0+ , base ^>=4.14.2.0 || ^>=4.15 || ^>=4.16 , exceptions ^>=0.10.4 , unix ^>=2.7.2.2 Build-Tool-Depends: hsc2hs:hsc2hs@@ -65,7 +68,8 @@ Include-Dirs: cbits C-Sources: cbits/hs-landlock.c Cc-Options: -Wall- Build-Depends: base+ Build-Depends: psx ^>=0.1+ , base , exceptions , unix Build-Tool-Depends: hsc2hs:hsc2hs@@ -82,10 +86,12 @@ Test-Suite landlock-test Type: exitcode-stdio-1.0 Hs-Source-Dirs: test- Main-Is: Main.hs+ Main-Is: landlock-test.hs+ Other-Modules: ThreadedScenario Build-Depends: landlock , landlock-internal , base+ , async ^>=2.2.3 , filepath ^>=1.4.2.1 , process ^>=1.6.9.0 , QuickCheck ^>=2.14.2@@ -100,3 +106,17 @@ ScopedTypeVariables TypeApplications Ghc-Options: -Wall++Test-Suite landlock-test-threaded+ Type: exitcode-stdio-1.0+ Hs-Source-Dirs: test+ Main-Is: landlock-test-threaded.hs+ Other-Modules: ThreadedScenario+ Build-Depends: landlock+ , base+ , async ^>=2.2.3+ , tasty ^>=1.4.1+ , tasty-expected-failure ^>=0.12.3+ , tasty-hunit ^>=0.10.0.3+ Default-Language: Haskell2010+ Ghc-Options: -Wall -threaded -with-rtsopts -N2
− test/Main.hs
@@ -1,155 +0,0 @@-{-# 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
+ test/ThreadedScenario.hs view
@@ -0,0 +1,68 @@+module ThreadedScenario (scenario) where++import Control.Concurrent.Async (Async, wait)+import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)+import Control.Exception.Base (handleJust)+import System.IO (IOMode(ReadMode), withFile)+import System.IO.Error (isPermissionError)+import System.Posix.Types (CPid(..))++import Test.Tasty (TestTree)+import Test.Tasty.HUnit (assertFailure, testCaseSteps)++import System.Landlock (AccessFsFlag(..), RulesetAttr(..), landlock)++foreign import ccall unsafe "unistd.h gettid"+ gettid :: IO CPid++scenario :: (IO () -> (Async () -> IO ()) -> IO ()) -> TestTree+scenario fn = testCaseSteps "Multithreaded Scenario" (scenario' fn)++scenario' :: (IO () -> (Async () -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()+scenario' withAsync step = do+ step "Starting scenario"++ mainTid <- gettid+ step $ "Main TID = " ++ show mainTid++ tidMVar <- newEmptyMVar+ continueMVar <- newEmptyMVar++ step "Launching thread"+ withAsync (thread tidMVar continueMVar) $ \child -> do+ _ <- takeMVar tidMVar++ step "Setting up Landlock sandbox"+ let flags = [AccessFsReadFile]+ landlock (RulesetAttr flags) [] [] $ \_ -> return ()++ step "Assert file not readable from main thread"+ assertFileNotReadable "main"+ step "Success"++ step "Letting thread continue"+ putMVar continueMVar ()++ step "Waiting for thread to exit"+ wait child++ where+ thread tidMVar continueMVar = do+ step "Running in thread"++ tid <- gettid+ step $ "Thread TID = " ++ show tid+ putMVar tidMVar tid++ step "Waiting for the signal..."+ () <- takeMVar continueMVar+ step "Received signal, continuing"++ step "Assert file not readable from thread"+ assertFileNotReadable "thread"+ step "Success"++ file = "/etc/resolv.conf"+ assertFileNotReadable env = handleJust permissionError return $ withFile file ReadMode $ \_ ->+ assertFailure $ "Still able to open file " ++ file ++ " in " ++ env+ permissionError exc = if isPermissionError exc then Just () else Nothing
+ test/landlock-test-threaded.hs view
@@ -0,0 +1,20 @@+module Main (main) where++import Control.Concurrent.Async (withAsyncBound)++import Test.Tasty (defaultMain, testGroup)+import Test.Tasty.ExpectedFailure (expectFailBecause)++import System.Landlock (isSupported)++import ThreadedScenario (scenario)++main :: IO ()+main = do+ supported <- isSupported+ let scenario' = scenario withAsyncBound+ defaultMain $ testGroup "Threaded" [+ if supported+ then scenario'+ else expectFailBecause "Landlock not supported" scenario'+ ]
+ test/landlock-test.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++{-# OPTIONS_GHC -Wno-orphans #-}++module Main (main) where++import Control.Concurrent.Async (withAsync)+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(..))++import ThreadedScenario (scenario)++-- 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+ , (if hasLandlock then id else expectFailBecause "Landlock not supported") (scenario withAsync)+ ]++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