diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/cbits/hs-landlock.c b/cbits/hs-landlock.c --- a/cbits/hs-landlock.c +++ b/cbits/hs-landlock.c @@ -6,6 +6,8 @@ #include #include +#include + #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); +} diff --git a/cbits/hs-landlock.h b/cbits/hs-landlock.h --- a/cbits/hs-landlock.h +++ b/cbits/hs-landlock.h @@ -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 diff --git a/internal/System/Landlock/Syscalls.hsc b/internal/System/Landlock/Syscalls.hsc --- a/internal/System/Landlock/Syscalls.hsc +++ b/internal/System/Landlock/Syscalls.hsc @@ -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} diff --git a/landlock.cabal b/landlock.cabal --- a/landlock.cabal +++ b/landlock.cabal @@ -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 diff --git a/test/Main.hs b/test/Main.hs deleted file mode 100644 --- a/test/Main.hs +++ /dev/null @@ -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 diff --git a/test/ThreadedScenario.hs b/test/ThreadedScenario.hs new file mode 100644 --- /dev/null +++ b/test/ThreadedScenario.hs @@ -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 diff --git a/test/landlock-test-threaded.hs b/test/landlock-test-threaded.hs new file mode 100644 --- /dev/null +++ b/test/landlock-test-threaded.hs @@ -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' + ] diff --git a/test/landlock-test.hs b/test/landlock-test.hs new file mode 100644 --- /dev/null +++ b/test/landlock-test.hs @@ -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