diff options
| -rw-r--r-- | erebos-tester.cabal | 38 | ||||
| -rw-r--r-- | src/Main.hs | 4 | ||||
| -rw-r--r-- | src/Wrapper.hs | 45 | ||||
| -rw-r--r-- | src/main.c | 81 |
4 files changed, 92 insertions, 76 deletions
diff --git a/erebos-tester.cabal b/erebos-tester.cabal index a6b3b70..f900823 100644 --- a/erebos-tester.cabal +++ b/erebos-tester.cabal @@ -30,10 +30,12 @@ source-repository head type: git location: git://erebosprotocol.net/tester -common common +executable erebos-tester ghc-options: -Wall -fdefer-typed-holes + -threaded + -no-hs-main if flag(ci) ghc-options: @@ -41,36 +43,6 @@ common common -- sometimes needed for backward/forward compatibility: -Wno-error=unused-imports - build-depends: - base ^>= { 4.15, 4.16, 4.17, 4.18, 4.19, 4.20 }, - -executable erebos-tester - import: common - ghc-options: - -- disable interval timer to avoid spawing thread that breaks unshare(CLONE_NEWUSER) - -with-rtsopts=-V0 - if impl(ghc >= 9.8) - ghc-options: - -- no multithreading is allowed for unshare(CLONE_NEWUSER) - -single-threaded - - main-is: Wrapper.hs - -- other-modules: - -- other-extensions: - build-depends: - directory >=1.3 && <1.4, - filepath ^>= { 1.4.2.1, 1.5.2 }, - linux-namespaces^>=0.1.3, - process ^>=1.6.9, - unix >=2.7 && <2.9, - hs-source-dirs: src - default-language: Haskell2010 - -executable erebos-tester-core - import: common - ghc-options: - -threaded - main-is: Main.hs other-modules: Config @@ -94,6 +66,9 @@ executable erebos-tester-core autogen-modules: Paths_erebos_tester + c-sources: + src/main.c + other-extensions: TemplateHaskell default-extensions: @@ -117,6 +92,7 @@ executable erebos-tester-core TypeOperators build-depends: + base ^>= { 4.15, 4.16, 4.17, 4.18, 4.19, 4.20 }, bytestring ^>= { 0.10, 0.11, 0.12 }, containers ^>= { 0.6.2.1, 0.7 }, directory ^>=1.3.6.0, diff --git a/src/Main.hs b/src/Main.hs index 42b2e5b..01bb766 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -157,3 +157,7 @@ main = do ok <- allM (uncurry $ runTest out $ optTest opts) $ concat $ replicate (optRepeat opts) $ concat tests when (not ok) exitFailure + +foreign export ccall testerMain :: IO () +testerMain :: IO () +testerMain = main diff --git a/src/Wrapper.hs b/src/Wrapper.hs deleted file mode 100644 index 544e37c..0000000 --- a/src/Wrapper.hs +++ /dev/null @@ -1,45 +0,0 @@ -module Main where - -import Control.Monad - -import GHC.Environment - -import System.Directory -import System.Environment -import System.FilePath -import System.Linux.Namespaces -import System.Posix.Process -import System.Posix.User -import System.Process - -main :: IO () -main = do - -- we must get uid/gid before unshare - uid <- getEffectiveUserID - gid <- getEffectiveGroupID - - unshare [User, Network, Mount] - writeUserMappings Nothing [UserMapping 0 uid 1] - writeGroupMappings Nothing [GroupMapping 0 gid 1] True - - -- needed for creating /run/netns - callCommand "mount -t tmpfs tmpfs /run" - - epath <- takeDirectory <$> getExecutablePath -- directory containing executable - fpath <- map takeDirectory . filter (any isPathSeparator) . take 1 <$> getFullArgs - -- directory used for invocation, can differ from above for symlinked executable - - let dirs = concat - [ [ epath ] - , [ epath </> "../../../erebos-tester-core/build/erebos-tester-core" ] - , fpath - ] - - args <- getArgs - mapM_ (\file -> executeFile file False args Nothing) =<< - findExecutablesInDirectories dirs "erebos-tester-core" - when (null fpath) $ - mapM_ (\file -> executeFile file False args Nothing) =<< - findExecutables "erebos-tester-core" - - fail "core binary not found" diff --git a/src/main.c b/src/main.c new file mode 100644 index 0000000..98daf2c --- /dev/null +++ b/src/main.c @@ -0,0 +1,81 @@ +#include "HsFFI.h" + +#if defined(__GLASGOW_HASKELL__) +#include "Main_stub.h" +#endif + +#include <errno.h> +#include <fcntl.h> +#include <sched.h> +#include <stdbool.h> +#include <stdio.h> +#include <string.h> +#include <sys/mount.h> +#include <unistd.h> + +/* + * The unshare call with CLONE_NEWUSER needs to happen before starting + * additional threads, which means before initializing the Haskell RTS. + * To achieve that, replace Haskell main with a custom one here that does + * the unshare work and then executes the Haskell code. + */ + +static bool writeProcSelfFile( const char * file, const char * data, size_t size ) +{ + char path[ 256 ]; + if( snprintf( path, sizeof( path ), "/proc/self/%s", file ) + >= sizeof( path ) ){ + fprintf( stderr, "buffer too small\n" ); + return false; + } + + int fd = open( path, O_WRONLY ); + if( fd < 0 ){ + fprintf( stderr, "failed to open %s: %s", path, strerror( errno )); + return false; + } + + ssize_t written = write( fd, data, size ); + if( written < 0 ) + fprintf( stderr, "failed to write to %s: %s\n", path, strerror( errno )); + + close( fd ); + return written == size; +} + +int main( int argc, char * argv[] ) +{ + uid_t uid = geteuid(); + gid_t gid = getegid(); + unshare( CLONE_NEWUSER | CLONE_NEWNET | CLONE_NEWNS ); + + char buf[ 256 ]; + int len; + + len = snprintf( buf, sizeof( buf ), "%d %d %d\n", 0, uid, 1 ); + if( len >= sizeof( buf ) ){ + fprintf( stderr, "buffer too small\n" ); + return 1; + } + if ( ! writeProcSelfFile( "uid_map", buf, len ) ) + return 1; + + if ( ! writeProcSelfFile( "setgroups", "deny\n", 5 ) ) + return 1; + + len = snprintf( buf, sizeof( buf ), "%d %d %d\n", 0, gid, 1 ); + if( len >= sizeof( buf ) ){ + fprintf( stderr, "buffer too small\n" ); + return 1; + } + if ( ! writeProcSelfFile( "gid_map", buf, len ) ) + return 1; + + mount( "tmpfs", "/run", "tmpfs", 0, "size=4m" ); + + hs_init( &argc, &argv ); + testerMain(); + hs_exit(); + + return 0; +} |