diff --git a/landlock.cabal b/landlock.cabal index 80e02d9..875778e 100644 --- a/landlock.cabal +++ b/landlock.cabal @@ -85,9 +85,11 @@ Test-Suite landlock-test Type: exitcode-stdio-1.0 Hs-Source-Dirs: test 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 @@ -102,3 +104,17 @@ Test-Suite landlock-test 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/ThreadedScenario.hs b/test/ThreadedScenario.hs new file mode 100644 index 0000000..22bc308 --- /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 index 0000000..5956b92 --- /dev/null +++ b/test/landlock-test-threaded.hs @@ -0,0 +1,19 @@ +module Main (main) where + +import Control.Concurrent.Async (withAsyncBound) + +import Test.Tasty (defaultMain) +import Test.Tasty.ExpectedFailure (expectFailBecause, ignoreTestBecause) + +import System.Landlock (isSupported) + +import ThreadedScenario (scenario) + +main :: IO () +main = do + supported <- isSupported + let test = scenario withAsyncBound + defaultMain $ + if supported + then expectFailBecause "landlock_restrict_self is thread-bound" test + else ignoreTestBecause "Landlock not supported" test diff --git a/test/landlock-test.hs b/test/landlock-test.hs index e2b5d96..2514091 100644 --- a/test/landlock-test.hs +++ b/test/landlock-test.hs @@ -8,6 +8,7 @@ module Main (main) where +import Control.Concurrent.Async (withAsync) import Control.Exception.Base (handleJust) import Control.Monad (unless) import Data.List (nub, sort) @@ -32,6 +33,8 @@ import System.Landlock (AccessFsFlag(..), RulesetAttr(..), OpenPathFlags(..), ab 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 @@ -63,6 +66,7 @@ tests :: Bool -> TestTree tests hasLandlock = testGroup "Tests" [ properties , (if hasLandlock then id else expectFailBecause "Landlock not supported") functionalTests + , scenario withAsync ] properties :: TestTree