tests: add multi-threaded testcase

When running with the threaded RTS, the test currently fails, which is
expected: we can't support this RTS for now, see #9.

See: #9

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

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

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

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