diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,29 @@ # Revision history for landlock +## 0.2.1.0 -- 2023-02-22 + +* Use vendored `linux/landlock.h` instead of system-provided header during + build. + +* Support Landlock ABI v2 and `LANDLOCK_ACCESS_FS_REFER` as part of it. + +* Support Landlock ABI v3 and `LANDLOCK_ACCESS_FS_TRUNCATE` as part of it. + +* Support GHC 9.4.2 / `base ^>=4.17`. + +* Support `unix ^>=2.8`. + +* Add a new executable,`landlocked`, which permits to run a command in + a sandboxed environment. + +* Add a flag, `landlocked`, which allows to not build the `landlocked` + executable. + +* Use `capi` foreign imports instead of `ccall` using the `CApiFFI` language + extension. + +* Add a Cabal flag, `werror`, to enable compiler `-Werror` and friends. + ## 0.2.0.1 -- 2022-08-24 * Code-wise the same as version 0.2.0.0, but said version was incorrectly diff --git a/README.lhs b/README.lhs new file mode 100644 --- /dev/null +++ b/README.lhs @@ -0,0 +1,118 @@ +# landlock-hs: Haskell bindings for the Linux Landlock API + +This library exposes Haskell bindings for the Linux kernel Landlock API. + +The Linux kernel Landlock API provides unprivileged access control. The goal +of Landlock is to enable to restrict ambient rights (e.g. global filesystem +access) for a set of processes. Because Landlock is a stackable LSM, it makes +possible to create safe security sandboxes as new security layers in addition +to the existing system-wide access-controls. This kind of sandbox is expected +to help mitigate the security impact of bugs or unexpected/malicious +behaviors in user space applications. Landlock empowers any process, +including unprivileged ones, to securely restrict themselves. + +For more information, see the [Landlock homepage](https://landlock.io/) and its +[kernel documentation](https://docs.kernel.org/userspace-api/landlock.html). + +## Example + +Here's a simple example, allowing read-only access to the user's SSH public +key, full access to `tmp` and the ability to read and execute everything in +`/usr`: + +```haskell +import System.Landlock ( + AccessFsFlag(..) + , OpenPathFlags(..) + , RulesetAttr(..) + , abiVersion + , accessFsFlags + , accessFsFlagIsReadOnly + , defaultOpenPathFlags + , isSupported + , landlock + , pathBeneath + , withOpenPath + ) + +import ReadmeUtils + +-- These tests run with a "fake" pre-populated rootfs +-- All files and directories in it are created using the current user, +-- readable, writable and (in case of scripts) executable, so without +-- Landlock, there would be no permission errors. + +main :: IO () +main = withFakeRoot $ \root -> do + -- Check whether Landlock is supported + hasLandlock <- isSupported + + unless hasLandlock $ + fail "Landlock not supported" + + version <- abiVersion + -- Find all FS access flags for the running kernel's ABI version + allFlags <- lookupAccessFsFlags version + let roFlags = filter accessFsFlagIsReadOnly allFlags + + let homeDir = root "home" "user" + publicKey = homeDir ".ssh" "id_ed25519.pub" + privateKey = homeDir ".ssh" "id_ed25519" + tmpDir = root "tmp" + + -- Construct the sandbox, locking down everything by default + landlock (RulesetAttr allFlags) [] [] $ \addRule -> do + -- /tmp is fully accessible + withOpenPath tmpDir defaultOpenPathFlags{ directory = True } $ \tmp -> + addRule (pathBeneath tmp allFlags) [] + + -- SSH public key is readable + withOpenPath publicKey defaultOpenPathFlags $ \key -> + addRule (pathBeneath key [AccessFsReadFile]) [] + + -- (Real) /usr is fully accessible, but read-only (includes executable permissions) + withOpenPath "/usr" defaultOpenPathFlags{ directory = True } $ \usr -> do + addRule (pathBeneath usr roFlags) [] + + -- Can create and write to files in tmp + writeFile (tmpDir "program.log") "Success!" + + -- Can read SSH key + _pubKey <- readFile publicKey + + -- Can execute things in /usr + "Linux\n" <- readProcess ("/usr" "bin" "uname") ["-s"] "" + + -- Can't read SSH private key + assertPermissionDenied $ + readFile privateKey + + -- Can't write to SSH public key + assertPermissionDenied $ + withFile publicKey WriteMode $ \fd -> + hPutStrLn fd "Oops, key gone!" + + -- Can't remove SSH public key + assertPermissionDenied $ + removeFile publicKey + + -- Can't create files in homedir + assertPermissionDenied $ + writeFile (homeDir "whoops.txt") "This file should not exist!" + + -- Can't read files from (real) /etc + assertPermissionDenied $ + readFile ("/etc" "hosts") + + where + lookupAccessFsFlags version = case lookup version accessFsFlags of + -- In a production implementation, we'd lookup the "best matching" flag + -- set, not require an exact match. + Nothing -> fail "Unsupported ABI version" + Just flags -> return flags + + assertPermissionDenied act = handleJust permissionDenied return $ do + _ <- act + fail "Expected permission error" + permissionDenied e = if isPermissionError e then Just () else Nothing +``` diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -13,3 +13,106 @@ For more information, see the [Landlock homepage](https://landlock.io/) and its [kernel documentation](https://docs.kernel.org/userspace-api/landlock.html). + +## Example + +Here's a simple example, allowing read-only access to the user's SSH public +key, full access to `tmp` and the ability to read and execute everything in +`/usr`: + +```haskell +import System.Landlock ( + AccessFsFlag(..) + , OpenPathFlags(..) + , RulesetAttr(..) + , abiVersion + , accessFsFlags + , accessFsFlagIsReadOnly + , defaultOpenPathFlags + , isSupported + , landlock + , pathBeneath + , withOpenPath + ) + +import ReadmeUtils + +-- These tests run with a "fake" pre-populated rootfs +-- All files and directories in it are created using the current user, +-- readable, writable and (in case of scripts) executable, so without +-- Landlock, there would be no permission errors. + +main :: IO () +main = withFakeRoot $ \root -> do + -- Check whether Landlock is supported + hasLandlock <- isSupported + + unless hasLandlock $ + fail "Landlock not supported" + + version <- abiVersion + -- Find all FS access flags for the running kernel's ABI version + allFlags <- lookupAccessFsFlags version + let roFlags = filter accessFsFlagIsReadOnly allFlags + + let homeDir = root "home" "user" + publicKey = homeDir ".ssh" "id_ed25519.pub" + privateKey = homeDir ".ssh" "id_ed25519" + tmpDir = root "tmp" + + -- Construct the sandbox, locking down everything by default + landlock (RulesetAttr allFlags) [] [] $ \addRule -> do + -- /tmp is fully accessible + withOpenPath tmpDir defaultOpenPathFlags{ directory = True } $ \tmp -> + addRule (pathBeneath tmp allFlags) [] + + -- SSH public key is readable + withOpenPath publicKey defaultOpenPathFlags $ \key -> + addRule (pathBeneath key [AccessFsReadFile]) [] + + -- (Real) /usr is fully accessible, but read-only (includes executable permissions) + withOpenPath "/usr" defaultOpenPathFlags{ directory = True } $ \usr -> do + addRule (pathBeneath usr roFlags) [] + + -- Can create and write to files in tmp + writeFile (tmpDir "program.log") "Success!" + + -- Can read SSH key + _pubKey <- readFile publicKey + + -- Can execute things in /usr + "Linux\n" <- readProcess ("/usr" "bin" "uname") ["-s"] "" + + -- Can't read SSH private key + assertPermissionDenied $ + readFile privateKey + + -- Can't write to SSH public key + assertPermissionDenied $ + withFile publicKey WriteMode $ \fd -> + hPutStrLn fd "Oops, key gone!" + + -- Can't remove SSH public key + assertPermissionDenied $ + removeFile publicKey + + -- Can't create files in homedir + assertPermissionDenied $ + writeFile (homeDir "whoops.txt") "This file should not exist!" + + -- Can't read files from (real) /etc + assertPermissionDenied $ + readFile ("/etc" "hosts") + + where + lookupAccessFsFlags version = case lookup version accessFsFlags of + -- In a production implementation, we'd lookup the "best matching" flag + -- set, not require an exact match. + Nothing -> fail "Unsupported ABI version" + Just flags -> return flags + + assertPermissionDenied act = handleJust permissionDenied return $ do + _ <- act + fail "Expected permission error" + permissionDenied e = if isPermissionError e then Just () else Nothing +``` diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/bin/landlocked.hs b/bin/landlocked.hs new file mode 100644 --- /dev/null +++ b/bin/landlocked.hs @@ -0,0 +1,180 @@ +module Main (main) where + +import Control.Applicative (many, (<**>)) +import Control.Exception.Base (displayException, handleJust) +import Control.Monad (forM_, unless) +import Data.List (intercalate, sortOn) +import Data.Maybe (listToMaybe) +import Data.Ord (Down (Down)) +import Data.Version (versionBranch) +import Options.Applicative + ( ParserInfo, + ReadM, + action, + execParser, + footer, + fullDesc, + header, + help, + helper, + hidden, + info, + infoOption, + long, + metavar, + noIntersperse, + option, + progDesc, + str, + strArgument, + ) +import qualified Paths_landlock as Paths +import System.Exit (ExitCode (ExitFailure), exitWith) +import System.IO (hPutStrLn, stderr) +import System.IO.Error (isDoesNotExistError, isPermissionError) +import System.Landlock + ( AccessFsFlag, + RulesetAttr (..), + Version, + abiVersion, + accessFsFlagIsReadOnly, + accessFsFlags, + defaultOpenPathFlags, + getVersion, + isSupported, + landlock, + pathBeneath, + withOpenPath, + ) +import System.Posix.Process (executeFile) + +main :: IO () +main = do + hasLandlock <- isSupported + unless hasLandlock $ do + hPutStrLn stderr "Landlock not supported on this system" + exitWith (ExitFailure 2) + + version <- abiVersion + + (usedVersion, allFlags) <- case lookupAccessFsFlags version of + Nothing -> fail $ "Unable to retrieve file-system access flags for Landlock ABI " ++ show (getVersion version) + Just r -> return r + let roFlags = filter accessFsFlagIsReadOnly allFlags + + args <- execParser (parser version usedVersion) + + landlock (RulesetAttr allFlags) [] [] $ \addRule -> do + forM_ (argsROPaths args) $ \path -> + withOpenPath path defaultOpenPathFlags $ \fd -> + addRule (pathBeneath fd roFlags) [] + + forM_ (argsRWPaths args) $ \path -> + withOpenPath path defaultOpenPathFlags $ \fd -> + addRule (pathBeneath fd allFlags) [] + + handleJust permissionDenied handlePermissionDenied $ + handleJust notFound handleNotFound $ do + _ <- executeFile (argsCommand args) True (argsArguments args) Nothing + fail "executeFile returned" + where + notFound e = if isDoesNotExistError e then Just e else Nothing + handleNotFound e = do + hPutStrLn stderr $ + unlines + [ "Failed to execute command: " ++ displayException e + ] + exitWith (ExitFailure 127) + permissionDenied e = if isPermissionError e then Just e else Nothing + handlePermissionDenied e = do + hPutStrLn stderr $ + unlines + [ "Failed to execute command: " ++ displayException e, + "Hint: access to the binary, the interpreter or shared libraries may be denied." + ] + exitWith (ExitFailure 126) + +data Args = Args + { argsROPaths :: [FilePath], + argsRWPaths :: [FilePath], + argsCommand :: FilePath, + argsArguments :: [String] + } + deriving (Show, Eq) + +parser :: Version -> Version -> ParserInfo Args +parser version usedVersion = + info + (argsParser <**> versionFlag <**> helper) + ( fullDesc + <> noIntersperse + <> progDesc "Execute a command in a sandboxed environment" + <> header + ( unwords + [ "Use landlocked to run a program in a sandboxed environment,", + "restricting access to system resources using the Linux", + "Landlock API." + ] + ) + <> footer + ( unwords + [ "The command binary, its interpreter and any shared", + "libraries must be accessible in the sandbox." + ] + ) + ) + where + argsParser = + Args + <$> many + ( option + filePath + ( long "ro" + <> metavar "PATH" + <> help "Allow read-only access to given file or directory" + <> action "default" + ) + ) + <*> many + ( option + filePath + ( long "rw" + <> metavar "PATH" + <> help "Allow write access to given file or directory" + <> action "default" + ) + ) + <*> strArgument + ( metavar "COMMAND" + <> help "Command to spawn" + <> action "command" + ) + <*> many + ( strArgument + ( metavar "ARG" + <> help "Arguments to pass to spawned command" + ) + ) + versionFlag = + infoOption + versionString + ( long "version" + <> help "Show version information" + <> hidden + ) + versionString = + unlines + [ "landlocked " ++ intercalate "." (map show (versionBranch Paths.version)), + "System Landlock ABI version: " ++ show (getVersion version), + "Using Landlock ABI version: " ++ show (getVersion usedVersion) + ] + +-- This is not really useful. It could be if 'ReaderM' were 'MonadIO' +filePath :: ReadM FilePath +filePath = str + +lookupAccessFsFlags :: Version -> Maybe (Version, [AccessFsFlag]) +lookupAccessFsFlags v = + listToMaybe $ + sortOn (Down . fst) $ + filter (\(v', _) -> v' <= v) accessFsFlags diff --git a/cbits/hs-landlock.c b/cbits/hs-landlock.c --- a/cbits/hs-landlock.c +++ b/cbits/hs-landlock.c @@ -1,38 +1,38 @@ -#define _GNU_SOURCE - #include #include -#include #include #include #include #include "hs-landlock.h" +#include "linux/landlock.h" -#ifndef landlock_create_ruleset -long landlock_create_ruleset(const struct landlock_ruleset_attr *const attr, - const size_t size, - const __u32 flags) { +long hs_landlock_create_ruleset(const struct landlock_ruleset_attr *const attr, + const size_t size, + const __u32 flags) { +#ifdef landlock_create_ruleset + return landlock_create_ruleset(attr, size, flags) +#else return syscall(__NR_landlock_create_ruleset, attr, size, flags); -} #endif +} -#ifndef landlock_add_rule -long landlock_add_rule(const int ruleset_fd, - const enum landlock_rule_type rule_type, - const void *const rule_attr, - const __u32 flags) { +long hs_landlock_add_rule(const int ruleset_fd, + const enum landlock_rule_type rule_type, + const void *const rule_attr, + const __u32 flags) { +#ifdef landlock_add_rule + return landlock_add_rule(ruleset_fd, rule_type, rule_attr, flags) +#else return syscall(__NR_landlock_add_rule, ruleset_fd, rule_type, rule_attr, flags); -} #endif +} -#ifndef landlock_restrict_self -long landlock_restrict_self(const int ruleset_fd, - const __u32 flags) { +long hs_landlock_restrict_self(const int ruleset_fd, + const __u32 flags) { return hs_psx_syscall3(__NR_landlock_restrict_self, ruleset_fd, flags, 0); } -#endif int hs_landlock_prctl(int option, unsigned long arg2, diff --git a/cbits/hs-landlock.h b/cbits/hs-landlock.h --- a/cbits/hs-landlock.h +++ b/cbits/hs-landlock.h @@ -2,22 +2,23 @@ #define _HS_LANDLOCK_H_ #include -#include #include +#include "linux/landlock.h" + #ifdef __cplusplus extern "C" { #endif -long landlock_create_ruleset(const struct landlock_ruleset_attr *const attr, - const size_t size, - const __u32 flags); -long landlock_add_rule(const int ruleset_fd, - const enum landlock_rule_type rule_type, - const void *const rule_attr, - const __u32 flags); -long landlock_restrict_self(const int ruleset_fd, - const __u32 flags); +long hs_landlock_create_ruleset(const struct landlock_ruleset_attr *const attr, + const size_t size, + const __u32 flags); +long hs_landlock_add_rule(const int ruleset_fd, + const enum landlock_rule_type rule_type, + const void *const rule_attr, + const __u32 flags); +long hs_landlock_restrict_self(const int ruleset_fd, + const __u32 flags); int hs_landlock_prctl(int option, unsigned long arg2, diff --git a/cbits/linux/GPL-2.0 b/cbits/linux/GPL-2.0 new file mode 100644 --- /dev/null +++ b/cbits/linux/GPL-2.0 @@ -0,0 +1,359 @@ +Valid-License-Identifier: GPL-2.0 +Valid-License-Identifier: GPL-2.0-only +Valid-License-Identifier: GPL-2.0+ +Valid-License-Identifier: GPL-2.0-or-later +SPDX-URL: https://spdx.org/licenses/GPL-2.0.html +Usage-Guide: + To use this license in source code, put one of the following SPDX + tag/value pairs into a comment according to the placement + guidelines in the licensing rules documentation. + For 'GNU General Public License (GPL) version 2 only' use: + SPDX-License-Identifier: GPL-2.0 + or + SPDX-License-Identifier: GPL-2.0-only + For 'GNU General Public License (GPL) version 2 or any later version' use: + SPDX-License-Identifier: GPL-2.0+ + or + SPDX-License-Identifier: GPL-2.0-or-later +License-Text: + + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc. + 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. This +General Public License applies to most of the Free Software +Foundation's software and to any other program whose authors commit to +using it. (Some other Free Software Foundation software is covered by +the GNU Library General Public License instead.) You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must show them these terms so they know their +rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that redistributors of a free +program will individually obtain patent licenses, in effect making the +program proprietary. To prevent this, we have made it clear that any +patent must be licensed for everyone's free use or not licensed at all. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License applies to any program or other work which contains +a notice placed by the copyright holder saying it may be distributed +under the terms of this General Public License. The "Program", below, +refers to any such program or work, and a "work based on the Program" +means either the Program or any derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term "modification".) Each licensee is addressed as "you". + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + + 1. You may copy and distribute verbatim copies of the Program's +source code as you receive it, in any medium, provided that you +conspicuously and appropriately publish on each copy an appropriate +copyright notice and disclaimer of warranty; keep intact all the +notices that refer to this License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. + +You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. + + 2. You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary way, to print or display an + announcement including an appropriate copyright notice and a + notice that there is no warranty (or else, saying that you provide + a warranty) and that users may redistribute the program under + these conditions, and telling the user how to view a copy of this + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: + + a) Accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) + +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + + 5. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 7. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 9. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of this License which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. + + 10. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) year name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, the commands you use may +be called something other than `show w' and `show c'; they could even be +mouse-clicks or menu items--whatever suits your program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the program + `Gnomovision' (which makes passes at compilers) written by James Hacker. + + , 1 April 1989 + Ty Coon, President of Vice + +This General Public License does not permit incorporating your program into +proprietary programs. If your program is a subroutine library, you may +consider it more useful to permit linking proprietary applications with the +library. If this is what you want to do, use the GNU Library General +Public License instead of this License. diff --git a/cbits/linux/Linux-syscall-note b/cbits/linux/Linux-syscall-note new file mode 100644 --- /dev/null +++ b/cbits/linux/Linux-syscall-note @@ -0,0 +1,25 @@ +SPDX-Exception-Identifier: Linux-syscall-note +SPDX-URL: https://spdx.org/licenses/Linux-syscall-note.html +SPDX-Licenses: GPL-2.0, GPL-2.0+, GPL-1.0+, LGPL-2.0, LGPL-2.0+, LGPL-2.1, LGPL-2.1+, GPL-2.0-only, GPL-2.0-or-later +Usage-Guide: + This exception is used together with one of the above SPDX-Licenses + to mark user space API (uapi) header files so they can be included + into non GPL compliant user space application code. + To use this exception add it with the keyword WITH to one of the + identifiers in the SPDX-Licenses tag: + SPDX-License-Identifier: WITH Linux-syscall-note +License-Text: + + NOTE! This copyright does *not* cover user programs that use kernel + services by normal system calls - this is merely considered normal use + of the kernel, and does *not* fall under the heading of "derived work". + Also note that the GPL below is copyrighted by the Free Software + Foundation, but the instance of code that it refers to (the Linux + kernel) is copyrighted by me and others who actually wrote it. + + Also note that the only valid version of the GPL as far as the kernel + is concerned is _this_ particular version of the license (ie v2, not + v2.2 or v3.x or whatever), unless explicitly otherwise stated. + + Linus Torvalds + diff --git a/cbits/linux/landlock.h b/cbits/linux/landlock.h new file mode 100644 --- /dev/null +++ b/cbits/linux/landlock.h @@ -0,0 +1,176 @@ +/* SPDX-License-Identifier: GPL-2.0 WITH Linux-syscall-note */ +/* + * Landlock - User space API + * + * Copyright © 2017-2020 Mickaël Salaün + * Copyright © 2018-2020 ANSSI + */ + +#ifndef _UAPI_LINUX_LANDLOCK_H +#define _UAPI_LINUX_LANDLOCK_H + +#include + +/** + * struct landlock_ruleset_attr - Ruleset definition + * + * Argument of sys_landlock_create_ruleset(). This structure can grow in + * future versions. + */ +struct landlock_ruleset_attr { + /** + * @handled_access_fs: Bitmask of actions (cf. `Filesystem flags`_) + * that is handled by this ruleset and should then be forbidden if no + * rule explicitly allow them: it is a deny-by-default list that should + * contain as much Landlock access rights as possible. Indeed, all + * Landlock filesystem access rights that are not part of + * handled_access_fs are allowed. This is needed for backward + * compatibility reasons. One exception is the + * %LANDLOCK_ACCESS_FS_REFER access right, which is always implicitly + * handled, but must still be explicitly handled to add new rules with + * this access right. + */ + __u64 handled_access_fs; +}; + +/* + * sys_landlock_create_ruleset() flags: + * + * - %LANDLOCK_CREATE_RULESET_VERSION: Get the highest supported Landlock ABI + * version. + */ +/* clang-format off */ +#define LANDLOCK_CREATE_RULESET_VERSION (1U << 0) +/* clang-format on */ + +/** + * enum landlock_rule_type - Landlock rule type + * + * Argument of sys_landlock_add_rule(). + */ +enum landlock_rule_type { + /** + * @LANDLOCK_RULE_PATH_BENEATH: Type of a &struct + * landlock_path_beneath_attr . + */ + LANDLOCK_RULE_PATH_BENEATH = 1, +}; + +/** + * struct landlock_path_beneath_attr - Path hierarchy definition + * + * Argument of sys_landlock_add_rule(). + */ +struct landlock_path_beneath_attr { + /** + * @allowed_access: Bitmask of allowed actions for this file hierarchy + * (cf. `Filesystem flags`_). + */ + __u64 allowed_access; + /** + * @parent_fd: File descriptor, preferably opened with ``O_PATH``, + * which identifies the parent directory of a file hierarchy, or just a + * file. + */ + __s32 parent_fd; + /* + * This struct is packed to avoid trailing reserved members. + * Cf. security/landlock/syscalls.c:build_check_abi() + */ +} __attribute__((packed)); + +/** + * DOC: fs_access + * + * A set of actions on kernel objects may be defined by an attribute (e.g. + * &struct landlock_path_beneath_attr) including a bitmask of access. + * + * Filesystem flags + * ~~~~~~~~~~~~~~~~ + * + * These flags enable to restrict a sandboxed process to a set of actions on + * files and directories. Files or directories opened before the sandboxing + * are not subject to these restrictions. + * + * A file can only receive these access rights: + * + * - %LANDLOCK_ACCESS_FS_EXECUTE: Execute a file. + * - %LANDLOCK_ACCESS_FS_WRITE_FILE: Open a file with write access. Note that + * you might additionally need the %LANDLOCK_ACCESS_FS_TRUNCATE right in order + * to overwrite files with :manpage:`open(2)` using ``O_TRUNC`` or + * :manpage:`creat(2)`. + * - %LANDLOCK_ACCESS_FS_READ_FILE: Open a file with read access. + * - %LANDLOCK_ACCESS_FS_TRUNCATE: Truncate a file with :manpage:`truncate(2)`, + * :manpage:`ftruncate(2)`, :manpage:`creat(2)`, or :manpage:`open(2)` with + * ``O_TRUNC``. Whether an opened file can be truncated with + * :manpage:`ftruncate(2)` is determined during :manpage:`open(2)`, in the + * same way as read and write permissions are checked during + * :manpage:`open(2)` using %LANDLOCK_ACCESS_FS_READ_FILE and + * %LANDLOCK_ACCESS_FS_WRITE_FILE. This access right is available since the + * third version of the Landlock ABI. + * + * A directory can receive access rights related to files or directories. The + * following access right is applied to the directory itself, and the + * directories beneath it: + * + * - %LANDLOCK_ACCESS_FS_READ_DIR: Open a directory or list its content. + * + * However, the following access rights only apply to the content of a + * directory, not the directory itself: + * + * - %LANDLOCK_ACCESS_FS_REMOVE_DIR: Remove an empty directory or rename one. + * - %LANDLOCK_ACCESS_FS_REMOVE_FILE: Unlink (or rename) a file. + * - %LANDLOCK_ACCESS_FS_MAKE_CHAR: Create (or rename or link) a character + * device. + * - %LANDLOCK_ACCESS_FS_MAKE_DIR: Create (or rename) a directory. + * - %LANDLOCK_ACCESS_FS_MAKE_REG: Create (or rename or link) a regular file. + * - %LANDLOCK_ACCESS_FS_MAKE_SOCK: Create (or rename or link) a UNIX domain + * socket. + * - %LANDLOCK_ACCESS_FS_MAKE_FIFO: Create (or rename or link) a named pipe. + * - %LANDLOCK_ACCESS_FS_MAKE_BLOCK: Create (or rename or link) a block device. + * - %LANDLOCK_ACCESS_FS_MAKE_SYM: Create (or rename or link) a symbolic link. + * - %LANDLOCK_ACCESS_FS_REFER: Link or rename a file from or to a different + * directory (i.e. reparent a file hierarchy). This access right is + * available since the second version of the Landlock ABI. This is also the + * only access right which is always considered handled by any ruleset in + * such a way that reparenting a file hierarchy is always denied by default. + * To avoid privilege escalation, it is not enough to add a rule with this + * access right. When linking or renaming a file, the destination directory + * hierarchy must also always have the same or a superset of restrictions of + * the source hierarchy. If it is not the case, or if the domain doesn't + * handle this access right, such actions are denied by default with errno + * set to ``EXDEV``. Linking also requires a ``LANDLOCK_ACCESS_FS_MAKE_*`` + * access right on the destination directory, and renaming also requires a + * ``LANDLOCK_ACCESS_FS_REMOVE_*`` access right on the source's (file or + * directory) parent. Otherwise, such actions are denied with errno set to + * ``EACCES``. The ``EACCES`` errno prevails over ``EXDEV`` to let user space + * efficiently deal with an unrecoverable error. + * + * .. warning:: + * + * It is currently not possible to restrict some file-related actions + * accessible through these syscall families: :manpage:`chdir(2)`, + * :manpage:`stat(2)`, :manpage:`flock(2)`, :manpage:`chmod(2)`, + * :manpage:`chown(2)`, :manpage:`setxattr(2)`, :manpage:`utime(2)`, + * :manpage:`ioctl(2)`, :manpage:`fcntl(2)`, :manpage:`access(2)`. + * Future Landlock evolutions will enable to restrict them. + */ +/* clang-format off */ +#define LANDLOCK_ACCESS_FS_EXECUTE (1ULL << 0) +#define LANDLOCK_ACCESS_FS_WRITE_FILE (1ULL << 1) +#define LANDLOCK_ACCESS_FS_READ_FILE (1ULL << 2) +#define LANDLOCK_ACCESS_FS_READ_DIR (1ULL << 3) +#define LANDLOCK_ACCESS_FS_REMOVE_DIR (1ULL << 4) +#define LANDLOCK_ACCESS_FS_REMOVE_FILE (1ULL << 5) +#define LANDLOCK_ACCESS_FS_MAKE_CHAR (1ULL << 6) +#define LANDLOCK_ACCESS_FS_MAKE_DIR (1ULL << 7) +#define LANDLOCK_ACCESS_FS_MAKE_REG (1ULL << 8) +#define LANDLOCK_ACCESS_FS_MAKE_SOCK (1ULL << 9) +#define LANDLOCK_ACCESS_FS_MAKE_FIFO (1ULL << 10) +#define LANDLOCK_ACCESS_FS_MAKE_BLOCK (1ULL << 11) +#define LANDLOCK_ACCESS_FS_MAKE_SYM (1ULL << 12) +#define LANDLOCK_ACCESS_FS_REFER (1ULL << 13) +#define LANDLOCK_ACCESS_FS_TRUNCATE (1ULL << 14) +/* clang-format on */ + +#endif /* _UAPI_LINUX_LANDLOCK_H */ diff --git a/internal/System/Landlock/Flags.hs b/internal/System/Landlock/Flags.hs new file mode 100644 --- /dev/null +++ b/internal/System/Landlock/Flags.hs @@ -0,0 +1,247 @@ +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE EmptyDataDeriving #-} +{-# LANGUAGE LambdaCase #-} + +module System.Landlock.Flags + ( toBits, + fromBits, + AccessFsFlag (..), + accessFsFlagToBit, + accessFsFlags, + accessFsFlagIsReadOnly, + CreateRulesetFlag (..), + createRulesetFlagToBit, + RestrictSelfFlag, + restrictSelfFlagToBit, + AddRuleFlag, + addRuleFlagToBit, + ) +where + +import Data.Bits (Bits, (.&.), (.|.)) +import System.Landlock.Hsc + ( U32, + U64, + lANDLOCK_ACCESS_FS_EXECUTE, + lANDLOCK_ACCESS_FS_MAKE_BLOCK, + lANDLOCK_ACCESS_FS_MAKE_CHAR, + lANDLOCK_ACCESS_FS_MAKE_DIR, + lANDLOCK_ACCESS_FS_MAKE_FIFO, + lANDLOCK_ACCESS_FS_MAKE_REG, + lANDLOCK_ACCESS_FS_MAKE_SOCK, + lANDLOCK_ACCESS_FS_MAKE_SYM, + lANDLOCK_ACCESS_FS_READ_DIR, + lANDLOCK_ACCESS_FS_READ_FILE, + lANDLOCK_ACCESS_FS_REFER, + lANDLOCK_ACCESS_FS_REMOVE_DIR, + lANDLOCK_ACCESS_FS_REMOVE_FILE, + lANDLOCK_ACCESS_FS_TRUNCATE, + lANDLOCK_ACCESS_FS_WRITE_FILE, + lANDLOCK_CREATE_RULESET_VERSION, + ) +import System.Landlock.Version (Version, version1, version2, version3) + +-- | Fold a set of flags into a bitset/number. +toBits :: (Num b, Bits b, Foldable f) => (a -> b) -> f a -> b +toBits f = foldr (\a b -> b .|. f a) 0 + +-- | Expand a bitset/number into a set of flags. +fromBits :: (Enum a, Bounded a, Num b, Bits b) => (a -> b) -> b -> [a] +fromBits f b = filter (\a -> b .&. f a /= 0) [minBound .. maxBound] + +-- | Filesystem flags. +-- +-- These flags enable to restrict a sandboxed process to a set of actions on +-- files and directories. Files or directories opened before the sandboxing +-- are not subject to these restrictions. +-- +-- A file can only receive these access rights: +-- +-- - 'AccessFsExecute' +-- - 'AccessFsWriteFile' +-- - 'AccessFsReadFile' +-- - 'AccessFsTruncate' +-- +-- A directory can receive access rights related to files or directories. The +-- following access right is applied to the directory itself, and the +-- directories beneath it: +-- +-- - 'AccessFsReadDir' +-- +-- However, the following access rights only apply to the content of a +-- directory, not the directory itself: +-- +-- - 'AccessFsRemoveDir' +-- - 'AccessFsRemoveFile' +-- - 'AccessFsMakeChar' +-- - 'AccessFsMakeDir' +-- - 'AccessFsMakeReg' +-- - 'AccessFsMakeSock' +-- - 'AccessFsMakeFifo' +-- - 'AccessFsMakeBlock' +-- - 'AccessFsMakeSym' +-- - 'AccessFsRefer' +-- +-- __Warning:__ It is currently not possible to restrict some file-related +-- actions acessible through these syscall families: @chdir@, +-- @stat@, @flock@, @chmod@, @chown@, @setxattr@, @utime@, @ioctl@, @fcntl@, +-- @access@. Future Landlock evolutions will enable to restrict them. +data AccessFsFlag + = -- | Execute a file. + AccessFsExecute + | -- | Open a file with write access. + AccessFsWriteFile + | -- | Open a file with read access. Note that + -- you might additionally need the @LANDLOCK_ACCESS_FS_TRUNCATE@ right in order + -- to overwrite files with @open@ using @O_TRUNC@ or + -- @creat@. + AccessFsReadFile + | -- | Open a directory or list its content. + AccessFsReadDir + | -- | Remove an empty directory or rename one + AccessFsRemoveDir + | -- | Unlink (or rename) a file. + AccessFsRemoveFile + | -- | Create (or rename or link) a character device. + AccessFsMakeChar + | -- | Create (or rename) a directory. + AccessFsMakeDir + | -- | Create (or rename or link) a regular file. + AccessFsMakeReg + | -- | Create (or rename or link) a UNIX domain socket. + AccessFsMakeSock + | -- | Create (or rename or link) a named pipe. + AccessFsMakeFifo + | -- | Create (or rename or link) a block device. + AccessFsMakeBlock + | -- | Create (or rename or link) a symbolic link. + AccessFsMakeSym + | -- | Link or rename a file from or to a different + -- directory (i.e. reparent a file hierarchy). This access right is + -- available since the second version of the Landlock ABI. This is also the + -- only access right which is always considered handled by any ruleset in + -- such a way that reparenting a file hierarchy is always denied by default. + -- To avoid privilege escalation, it is not enough to add a rule with this + -- access right. When linking or renaming a file, the destination directory + -- hierarchy must also always have the same or a superset of restrictions of + -- the source hierarchy. If it is not the case, or if the domain doesn't + -- handle this access right, such actions are denied by default with @errno@ + -- set to @EXDEV@. Linking also requires a @LANDLOCK_ACCESS_FS_MAKE_*@ access + -- right on the destination directory, and renaming also requires a + -- @LANDLOCK_ACCESS_FS_REMOVE_*@ access right on the source's (file or + -- directory) parent. Otherwise, such actions are denied with @errno@ set to + -- @EACCES@. The @EACCES@ @errno@ prevails over @EXDEV@ to let user space + -- efficiently deal with an unrecoverable error. + AccessFsRefer + | -- | Truncate a file with @truncate@, + -- @ftruncate@, @creat@, or @open@ with + -- @O_TRUNC@. Whether an opened file can be truncated with + -- @ftruncate@ is determined during @open@, in the + -- same way as read and write permissions are checked during + -- @open@ using @LANDLOCK_ACCESS_FS_READ_FILE@ and + -- @LANDLOCK_ACCESS_FS_WRITE_FILE@. This access right is available since the + -- third version of the Landlock ABI. + AccessFsTruncate + -- Note: when adding new flags, this likely means a new ABI version is + -- available. Hence, add this to 'System.Landlock.Version' (and export it + -- from 'System.Landlock'), and make sure to update both 'accessFsFlags' and + -- 'accessFsFlagIsReadOnly'. + deriving (Show, Eq, Enum, Bounded, Ord) + +-- | Retrieve a number with the appropriate 'AccessFsFlag' bit set. +accessFsFlagToBit :: AccessFsFlag -> U64 +accessFsFlagToBit = \case + AccessFsExecute -> lANDLOCK_ACCESS_FS_EXECUTE + AccessFsWriteFile -> lANDLOCK_ACCESS_FS_WRITE_FILE + AccessFsReadFile -> lANDLOCK_ACCESS_FS_READ_FILE + AccessFsReadDir -> lANDLOCK_ACCESS_FS_READ_DIR + AccessFsRemoveDir -> lANDLOCK_ACCESS_FS_REMOVE_DIR + AccessFsRemoveFile -> lANDLOCK_ACCESS_FS_REMOVE_FILE + AccessFsMakeChar -> lANDLOCK_ACCESS_FS_MAKE_CHAR + AccessFsMakeDir -> lANDLOCK_ACCESS_FS_MAKE_DIR + AccessFsMakeReg -> lANDLOCK_ACCESS_FS_MAKE_REG + AccessFsMakeSock -> lANDLOCK_ACCESS_FS_MAKE_SOCK + AccessFsMakeFifo -> lANDLOCK_ACCESS_FS_MAKE_FIFO + AccessFsMakeBlock -> lANDLOCK_ACCESS_FS_MAKE_BLOCK + AccessFsMakeSym -> lANDLOCK_ACCESS_FS_MAKE_SYM + AccessFsRefer -> lANDLOCK_ACCESS_FS_REFER + AccessFsTruncate -> lANDLOCK_ACCESS_FS_TRUNCATE + +-- | All 'AccessFsFlag' flags keyed by a Landlock ABI 'Version'. +accessFsFlags :: [(Version, [AccessFsFlag])] +accessFsFlags = + [ (v, [f | f <- [minBound ..], version f <= v]) + | v <- + [ version1, + version2, + version3 + ] + ] + where + version = \case + AccessFsExecute -> version1 + AccessFsWriteFile -> version1 + AccessFsReadFile -> version1 + AccessFsReadDir -> version1 + AccessFsRemoveDir -> version1 + AccessFsRemoveFile -> version1 + AccessFsMakeChar -> version1 + AccessFsMakeDir -> version1 + AccessFsMakeReg -> version1 + AccessFsMakeSock -> version1 + AccessFsMakeFifo -> version1 + AccessFsMakeBlock -> version1 + AccessFsMakeSym -> version1 + AccessFsRefer -> version2 + AccessFsTruncate -> version3 + +-- | Predicate for read-only 'AccessFsFlag' flags. +accessFsFlagIsReadOnly :: AccessFsFlag -> Bool +accessFsFlagIsReadOnly = \case + AccessFsExecute -> True + AccessFsWriteFile -> False + AccessFsReadFile -> True + AccessFsReadDir -> True + AccessFsRemoveDir -> False + AccessFsRemoveFile -> False + AccessFsMakeChar -> False + AccessFsMakeDir -> False + AccessFsMakeReg -> False + AccessFsMakeSock -> False + AccessFsMakeFifo -> False + AccessFsMakeBlock -> False + AccessFsMakeSym -> False + AccessFsRefer -> False + AccessFsTruncate -> False + +-- | Flags passed to @landlock_create_ruleset@. +-- +-- In the current kernel API, only @LANDLOCK_CREATE_RULESET_VERSION@ is +-- defined, which should not be used when creating an actual Landlock +-- encironment (cf. 'landlock'). +data CreateRulesetFlag = CreateRulesetVersion + deriving (Show, Eq, Enum, Bounded) + +createRulesetFlagToBit :: CreateRulesetFlag -> U32 +createRulesetFlagToBit = \case + CreateRulesetVersion -> lANDLOCK_CREATE_RULESET_VERSION + +-- | Flags passed to @landlock_restrict_self@. +-- +-- In the current kernel API, no such flags are defined, hence this is a type +-- without any constructors. +data RestrictSelfFlag + deriving (Show, Eq) + +restrictSelfFlagToBit :: RestrictSelfFlag -> U32 +restrictSelfFlagToBit = \case {} + +-- | Flags passed to @landlock_add_rule@. +-- +-- In the current kernel API, no such flags are defined, hence this is a type +-- without any constructors. +data AddRuleFlag + deriving (Show, Eq) + +addRuleFlagToBit :: AddRuleFlag -> U32 +addRuleFlagToBit = \case {} diff --git a/internal/System/Landlock/Flags.hsc b/internal/System/Landlock/Flags.hsc deleted file mode 100644 --- a/internal/System/Landlock/Flags.hsc +++ /dev/null @@ -1,119 +0,0 @@ -{-# LANGUAGE LambdaCase #-} - -module System.Landlock.Flags ( - toBits - , fromBits - , AccessFsFlag(..) - , accessFsFlagToBit - , accessFsFlags - , accessFsFlagIsReadOnly - ) where - -#include - -import Data.Bits (Bits, (.|.), (.&.)) - -import System.Landlock.Version (Version, version1) - --- | Fold a set of flags into a bitset/number. -toBits :: (Num b, Bits b, Foldable f) => f a -> (a -> b) -> b -toBits l f = foldr (\a b -> b .|. f a) 0 l - --- | Expand a bitset/number into a set of flags. -fromBits :: (Enum a, Bounded a, Num b, Bits b) => b -> (a -> b) -> [a] -fromBits b f = filter (\a -> b .&. f a /= 0) [minBound .. maxBound] - --- | Filesystem flags. --- --- These flags enable to restrict a sandboxed process to a set of actions on --- files and directories. Files or directories opened before the sandboxing --- are not subject to these restrictions. --- --- A file can only receive these access rights: --- --- - 'AccessFsExecute' --- - 'AccessFsWriteFile' --- - 'AccessFsReadFile' --- --- A directory can receive access rights related to files or directories. The --- following access right is applied to the directory itself, and the --- directories beneath it: --- --- - 'AccessFsReadDir' --- --- However, the following access rights only apply to the content of a --- directory, not the directory itself: --- --- - 'AccessFsRemoveDir' --- - 'AccessFsRemoveFile' --- - 'AccessFsMakeChar' --- - 'AccessFsMakeDir' --- - 'AccessFsMakeReg' --- - 'AccessFsMakeSock' --- - 'AccessFsMakeFifo' --- - 'AccessFsMakeBlock' --- - 'AccessFsMakeSym' --- --- __Warning:__ It is currently not possible to restrict some file-related --- actions acessible through these syscall families: @chdir@, @truncate@, --- @stat@, @flock@, @chmod@, @chown@, @setxattr@, @utime@, @ioctl@, @fcntl@, --- @access@. Future Landlock evolutions will enable to restrict them. -data AccessFsFlag = AccessFsExecute -- ^ Execute a file. - | AccessFsWriteFile -- ^ Open a file with write access. - | AccessFsReadFile -- ^ Open a file with read access. - | AccessFsReadDir -- ^ Open a directory or list its content. - | AccessFsRemoveDir -- ^ Remove an empty directory or rename one - | AccessFsRemoveFile -- ^ Unlink (or rename) a file. - | AccessFsMakeChar -- ^ Create (or rename or link) a character device. - | AccessFsMakeDir -- ^ Create (or rename) a directory. - | AccessFsMakeReg -- ^ Create (or rename or link) a regular file. - | AccessFsMakeSock -- ^ Create (or rename or link) a UNIX domain socket. - | AccessFsMakeFifo -- ^ Create (or rename or link) a named pipe. - | AccessFsMakeBlock -- ^ Create (or rename or link) a block device. - | AccessFsMakeSym -- ^ Create (or rename or link) a symbolic link. - --- Note: when adding new flags, this likely means a new ABI version is --- available. Hence, add this to 'System.Landlock.Version' (and export it --- from 'System.Landlock'), and make sure to update both 'accessFsFlags' and --- 'accessFsFlagIsReadOnly'. - deriving (Show, Eq, Enum, Bounded, Ord) - --- | Retrieve a number with the appropriate 'AccessFsFlag' bit set. -accessFsFlagToBit :: Num a => AccessFsFlag -> a -accessFsFlagToBit = \case - AccessFsExecute -> #{const LANDLOCK_ACCESS_FS_EXECUTE} - AccessFsWriteFile -> #{const LANDLOCK_ACCESS_FS_WRITE_FILE} - AccessFsReadFile -> #{const LANDLOCK_ACCESS_FS_READ_FILE} - AccessFsReadDir -> #{const LANDLOCK_ACCESS_FS_READ_DIR} - AccessFsRemoveDir -> #{const LANDLOCK_ACCESS_FS_REMOVE_DIR} - AccessFsRemoveFile -> #{const LANDLOCK_ACCESS_FS_REMOVE_FILE} - AccessFsMakeChar -> #{const LANDLOCK_ACCESS_FS_MAKE_CHAR} - AccessFsMakeDir -> #{const LANDLOCK_ACCESS_FS_MAKE_DIR} - AccessFsMakeReg -> #{const LANDLOCK_ACCESS_FS_MAKE_REG} - AccessFsMakeSock -> #{const LANDLOCK_ACCESS_FS_MAKE_SOCK} - AccessFsMakeFifo -> #{const LANDLOCK_ACCESS_FS_MAKE_FIFO} - AccessFsMakeBlock -> #{const LANDLOCK_ACCESS_FS_MAKE_BLOCK} - AccessFsMakeSym -> #{const LANDLOCK_ACCESS_FS_MAKE_SYM} - --- | All 'AccessFsFlag' flags keyed by a Landlock ABI 'Version'. -accessFsFlags :: [(Version, [AccessFsFlag])] -accessFsFlags = [ - (version1, [AccessFsExecute .. AccessFsMakeSym]) - ] - --- | Predicate for read-only 'AccessFsFlag' flags. -accessFsFlagIsReadOnly :: AccessFsFlag -> Bool -accessFsFlagIsReadOnly = \case - AccessFsExecute -> True - AccessFsWriteFile -> False - AccessFsReadFile -> True - AccessFsReadDir -> True - AccessFsRemoveDir -> False - AccessFsRemoveFile -> False - AccessFsMakeChar -> False - AccessFsMakeDir -> False - AccessFsMakeReg -> False - AccessFsMakeSock -> False - AccessFsMakeFifo -> False - AccessFsMakeBlock -> False - AccessFsMakeSym -> False diff --git a/internal/System/Landlock/Hsc.hsc b/internal/System/Landlock/Hsc.hsc new file mode 100644 --- /dev/null +++ b/internal/System/Landlock/Hsc.hsc @@ -0,0 +1,179 @@ +module System.Landlock.Hsc ( + aT_FDCWD, + + o_PATH, + o_RDONLY, + o_DIRECTORY, + o_NOFOLLOW, + o_CLOEXEC, + + lANDLOCK_ACCESS_FS_EXECUTE, + lANDLOCK_ACCESS_FS_WRITE_FILE, + lANDLOCK_ACCESS_FS_READ_FILE, + lANDLOCK_ACCESS_FS_READ_DIR, + lANDLOCK_ACCESS_FS_REMOVE_DIR, + lANDLOCK_ACCESS_FS_REMOVE_FILE, + lANDLOCK_ACCESS_FS_MAKE_CHAR, + lANDLOCK_ACCESS_FS_MAKE_DIR, + lANDLOCK_ACCESS_FS_MAKE_REG, + lANDLOCK_ACCESS_FS_MAKE_SOCK, + lANDLOCK_ACCESS_FS_MAKE_FIFO, + lANDLOCK_ACCESS_FS_MAKE_BLOCK, + lANDLOCK_ACCESS_FS_MAKE_SYM, + lANDLOCK_ACCESS_FS_REFER, + lANDLOCK_ACCESS_FS_TRUNCATE, + + lANDLOCK_CREATE_RULESET_VERSION, + + U32, + U64, + Landlock_rule_type, + + pR_SET_NO_NEW_PRIVS, + + landlock_ruleset_attr_size, + landlock_ruleset_attr_alignment, + landlock_ruleset_attr_peek_handled_access_fs, + landlock_ruleset_attr_poke_handled_access_fs, + + lANDLOCK_RULE_PATH_BENEATH, + landlock_path_beneath_attr_size, + landlock_path_beneath_attr_alignment, + landlock_path_beneath_attr_peek_allowed_access, + landlock_path_beneath_attr_poke_allowed_access, + landlock_path_beneath_attr_peek_parent_fd, + landlock_path_beneath_attr_poke_parent_fd, +) where + +#define _GNU_SOURCE + +#include +#include +#include +#include + +#include "hs-landlock.h" +#include "linux/landlock.h" + +import Data.Int (Int32) +import Data.Word (Word32, Word64) +import Foreign.C.Types (CInt) +import Foreign.Ptr (Ptr) +import Foreign.Storable (peekByteOff, pokeByteOff) + +aT_FDCWD :: CInt +aT_FDCWD = #{const AT_FDCWD} + +o_PATH :: CInt +o_PATH = #{const O_PATH} + +o_RDONLY :: CInt +o_RDONLY = #{const O_RDONLY} + +o_DIRECTORY :: CInt +o_DIRECTORY = #{const O_DIRECTORY} + +o_NOFOLLOW :: CInt +o_NOFOLLOW = #{const O_NOFOLLOW} + +o_CLOEXEC :: CInt +o_CLOEXEC = #{const O_CLOEXEC} + +lANDLOCK_ACCESS_FS_EXECUTE :: #{type __u64} +lANDLOCK_ACCESS_FS_EXECUTE = #{const LANDLOCK_ACCESS_FS_EXECUTE} + +lANDLOCK_ACCESS_FS_WRITE_FILE :: #{type __u64} +lANDLOCK_ACCESS_FS_WRITE_FILE = #{const LANDLOCK_ACCESS_FS_WRITE_FILE} + +lANDLOCK_ACCESS_FS_READ_FILE :: #{type __u64} +lANDLOCK_ACCESS_FS_READ_FILE = #{const LANDLOCK_ACCESS_FS_READ_FILE} + +lANDLOCK_ACCESS_FS_READ_DIR :: #{type __u64} +lANDLOCK_ACCESS_FS_READ_DIR = #{const LANDLOCK_ACCESS_FS_READ_DIR} + +lANDLOCK_ACCESS_FS_REMOVE_DIR :: #{type __u64} +lANDLOCK_ACCESS_FS_REMOVE_DIR = #{const LANDLOCK_ACCESS_FS_REMOVE_DIR} + +lANDLOCK_ACCESS_FS_REMOVE_FILE :: #{type __u64} +lANDLOCK_ACCESS_FS_REMOVE_FILE = #{const LANDLOCK_ACCESS_FS_REMOVE_FILE} + +lANDLOCK_ACCESS_FS_MAKE_CHAR :: #{type __u64} +lANDLOCK_ACCESS_FS_MAKE_CHAR = #{const LANDLOCK_ACCESS_FS_MAKE_CHAR} + +lANDLOCK_ACCESS_FS_MAKE_DIR :: #{type __u64} +lANDLOCK_ACCESS_FS_MAKE_DIR = #{const LANDLOCK_ACCESS_FS_MAKE_DIR} + +lANDLOCK_ACCESS_FS_MAKE_REG :: #{type __u64} +lANDLOCK_ACCESS_FS_MAKE_REG = #{const LANDLOCK_ACCESS_FS_MAKE_REG} + +lANDLOCK_ACCESS_FS_MAKE_SOCK :: #{type __u64} +lANDLOCK_ACCESS_FS_MAKE_SOCK = #{const LANDLOCK_ACCESS_FS_MAKE_SOCK} + +lANDLOCK_ACCESS_FS_MAKE_FIFO :: #{type __u64} +lANDLOCK_ACCESS_FS_MAKE_FIFO = #{const LANDLOCK_ACCESS_FS_MAKE_FIFO} + +lANDLOCK_ACCESS_FS_MAKE_BLOCK :: #{type __u64} +lANDLOCK_ACCESS_FS_MAKE_BLOCK = #{const LANDLOCK_ACCESS_FS_MAKE_BLOCK} + +lANDLOCK_ACCESS_FS_MAKE_SYM :: #{type __u64} +lANDLOCK_ACCESS_FS_MAKE_SYM = #{const LANDLOCK_ACCESS_FS_MAKE_SYM} + +lANDLOCK_ACCESS_FS_REFER :: #{type __u64} +lANDLOCK_ACCESS_FS_REFER = #{const LANDLOCK_ACCESS_FS_REFER} + +lANDLOCK_ACCESS_FS_TRUNCATE :: #{type __u64} +lANDLOCK_ACCESS_FS_TRUNCATE = #{const LANDLOCK_ACCESS_FS_TRUNCATE} + +lANDLOCK_CREATE_RULESET_VERSION :: #{type __u32} +lANDLOCK_CREATE_RULESET_VERSION = #{const LANDLOCK_CREATE_RULESET_VERSION} + +type U32 = #{type __u32} +type U64 = #{type __u64} + +type Landlock_rule_type = #{type enum landlock_rule_type} + +pR_SET_NO_NEW_PRIVS :: CInt +pR_SET_NO_NEW_PRIVS = #{const PR_SET_NO_NEW_PRIVS} + +landlock_ruleset_attr_size :: Int +landlock_ruleset_attr_size = #{size struct landlock_ruleset_attr} + +landlock_ruleset_attr_alignment :: Int +landlock_ruleset_attr_alignment = #{alignment struct landlock_ruleset_attr} + +landlock_ruleset_attr_peek_handled_access_fs :: Ptr a -> IO #{type __u64} +landlock_ruleset_attr_peek_handled_access_fs = + #{peek struct landlock_ruleset_attr, handled_access_fs} + +landlock_ruleset_attr_poke_handled_access_fs :: Ptr a -> #{type __u64} -> IO () +landlock_ruleset_attr_poke_handled_access_fs = + #{poke struct landlock_ruleset_attr, handled_access_fs} + +lANDLOCK_RULE_PATH_BENEATH :: #{type enum landlock_rule_type} +lANDLOCK_RULE_PATH_BENEATH = #{const LANDLOCK_RULE_PATH_BENEATH} + +landlock_path_beneath_attr_size :: Int +landlock_path_beneath_attr_size = #{size struct landlock_path_beneath_attr} + +landlock_path_beneath_attr_alignment :: Int +landlock_path_beneath_attr_alignment = + #{alignment struct landlock_path_beneath_attr} + +landlock_path_beneath_attr_peek_allowed_access :: Ptr a -> IO #{type __u64} +landlock_path_beneath_attr_peek_allowed_access = + #{peek struct landlock_path_beneath_attr, allowed_access} + +landlock_path_beneath_attr_peek_parent_fd :: Ptr a -> IO #{type __s32} +landlock_path_beneath_attr_peek_parent_fd = + #{peek struct landlock_path_beneath_attr, parent_fd} + +landlock_path_beneath_attr_poke_allowed_access :: + Ptr a -> #{type __u64} -> IO () +landlock_path_beneath_attr_poke_allowed_access = + #{poke struct landlock_path_beneath_attr, allowed_access} + +landlock_path_beneath_attr_poke_parent_fd :: Ptr a -> #{type __s32} -> IO () +landlock_path_beneath_attr_poke_parent_fd = + #{poke struct landlock_path_beneath_attr, parent_fd} + + diff --git a/internal/System/Landlock/OpenPath.hs b/internal/System/Landlock/OpenPath.hs new file mode 100644 --- /dev/null +++ b/internal/System/Landlock/OpenPath.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE CApiFFI #-} + +module System.Landlock.OpenPath + ( withOpenPath, + withOpenPathAt, + OpenPathFlags (..), + defaultOpenPathFlags, + ) +where + +import Control.Monad.Catch (MonadMask, bracket) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Bits ((.|.)) +import Foreign.C.String (CString, withCString) +import Foreign.C.Types (CInt (..)) +import System.Landlock.Hsc + ( aT_FDCWD, + o_CLOEXEC, + o_DIRECTORY, + o_NOFOLLOW, + o_PATH, + o_RDONLY, + ) +import System.Posix.Error (throwErrnoPathIfMinus1Retry) +import System.Posix.IO (closeFd) +import System.Posix.Types (Fd) + +foreign import capi unsafe "fcntl.h openat" + _openat :: + CInt -> + CString -> + CInt -> + IO CInt + +openat :: + Fd -> + FilePath -> + CInt -> + IO Fd +openat dirfd pathname flags = withCString pathname $ \pathnamep -> do + throwErrnoPathIfMinus1Retry "openat" pathname $ + fromIntegral <$> _openat (fromIntegral dirfd) pathnamep flags + +-- | Extra flags used by 'withOpenPathAt' in the call to @openat@. +data OpenPathFlags = OpenPathFlags + { -- | Set @O_DIRECTORY@. + directory :: Bool, + -- | Set @O_NOFOLLOW@. + nofollow :: Bool, + -- | Set @O_CLOEXEC@. + cloexec :: Bool + } + deriving (Show, Eq) + +-- | Default 'OpenPathFlags': +-- +-- - 'directory' is @False@. +-- - 'nofollow' is @False@. +-- - 'cloexec' is @True@. +defaultOpenPathFlags :: OpenPathFlags +defaultOpenPathFlags = + OpenPathFlags + { directory = False, + nofollow = False, + cloexec = True + } + +-- | Perform an action with a path @open@ed using @O_PATH@. +-- +-- The file descriptor provided to the action will be @close@d when the +-- function returns. +-- +-- This internally calls @openat@ with @AT_FDCWD@ and the @O_PATH@ and +-- @O_RDONLY@ flags set, next to any flags specified in the 'OpenPathFlags' +-- argument. +withOpenPath :: + (MonadIO m, MonadMask m) => + -- | Path to open. + FilePath -> + -- | Flag settings to pass. + OpenPathFlags -> + -- | Action to call with a file descriptor to the given path. + (Fd -> m a) -> + -- | Result of the invoked action. + m a +withOpenPath = withOpenPathAt (fromIntegral aT_FDCWD) + +-- | Perform an action with a path @openat@ed using @O_PATH@. +-- +-- Like 'withOpenPath', exposing the @openat@ @dirfd@ argument. +-- +-- The file descriptor provided to the action will be @close@d when the +-- function returns. +-- +-- This internally calls @openat@ with the @O_PATH@ and @O_RDONLY@ flags set, +-- next to any flags specified in the 'OpenPathFlags' argument. +withOpenPathAt :: + (MonadIO m, MonadMask m) => + -- | @dirfd@ argument to @openat@. + Fd -> + -- | Path to open. + FilePath -> + -- | Flag settings to pass. + OpenPathFlags -> + -- | Action to call with a file descriptor to the given path. + (Fd -> m a) -> + -- | Result of the invoked action. + m a +withOpenPathAt dirfd pathname flags = + bracket + (liftIO $ openat dirfd pathname flags') + (liftIO . closeFd) + where + flags' = + foldr + (.|.) + 0 + [ o_PATH, + o_RDONLY, + if directory flags then o_DIRECTORY else 0, + if nofollow flags then o_NOFOLLOW else 0, + if cloexec flags then o_CLOEXEC else 0 + ] diff --git a/internal/System/Landlock/OpenPath.hsc b/internal/System/Landlock/OpenPath.hsc deleted file mode 100644 --- a/internal/System/Landlock/OpenPath.hsc +++ /dev/null @@ -1,93 +0,0 @@ -module System.Landlock.OpenPath ( - withOpenPath - , withOpenPathAt - , OpenPathFlags(..) - , defaultOpenPathFlags - ) where - -#define _GNU_SOURCE - -#include - -import Control.Monad.Catch (MonadMask, bracket) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Bits ((.|.)) -import Data.Int (Int32) -import Foreign.C.String (CString, withCString) -import System.Posix.Error (throwErrnoPathIfMinus1Retry) -import System.Posix.IO (closeFd) -import System.Posix.Types (Fd) - -foreign import ccall unsafe "fcntl.h openat" - _openat :: #{type int} - -> CString - -> #{type int} - -> IO #{type int} - -openat :: Fd - -> FilePath - -> #{type int} - -> IO Fd -openat dirfd pathname flags = withCString pathname $ \pathnamep -> do - fd <- throwErrnoPathIfMinus1Retry "openat" pathname $ _openat (fromIntegral dirfd) pathnamep flags - return $ fromIntegral fd - --- | Extra flags used by 'withOpenPathAt' in the call to @openat@. -data OpenPathFlags = OpenPathFlags { directory :: Bool - -- ^ Set @O_DIRECTORY@. - , nofollow :: Bool - -- ^ Set @O_NOFOLLOW@. - , cloexec :: Bool - -- ^ Set @O_CLOEXEC@. - } - deriving (Show, Eq) - --- | Default 'OpenPathFlags': --- --- - 'directory' is @False@. --- - 'nofollow' is @False@. --- - 'cloexec' is @True@. -defaultOpenPathFlags :: OpenPathFlags -defaultOpenPathFlags = OpenPathFlags { directory = False - , nofollow = False - , cloexec = True - } - --- | Perform an action with a path @open@ed using @O_PATH@. --- --- The file descriptor provided to the action will be @close@d when the --- function returns. --- --- This internally calls @openat@ with @AT_FDCWD@ and the @O_PATH@ and --- @O_RDONLY@ flags set, next to any flags specified in the 'OpenPathFlags' --- argument. -withOpenPath :: (MonadIO m, MonadMask m) - => FilePath -- ^ Path to open. - -> OpenPathFlags -- ^ Flag settings to pass. - -> (Fd -> m a) -- ^ Action to call with a file descriptor to the given path. - -> m a -- ^ Result of the invoked action. -withOpenPath = withOpenPathAt (fromIntegral (#{const AT_FDCWD} :: #{type int})) - --- | Perform an action with a path @openat@ed using @O_PATH@. --- --- Like 'withOpenPath', exposing the @openat@ @dirfd@ argument. --- --- The file descriptor provided to the action will be @close@d when the --- function returns. --- --- This internally calls @openat@ with the @O_PATH@ and @O_RDONLY@ flags set, --- next to any flags specified in the 'OpenPathFlags' argument. -withOpenPathAt :: (MonadIO m, MonadMask m) - => Fd -- ^ @dirfd@ argument to @openat@. - -> FilePath -- ^ Path to open. - -> OpenPathFlags -- ^ Flag settings to pass. - -> (Fd -> m a) -- ^ Action to call with a file descriptor to the given path. - -> m a -- ^ Result of the invoked action. -withOpenPathAt dirfd pathname flags = bracket (liftIO $ openat dirfd pathname flags') (liftIO . closeFd) - where - flags' = foldr (.|.) 0 [ #{const O_PATH} - , #{const O_RDONLY} - , if directory flags then #{const O_DIRECTORY} else 0 - , if nofollow flags then #{const O_NOFOLLOW} else 0 - , if cloexec flags then #{const O_CLOEXEC} else 0 - ] diff --git a/internal/System/Landlock/Rules.hs b/internal/System/Landlock/Rules.hs new file mode 100644 --- /dev/null +++ b/internal/System/Landlock/Rules.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE StandaloneDeriving #-} + +module System.Landlock.Rules + ( Rule, + RuleType (..), + ruleType, + pathBeneath, + AccessFsFlag (..), + ) +where + +import Foreign.Storable (Storable (..)) +import System.Landlock.Flags + ( AccessFsFlag (..), + accessFsFlagToBit, + fromBits, + toBits, + ) +import System.Landlock.Hsc + ( Landlock_rule_type, + lANDLOCK_RULE_PATH_BENEATH, + landlock_path_beneath_attr_alignment, + landlock_path_beneath_attr_peek_allowed_access, + landlock_path_beneath_attr_peek_parent_fd, + landlock_path_beneath_attr_poke_allowed_access, + landlock_path_beneath_attr_poke_parent_fd, + landlock_path_beneath_attr_size, + ) +import System.Posix.Types (Fd) + +-- | Kind of 'Rule's. +data RuleType = PathBeneath + +-- | A rule enforced by Landlock, to be registered using 'System.Landlock.addRule'. +-- +-- 'Rule's can be constructed using the relevant functions, like 'pathBeneath'. +data Rule (a :: RuleType) where + PathBeneathRule :: [AccessFsFlag] -> Fd -> Rule 'PathBeneath + +deriving instance Show (Rule a) + +deriving instance Eq (Rule a) + +-- | Retrieve the @enum landlock_rule_type@ value of a given 'Rule'. +ruleType :: Rule a -> Landlock_rule_type +ruleType = \case + PathBeneathRule {} -> lANDLOCK_RULE_PATH_BENEATH + +instance Storable (Rule 'PathBeneath) where + sizeOf _ = landlock_path_beneath_attr_size + alignment _ = landlock_path_beneath_attr_alignment + peek ptr = do + allowedAccess <- landlock_path_beneath_attr_peek_allowed_access ptr + parentFd <- landlock_path_beneath_attr_peek_parent_fd ptr + return $ + PathBeneathRule + (fromBits accessFsFlagToBit allowedAccess) + (fromIntegral parentFd) + poke ptr (PathBeneathRule flags fd) = do + let allowedAccess = toBits accessFsFlagToBit flags + parentFd = fromIntegral fd + landlock_path_beneath_attr_poke_allowed_access ptr allowedAccess + landlock_path_beneath_attr_poke_parent_fd ptr parentFd + +-- | Construct a path hierarchy rule definition. +-- +-- This corresponds to a rule of type @LANDLOCK_RULE_PATH_BENEATH@, with +-- attributes defined in a @struct landlock_path_beneath_attr@. +pathBeneath :: + -- | File descriptor, preferably opened with @O_PATH@, which + -- identifies the parent directory of a file hierarchy, or + -- just a file. + Fd -> + -- | Allowed actions for this file hierarchy + -- (cf. 'AccessFsFlag'). + [AccessFsFlag] -> + Rule 'PathBeneath +pathBeneath fd flags = PathBeneathRule flags fd diff --git a/internal/System/Landlock/Rules.hsc b/internal/System/Landlock/Rules.hsc deleted file mode 100644 --- a/internal/System/Landlock/Rules.hsc +++ /dev/null @@ -1,66 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE StandaloneDeriving #-} - -module System.Landlock.Rules ( - Rule - , RuleType(..) - , ruleType - , pathBeneath - , AccessFsFlag(..) - ) where - -#include -#include - -import Data.Int (Int32) -import Data.Word (Word32, Word64) -import Foreign.Storable (Storable(..)) -import System.Posix.Types (Fd) - -import System.Landlock.Flags (AccessFsFlag(..), accessFsFlagToBit, fromBits, toBits) - --- | Kind of 'Rule's. -data RuleType = PathBeneath - --- | A rule enforced by Landlock, to be registered using 'System.Landlock.addRule'. --- --- 'Rule's can be constructed using the relevant functions, like 'pathBeneath'. -data Rule (a :: RuleType) where - PathBeneathRule :: [AccessFsFlag] -> Fd -> Rule 'PathBeneath - -deriving instance Show (Rule a) -deriving instance Eq (Rule a) - --- | Retrieve the @enum landlock_rule_type@ value of a given 'Rule'. -ruleType :: Rule a -> #{type enum landlock_rule_type} -ruleType = \case - PathBeneathRule{} -> #{const LANDLOCK_RULE_PATH_BENEATH} - -instance Storable (Rule 'PathBeneath) where - sizeOf _ = #{size struct landlock_path_beneath_attr} - alignment _ = #{alignment struct landlock_path_beneath_attr} - peek ptr = do - allowedAccess <- #{peek struct landlock_path_beneath_attr, allowed_access} ptr :: IO #{type __u64} - parentFd <- #{peek struct landlock_path_beneath_attr, parent_fd} ptr :: IO #{type __s32} - return $ PathBeneathRule (fromBits allowedAccess accessFsFlagToBit) (fromIntegral parentFd) - poke ptr (PathBeneathRule flags fd) = do - let allowedAccess = toBits flags accessFsFlagToBit :: #{type __u64} - parentFd = fromIntegral fd :: #{type __s32} - #{poke struct landlock_path_beneath_attr, allowed_access} ptr allowedAccess - #{poke struct landlock_path_beneath_attr, parent_fd} ptr parentFd - --- | Construct a path hierarchy rule definition. --- --- This corresponds to a rule of type @LANDLOCK_RULE_PATH_BENEATH@, with --- attributes defined in a @struct landlock_path_beneath_attr@. -pathBeneath :: Fd -- ^ File descriptor, preferably opened with @O_PATH@, which - -- identifies the parent directory of a file hierarchy, or - -- just a file. - -> [AccessFsFlag] -- ^ Allowed actions for this file hierarchy - -- (cf. 'AccessFsFlag'). - -> Rule 'PathBeneath -pathBeneath fd flags = PathBeneathRule flags fd diff --git a/internal/System/Landlock/Syscalls.hs b/internal/System/Landlock/Syscalls.hs new file mode 100644 --- /dev/null +++ b/internal/System/Landlock/Syscalls.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE CApiFFI #-} + +module System.Landlock.Syscalls + ( LandlockRulesetAttr (..), + landlock_create_ruleset, + landlock_add_rule, + landlock_restrict_self, + prctl, + pR_SET_NO_NEW_PRIVS, + throwIfNonZero, + ) +where + +import Control.Monad (unless) +import Foreign.C.Error (throwErrnoIfMinus1) +import Foreign.C.Types (CInt (..), CLong (..), CSize (..), CULong (..)) +import Foreign.Ptr (Ptr) +import Foreign.Storable (Storable (..)) +import System.IO.Error (ioeSetLocation) +import System.Landlock.Hsc + ( Landlock_rule_type, + U32, + U64, + landlock_ruleset_attr_alignment, + landlock_ruleset_attr_peek_handled_access_fs, + landlock_ruleset_attr_poke_handled_access_fs, + landlock_ruleset_attr_size, + pR_SET_NO_NEW_PRIVS, + ) + +{- HLINT ignore LandlockRulesetAttr "Use newtype instead of data" -} +data LandlockRulesetAttr = LandlockRulesetAttr + { landlockRulesetAttrHandledAccessFs :: U64 + } + deriving (Show, Eq) + +instance Storable LandlockRulesetAttr where + sizeOf _ = landlock_ruleset_attr_size + alignment _ = landlock_ruleset_attr_alignment + peek ptr = + LandlockRulesetAttr + <$> landlock_ruleset_attr_peek_handled_access_fs ptr + poke ptr attr = + landlock_ruleset_attr_poke_handled_access_fs + ptr + (landlockRulesetAttrHandledAccessFs attr) + +foreign import capi unsafe "hs-landlock.h hs_landlock_create_ruleset" + _landlock_create_ruleset :: + Ptr LandlockRulesetAttr -> + CSize -> + U32 -> + IO CLong + +{- HLINT ignore landlock_create_ruleset "Use camelCase" -} +landlock_create_ruleset :: + Ptr LandlockRulesetAttr -> + CSize -> + U32 -> + IO CLong +landlock_create_ruleset attr size flags = + throwErrnoIfMinus1 "landlock_create_ruleset" $ + _landlock_create_ruleset attr size flags + +foreign import capi unsafe "hs-landlock.h hs_landlock_add_rule" + _landlock_add_rule :: + CInt -> + Landlock_rule_type -> + Ptr a -> + U32 -> + IO CLong + +{- HLINT ignore landlock_add_rule "Use camelCase" -} +landlock_add_rule :: + CInt -> + Landlock_rule_type -> + Ptr a -> + U32 -> + IO () +landlock_add_rule ruleset_fd rule_type rule_attr flags = + throwIfNonZero "landlock_add_rule" $ + throwErrnoIfMinus1 "landlock_add_rule" $ + _landlock_add_rule ruleset_fd rule_type rule_attr flags + +foreign import capi unsafe "hs-landlock.h hs_landlock_restrict_self" + _landlock_restrict_self :: + CInt -> + U32 -> + IO CLong + +{- HLINT ignore landlock_restrict_self "Use camelCase" -} +landlock_restrict_self :: + CInt -> + U32 -> + IO () +landlock_restrict_self ruleset_fd flags = + throwIfNonZero "landlock_restrict_self" $ + throwErrnoIfMinus1 "landlock_restrict_self" $ + _landlock_restrict_self ruleset_fd flags + +foreign import capi unsafe "hs-landlock.h hs_landlock_prctl" + _prctl :: + CInt -> + CULong -> + CULong -> + CULong -> + CULong -> + IO CInt + +prctl :: + CInt -> + CULong -> + CULong -> + CULong -> + CULong -> + IO CInt +prctl option arg2 arg3 arg4 arg5 = + throwErrnoIfMinus1 "prctl" $ _prctl option arg2 arg3 arg4 arg5 + +throwIfNonZero :: (Num a, Eq a, Show a) => String -> IO a -> IO () +throwIfNonZero location act = do + rc <- act + unless (rc == 0) $ + ioError $ + flip ioeSetLocation location $ + userError $ + "Unexpected return value: " ++ show rc ++ " /= 0" diff --git a/internal/System/Landlock/Syscalls.hsc b/internal/System/Landlock/Syscalls.hsc deleted file mode 100644 --- a/internal/System/Landlock/Syscalls.hsc +++ /dev/null @@ -1,86 +0,0 @@ -module System.Landlock.Syscalls ( - LandlockRulesetAttr(..) - , landlock_create_ruleset - , landlock_add_rule - , landlock_restrict_self - , prctl - ) where - -#include -#include -#include -#include - -#include "hs-landlock.h" - -import Data.Int (Int32, Int64) -import Data.Word (Word32, Word64) -import Foreign.C.Error (throwErrnoIfMinus1) -import Foreign.Ptr (Ptr) -import Foreign.Storable (Storable(..)) - -data LandlockRulesetAttr = LandlockRulesetAttr { landlockRulesetAttrHandledAccessFs :: #{type __u64} } - deriving (Show, Eq) - -instance Storable LandlockRulesetAttr where - sizeOf _ = #{size struct landlock_ruleset_attr} - alignment _ = #{alignment struct landlock_ruleset_attr} - peek ptr = LandlockRulesetAttr <$> #{peek struct landlock_ruleset_attr, handled_access_fs} ptr - poke ptr attr = do - #{poke struct landlock_ruleset_attr, handled_access_fs} ptr (landlockRulesetAttrHandledAccessFs attr) - -foreign import ccall unsafe "hs-landlock.h landlock_create_ruleset" - _landlock_create_ruleset :: Ptr LandlockRulesetAttr - -> #{type size_t} - -> #{type __u32} - -> IO #{type long} - -landlock_create_ruleset :: Ptr LandlockRulesetAttr - -> #{type size_t} - -> #{type __u32} - -> IO #{type long} -landlock_create_ruleset attr size flags = - throwErrnoIfMinus1 "landlock_create_ruleset" $ _landlock_create_ruleset attr size flags - -foreign import ccall unsafe "hs-landlock.h landlock_add_rule" - _landlock_add_rule :: #{type int} - -> #{type enum landlock_rule_type} - -> Ptr a - -> #{type __u32} - -> IO #{type long} - -landlock_add_rule :: #{type int} - -> #{type enum landlock_rule_type} - -> Ptr a - -> #{type __u32} - -> IO #{type long} -landlock_add_rule ruleset_fd rule_type rule_attr flags = - throwErrnoIfMinus1 "landlock_add_rule" $ _landlock_add_rule ruleset_fd rule_type rule_attr flags - -foreign import ccall unsafe "hs-landlock.h landlock_restrict_self" - _landlock_restrict_self :: #{type int} - -> #{type __u32} - -> IO #{type long} - -landlock_restrict_self :: #{type int} - -> #{type __u32} - -> IO #{type long} -landlock_restrict_self ruleset_fd flags = - throwErrnoIfMinus1 "landlock_restrict_self" $ _landlock_restrict_self ruleset_fd flags - -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} - -> #{type unsigned long} - -> #{type unsigned long} - -> IO #{type int} -prctl option arg2 arg3 arg4 arg5 = - throwErrnoIfMinus1 "prctl" $ _prctl option arg2 arg3 arg4 arg5 diff --git a/internal/System/Landlock/Version.hs b/internal/System/Landlock/Version.hs new file mode 100644 --- /dev/null +++ b/internal/System/Landlock/Version.hs @@ -0,0 +1,28 @@ +module System.Landlock.Version + ( Version (..), + version1, + version2, + version3, + ) +where + +-- | Representation of a Landlock ABI version as reported by the kernel. +newtype Version = Version + { -- | Get the numerical version. + getVersion :: Word + } + deriving (Show, Eq, Ord) + +-- All ABI versions supported by this library should be exposed as a value. + +-- | ABI version 1. +version1 :: Version +version1 = Version 1 + +-- | ABI version 2. +version2 :: Version +version2 = Version 2 + +-- | ABI version 3. +version3 :: Version +version3 = Version 3 diff --git a/internal/System/Landlock/Version.hsc b/internal/System/Landlock/Version.hsc deleted file mode 100644 --- a/internal/System/Landlock/Version.hsc +++ /dev/null @@ -1,15 +0,0 @@ -module System.Landlock.Version ( - Version(..) - , version1 - ) where - -import Data.Int (Int64) - --- | Representation of a Landlock ABI version as reported by the kernel. -newtype Version = Version { getVersion :: #{type long} } - deriving (Show, Eq, Ord) - --- All ABI versions supported by this library should be exposed as a value. --- | ABI version 1. -version1 :: Version -version1 = Version 1 diff --git a/landlock.cabal b/landlock.cabal --- a/landlock.cabal +++ b/landlock.cabal @@ -1,10 +1,9 @@ -Cabal-Version: 2.2 -Build-Type: Simple - -Name: landlock -Version: 0.2.0.1 -Synopsis: Haskell bindings for the Linux Landlock API -Description: +cabal-version: 2.2 +build-type: Simple +name: landlock +version: 0.2.1.0 +synopsis: Haskell bindings for the Linux Landlock API +description: This library exposes Haskell bindings for the Linux kernel Landlock API. . The Linux kernel Landlock API provides unprivileged access control. The goal @@ -18,105 +17,197 @@ . For more information, see the and its . -Homepage: https://github.com/NicolasT/landlock-hs -Bug-Reports: https://github.com/NicolasT/landlock-hs/issues -License: BSD-3-Clause -License-File: LICENSE -Author: Nicolas Trangez -Maintainer: ikke@nicolast.be -Copyright: (c) 2022 Nicolas Trangez -Category: System -Stability: alpha -Extra-Source-Files: +homepage: https://github.com/NicolasT/landlock-hs +bug-reports: https://github.com/NicolasT/landlock-hs/issues +license: BSD-3-Clause +license-file: LICENSE +author: Nicolas Trangez +maintainer: ikke@nicolast.be +copyright: (c) 2022 Nicolas Trangez +category: System +stability: alpha +extra-doc-files: + cbits/linux/GPL-2.0 + cbits/linux/Linux-syscall-note CHANGELOG.md README.md + +extra-source-files: cbits/hs-landlock.h + cbits/linux/landlock.h -Tested-With: GHC ==8.10.5 - , GHC ==9.0.2 - , GHC ==9.2.2 +tested-with: GHC ==8.10.7 || ==9.0.2 || ==9.2.4 || ==9.4.2 -Source-Repository head - Type: git - Location: https://github.com/NicolasT/landlock-hs.git - Subdir: landlock - Branch: main +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 || ^>=4.15 || ^>=4.16 - , exceptions ^>=0.10.4 - , unix ^>=2.7.2.2 - Build-Tool-Depends: hsc2hs:hsc2hs - Hs-Source-Dirs: src - Default-Language: Haskell2010 - Other-Extensions: EmptyCase - EmptyDataDeriving - FlexibleContexts - LambdaCase - RankNTypes - Ghc-Options: -Wall +flag landlocked + description: Build the landlocked utility. + default: True + manual: True -Library landlock-internal - Exposed-Modules: System.Landlock.Flags - , System.Landlock.OpenPath - , System.Landlock.Rules - , System.Landlock.Syscalls - , System.Landlock.Version - Include-Dirs: cbits - C-Sources: cbits/hs-landlock.c - Cc-Options: -Wall - Build-Depends: psx ^>=0.1 - , base - , exceptions - , unix - Build-Tool-Depends: hsc2hs:hsc2hs - Hs-Source-Dirs: internal - Default-Language: Haskell2010 - Other-Extensions: DataKinds - FlexibleInstances - GADTs - KindSignatures - LambdaCase - StandaloneDeriving - Ghc-Options: -Wall +flag werror + description: Turn compiler warnings into errors. + default: False + manual: True -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 - , tasty ^>=1.4.1 - , tasty-expected-failure ^>=0.12.3 - , tasty-hunit ^>=0.10.0.3 - , tasty-quickcheck ^>=0.10.1.2 - Default-Language: Haskell2010 - Other-Extensions: DataKinds - FlexibleInstances - LambdaCase - ScopedTypeVariables - TypeApplications - Ghc-Options: -Wall +common common-settings + default-language: Haskell2010 + ghc-options: + -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates + -Wpartial-fields -Wmissing-home-modules -Widentities + -Wredundant-constraints -Wcpp-undef -Wmissing-export-lists -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 + cc-options: -Wall -Wextra -pedantic + + if flag(werror) + ghc-options: -Werror -optc=-Werror + + -- Note: disable some warnings triggered by `hsc2hs` code + cc-options: + -Werror -Wno-error=overlength-strings -Wno-error=type-limits + -Wno-error=variadic-macros + +library + import: common-settings + exposed-modules: System.Landlock + build-depends: + , base >=4.14.2.0 && <4.17 || ^>=4.17 + , exceptions ^>=0.10.4 + , landlock-internal + , unix >=2.7.2.2 && <2.8 || ^>=2.8 + + hs-source-dirs: src + other-extensions: + FlexibleContexts + RankNTypes + +library landlock-internal + import: common-settings + exposed-modules: + System.Landlock.Flags + System.Landlock.Hsc + System.Landlock.OpenPath + System.Landlock.Rules + System.Landlock.Syscalls + System.Landlock.Version + + include-dirs: cbits + c-sources: cbits/hs-landlock.c + build-depends: + , base >=4.14.2.0 && <4.17 || ^>=4.17 + , exceptions ^>=0.10.4 + , psx ^>=0.1 + , unix >=2.7.2.2 && <2.8 || ^>=2.8 + + build-tool-depends: hsc2hs:hsc2hs + hs-source-dirs: internal + other-extensions: + CApiFFI + DataKinds + EmptyCase + EmptyDataDeriving + FlexibleInstances + GADTs + KindSignatures + LambdaCase + StandaloneDeriving + +executable landlocked + import: common-settings + + if !flag(landlocked) + buildable: False + + main-is: landlocked.hs + other-modules: Paths_landlock + autogen-modules: Paths_landlock + hs-source-dirs: bin + build-depends: + , base >=4.14.2.0 && <4.17 || ^>=4.17 + , exceptions ^>=0.10.4 + , landlock + , optparse-applicative >=0.16.1.0 && <0.17 || ^>=0.17 + , unix >=2.7.2.2 && <2.8 || ^>=2.8 + +test-suite landlock-test + import: common-settings + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: landlock-test.hs + other-modules: ThreadedScenario + build-depends: + , async ^>=2.2.3 + , base >=4.14.2.0 && <4.17 || ^>=4.17 + , filepath ^>=1.4.2.1 + , landlock + , landlock-internal + , process ^>=1.6.9.0 + , QuickCheck ^>=2.14.2 + , quickcheck-classes-base ^>=0.6.2.0 + , tasty ^>=1.4.1 + , tasty-hunit ^>=0.10.0.3 + , tasty-quickcheck ^>=0.10.1.2 + + other-extensions: + CApiFFI + DataKinds + FlexibleInstances + LambdaCase + TypeApplications + +test-suite landlock-test-threaded + import: common-settings + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: landlock-test-threaded.hs + other-modules: ThreadedScenario + build-depends: + , async ^>=2.2.3 + , base >=4.14.2.0 && <4.17 || ^>=4.17 + , landlock + , tasty ^>=1.4.1 + , tasty-hunit ^>=0.10.0.3 + + ghc-options: -threaded -with-rtsopts -N2 + other-extensions: CApiFFI + +test-suite landlock-readme + import: common-settings + type: exitcode-stdio-1.0 + main-is: README.lhs + other-modules: ReadmeUtils + hs-source-dirs: . test + build-depends: + , base >=4.14.2.0 && <4.17 || ^>=4.17 + , directory ^>=1.3.6.0 + , filepath ^>=1.4.2.1 + , landlock + , process ^>=1.6.9.0 + , temporary ^>=1.3 + + build-tool-depends: markdown-unlit:markdown-unlit + ghc-options: -pgmL markdown-unlit + +test-suite landlocked-test + import: common-settings + + if !flag(landlocked) + buildable: False + + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: landlocked-test.hs + build-depends: + , base >=4.14.2.0 && <4.17 || ^>=4.17 + , filepath ^>=1.4.2.1 + , process ^>=1.6.9.0 + , tasty ^>=1.4.1 + , tasty-hunit ^>=0.10.0.3 + , temporary ^>=1.3 + + build-tool-depends: landlock:landlocked diff --git a/src/System/Landlock.hs b/src/System/Landlock.hs new file mode 100644 --- /dev/null +++ b/src/System/Landlock.hs @@ -0,0 +1,263 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +-- | +-- Module: System.Landlock +-- Description: Haskell bindings for the Linux kernel Landlock API +-- Copyright: (c) Nicolas Trangez, 2022 +-- License: BSD-3-Clause +-- Maintainer: ikke@nicolast.be +-- Stability: alpha +-- Portability: Linux +-- +-- This library exposes Haskell bindings for the Linux kernel Landlock API. +-- +-- The Linux kernel Landlock API provides unprivileged access control. The goal +-- of Landlock is to enable to restrict ambient rights (e.g. global filesystem +-- access) for a set of processes. Because Landlock is a stackable LSM, it makes +-- possible to create safe security sandboxes as new security layers in addition +-- to the existing system-wide access-controls. This kind of sandbox is expected +-- to help mitigate the security impact of bugs or unexpected/malicious +-- behaviors in user space applications. Landlock empowers any process, +-- including unprivileged ones, to securely restrict themselves. +-- +-- For more information, see the [Landlock homepage](https://landlock.io/) and its +-- [kernel documentation](https://docs.kernel.org/userspace-api/landlock.html). +module System.Landlock + ( -- * Core API + + -- + + -- | Use 'landlock' to sandbox a process. + -- $example + landlock, + RulesetAttr (..), + + -- ** Filesystem Access Flags + + -- + + -- | Filesystem access flags to sandbox filesystem access. + AccessFsFlag (..), + accessFsFlags, + accessFsFlagIsReadOnly, + + -- * Sandboxing Rules + + -- + + -- | Sandboxing rules to apply. + Rule, + pathBeneath, + + -- * Utility Functions + + -- + + -- | Various utility functions. + isSupported, + + -- ** Landlock ABI Version + + -- + + -- | Retrieve and handle the kernel's Landlock ABI version. + abiVersion, + Version, + getVersion, + version1, + version2, + version3, + + -- ** Opening paths using @O_PATH@ + + -- + + -- | When creating a 'pathBeneath' rule, a file descriptor to a directory + -- or file is needed. These can be safely @open@ed using the @O_PATH@ flag + -- using the following functions. + withOpenPath, + withOpenPathAt, + OpenPathFlags (..), + defaultOpenPathFlags, + ) +where + +import Control.Exception.Base (handleJust) +import Control.Monad (void) +import Control.Monad.Catch (MonadMask, bracket) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Foreign.Marshal.Utils (with) +import Foreign.Ptr (nullPtr) +import Foreign.Storable (Storable, sizeOf) +import GHC.IO.Exception (IOErrorType (UnsupportedOperation)) +import System.IO.Error (ioeGetErrorType) +import System.Landlock.Flags + ( AccessFsFlag (..), + AddRuleFlag, + CreateRulesetFlag (..), + RestrictSelfFlag, + accessFsFlagIsReadOnly, + accessFsFlagToBit, + accessFsFlags, + addRuleFlagToBit, + createRulesetFlagToBit, + restrictSelfFlagToBit, + toBits, + ) +import System.Landlock.OpenPath (OpenPathFlags (..), defaultOpenPathFlags, withOpenPath, withOpenPathAt) +import System.Landlock.Rules (Rule, pathBeneath, ruleType) +import System.Landlock.Syscalls + ( LandlockRulesetAttr (..), + landlock_add_rule, + landlock_create_ruleset, + landlock_restrict_self, + pR_SET_NO_NEW_PRIVS, + prctl, + throwIfNonZero, + ) +import System.Landlock.Version (Version (..), version1, version2, version3) +import System.Posix.IO (closeFd) +import System.Posix.Types (Fd) + +-- | Retrieve the Landlock ABI version of the running system. +-- +-- __Warning:__ calling this on a system without Landlock support, or with +-- Landlock disabled, will result in an exception. +abiVersion :: IO Version +abiVersion = Version . fromIntegral <$> landlock_create_ruleset nullPtr 0 flags + where + flags = toBits createRulesetFlagToBit [CreateRulesetVersion] + +-- | Check whether Landlock is supported and enabled on the running system. +isSupported :: IO Bool +isSupported = handleJust unsupportedOperation (\() -> return False) $ do + void abiVersion + return True + where + unsupportedOperation exc = if isUnsupportedOperationError exc then Just () else Nothing + isUnsupportedOperationError = isUnsupportedOperationErrorType . ioeGetErrorType + isUnsupportedOperationErrorType = (== UnsupportedOperation) + +-- | Ruleset attributes. +-- +-- This represents a @struct landlock_ruleset_attr@ as passed to +-- @landlock_create_ruleset@. + +{- HLINT ignore "Use newtype instead of data" -} +data RulesetAttr = RulesetAttr + { -- | Actions (cf. 'AccessFsFlag') that ought to + -- be handled by a ruleset and should be + -- forbidden if no rule explicitly allow them. + -- This is needed forbackward compatibility + -- reasons. + rulesetAttrHandledAccessFs :: [AccessFsFlag] + } + deriving (Show, Eq) + +-- | Handle to a Landlock ruleset. Use 'addRule' to register new rules. +newtype LandlockFd = LandlockFd {unLandlockFd :: Fd} + deriving (Show, Eq) + +createRuleset :: RulesetAttr -> [CreateRulesetFlag] -> IO LandlockFd +createRuleset attr flags = with attr' $ \attrp -> wrap <$> landlock_create_ruleset attrp (fromIntegral $ sizeOf attr') flags' + where + wrap = LandlockFd . fromIntegral + attr' = LandlockRulesetAttr {landlockRulesetAttrHandledAccessFs = handledAccessFs} + handledAccessFs = toBits accessFsFlagToBit (rulesetAttrHandledAccessFs attr) + flags' = toBits createRulesetFlagToBit flags + +restrictSelf :: LandlockFd -> [RestrictSelfFlag] -> IO () +restrictSelf fd flags = + landlock_restrict_self (fromIntegral $ unLandlockFd fd) flags' + where + flags' = toBits restrictSelfFlagToBit flags + +-- | Apply a Landlock sandbox to the current process. +-- +-- The provided action can be used to register Landlock 'Rule's on the given +-- instance (see 'addRule'). +-- +-- Once this returns, the Landlock sandbox will be in effect (see +-- @landlock_restrict_self@), and no privileged processes can be spawned +-- (@prctl(PR_SET_NO_NEW_PRIVS, 1, 0, 0, 0)@ has been invoked). +-- +-- __Warning:__ calling this on a system without Landlock support, or with +-- Landlock disabled, will result in an exception. +landlock :: + (MonadMask m, MonadIO m) => + -- | Ruleset attribute passed to @landlock_create_ruleset@. + RulesetAttr -> + -- | Flags passed to @landlock_create_ruleset@. Since no flags but + -- 'CreateRulesetVersion' (@LANDLOCK_CREATE_RULESET_VERSION@) are + -- defined, and this flag must not be used when creating an actual + -- ruleset, this should be an empty list. + [CreateRulesetFlag] -> + -- | Flags passed to @landlock_restrict_self@. Since no flags are + -- defined, this should be an empty list. + [RestrictSelfFlag] -> + -- | Action that will be called before the Landlock sandbox is + -- enforced. The provided function can be used to register + -- sandboxing rules (internally using @landlock_add_rule@), + -- given a 'Rule' and a set of 'AddRuleFlag's. However, since no + -- flags are currently defined, this should be an empty list. + ((Storable (Rule r) => Rule r -> [AddRuleFlag] -> m ()) -> m a) -> + -- | Result of the given action. + m a +landlock attr createRulesetFlags restrictSelfFlags act = + bracket (liftIO $ createRuleset attr createRulesetFlags) (liftIO . closeFd . unLandlockFd) $ \fd -> do + res <- act (addRule fd) + liftIO $ do + throwIfNonZero "prtcl" $ prctl pR_SET_NO_NEW_PRIVS 1 0 0 0 + restrictSelf fd restrictSelfFlags + return res + +-- | Register a new 'Rule' with a Landlock instance. +addRule :: + (MonadIO m, Storable (Rule a)) => + -- | Handle to a Landlock instance. + LandlockFd -> + -- | Sandboxing 'Rule' to register with the Landlock instance. + Rule a -> + -- | Flags. Since no flags are defined, this should be an empty + -- list. + [AddRuleFlag] -> + m () +addRule fd rule flags = liftIO $ + with rule $ \ruleAttrp -> + landlock_add_rule (fromIntegral $ unLandlockFd fd) (ruleType rule) ruleAttrp flags' + where + flags' = toBits addRuleFlagToBit flags + +-- $example +-- +-- Example usage: +-- +-- @ +-- -- Retrieve the Landlock ABI version +-- abi <- abiVersion +-- +-- -- Calculate access flag sets +-- -- Note: in production code, find the highest matching version or similar +-- let Just flags = lookup abi accessFsFlags +-- readOnlyFlags = filter accessFsFlagIsReadOnly flags +-- +-- -- Sandbox the process +-- landlock (RulesetAttr flags) [] [] $ \\addRule -> do +-- -- Allow read-only access to the /usr hierarchy +-- withOpenPath "/usr" defaultOpenPathFlags{ directory = True } $ \\fd -> +-- addRule (pathBeneath fd readOnlyFlags) [] +-- +-- -- Allow read access to my public key +-- withOpenPath "\/home\/nicolas\/.ssh\/id_ed25519.pub" defaultOpenPathFlags $ \\fd -> +-- addRule (pathBeneath fd [AccessFsReadFile]) [] +-- +-- withFile "\/home\/nicolas\/.ssh\/id_ed25519.pub" ReadMode (\\fd -> putStrLn \"Success\") +-- -- Success +-- +-- withFile "\/usr\/bin\/ghc" ReadMode (\\fd -> putStrLn \"Success\") +-- -- Success +-- +-- openFile "\/home\/nicolas\/.ssh\/id_ed25519" ReadMode +-- -- *** Exception: \/home\/nicolas\/.ssh\/id_ed25519: openFile: permission denied (Permission denied) +-- @ diff --git a/src/System/Landlock.hsc b/src/System/Landlock.hsc deleted file mode 100644 --- a/src/System/Landlock.hsc +++ /dev/null @@ -1,249 +0,0 @@ -{-# LANGUAGE EmptyCase #-} -{-# LANGUAGE EmptyDataDeriving #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RankNTypes #-} - --- | --- Module: System.Landlock --- Description: Haskell bindings for the Linux kernel Landlock API --- Copyright: (c) Nicolas Trangez, 2022 --- License: BSD-3-Clause --- Maintainer: ikke@nicolast.be --- Stability: alpha --- Portability: Linux --- --- This library exposes Haskell bindings for the Linux kernel Landlock API. --- --- The Linux kernel Landlock API provides unprivileged access control. The goal --- of Landlock is to enable to restrict ambient rights (e.g. global filesystem --- access) for a set of processes. Because Landlock is a stackable LSM, it makes --- possible to create safe security sandboxes as new security layers in addition --- to the existing system-wide access-controls. This kind of sandbox is expected --- to help mitigate the security impact of bugs or unexpected/malicious --- behaviors in user space applications. Landlock empowers any process, --- including unprivileged ones, to securely restrict themselves. --- --- For more information, see the [Landlock homepage](https://landlock.io/) and its --- [kernel documentation](https://docs.kernel.org/userspace-api/landlock.html). - -module System.Landlock ( - -- * Core API - -- - -- | Use 'landlock' to sandbox a process. - -- - -- $example - landlock - , RulesetAttr(..) - -- ** Filesystem Access Flags - -- - -- | Filesystem access flags to sandbox filesystem access. - , AccessFsFlag(..) - , accessFsFlags - , accessFsFlagIsReadOnly - -- * Sandboxing Rules - -- - -- | Sandboxing rules to apply. - , Rule - , pathBeneath - -- * Utility Functions - -- - -- | Various utility functions. - , isSupported - -- ** Landlock ABI Version - -- - -- | Retrieve and handle the kernel's Landlock ABI version. - , abiVersion - , Version - , version1 - -- ** Opening paths using @O_PATH@ - -- - -- | When creating a 'pathBeneath' rule, a file descriptor to a directory - -- or file is needed. These can be safely @open@ed using the @O_PATH@ flag - -- using the following functions. - , withOpenPath - , withOpenPathAt - , OpenPathFlags(..) - , defaultOpenPathFlags - ) where - -#define _GNU_SOURCE - -#include -#include - -import Control.Exception.Base (handleJust) -import Control.Monad (void) -import Control.Monad.Catch (MonadMask, bracket) -import Control.Monad.IO.Class (MonadIO, liftIO) -import GHC.IO.Exception (IOErrorType(UnsupportedOperation)) -import Foreign.Marshal.Utils (with) -import Foreign.Ptr (nullPtr) -import Foreign.Storable (Storable, sizeOf) -import System.IO.Error (ioeGetErrorType) -import System.Posix.IO (closeFd) -import System.Posix.Types (Fd) - -import System.Landlock.Flags (AccessFsFlag(..), accessFsFlagToBit, accessFsFlags, accessFsFlagIsReadOnly, toBits) -import System.Landlock.OpenPath (OpenPathFlags(..), defaultOpenPathFlags, withOpenPath, withOpenPathAt) -import System.Landlock.Rules (Rule, ruleType, pathBeneath) -import System.Landlock.Syscalls (LandlockRulesetAttr(..), landlock_create_ruleset, landlock_add_rule, landlock_restrict_self, prctl) -import System.Landlock.Version (Version(..), version1) - --- | Retrieve the Landlock ABI version of the running system. --- --- __Warning:__ calling this on a system without Landlock support, or with --- Landlock disabled, will result in an exception. -abiVersion :: IO Version -abiVersion = Version <$> landlock_create_ruleset nullPtr 0 #{const LANDLOCK_CREATE_RULESET_VERSION} - --- | Check whether Landlock is supported and enabled on the running system. -isSupported :: IO Bool -isSupported = handleJust unsupportedOperation (\() -> return False) $ do - void abiVersion - return True - where - unsupportedOperation exc = if isUnsupportedOperationError exc then Just () else Nothing - isUnsupportedOperationError = isUnsupportedOperationErrorType . ioeGetErrorType - isUnsupportedOperationErrorType = (== UnsupportedOperation) - --- | Ruleset attributes. --- --- This represents a @struct landlock_ruleset_attr@ as passed to --- @landlock_create_ruleset@. -data RulesetAttr = RulesetAttr { rulesetAttrHandledAccessFs :: [AccessFsFlag] - -- ^ Actions (cf. 'AccessFsFlag') that ought to - -- be handled by a ruleset and should be - -- forbidden if no rule explicitly allow them. - -- This is needed forbackward compatibility - -- reasons. - } - deriving (Show, Eq) - --- | Flags passed to @landlock_create_ruleset@. --- --- In the current kernel API, only @LANDLOCK_CREATE_RULESET_VERSION@ is --- defined, which should not be used when creating an actual Landlock --- encironment (cf. 'landlock'). -data CreateRulesetFlag = CreateRulesetVersion - deriving (Show, Eq, Enum, Bounded) - --- | Handle to a Landlock ruleset. Use 'addRule' to register new rules. -newtype LandlockFd = LandlockFd { unLandlockFd :: Fd } - deriving (Show, Eq) - -createRuleset :: RulesetAttr -> [CreateRulesetFlag] -> IO LandlockFd -createRuleset attr flags = with attr' $ \attrp -> wrap <$> landlock_create_ruleset attrp (fromIntegral $ sizeOf attr') flags' - where - wrap = LandlockFd . fromIntegral - attr' = LandlockRulesetAttr { landlockRulesetAttrHandledAccessFs = handledAccessFs } - handledAccessFs = toBits (rulesetAttrHandledAccessFs attr) accessFsFlagToBit - flags' = toBits flags $ \case - CreateRulesetVersion -> #{const LANDLOCK_CREATE_RULESET_VERSION} - --- | Flags passed to @landlock_restrict_self@. --- --- In the current kernel API, no such flags are defined, hence this is a type --- without any constructors. -data RestrictSelfFlag - deriving (Show, Eq) - -restrictSelf :: LandlockFd -> [RestrictSelfFlag] -> IO () -restrictSelf fd flags = - void $ landlock_restrict_self (fromIntegral $ unLandlockFd fd) flags' - where - flags' = toBits flags $ \case {} - --- | Apply a Landlock sandbox to the current process. --- --- The provided action can be used to register Landlock 'Rule's on the given --- instance (see 'addRule'). --- --- Once this returns, the Landlock sandbox will be in effect (see --- @landlock_restrict_self@), and no privileged processes can be spawned --- (@prctl(PR_SET_NO_NEW_PRIVS, 1, 0, 0, 0)@ has been invoked). --- --- __Warning:__ calling this on a system without Landlock support, or with --- Landlock disabled, will result in an exception. -landlock :: (MonadMask m, MonadIO m) - => RulesetAttr - -- ^ Ruleset attribute passed to @landlock_create_ruleset@. - -> [CreateRulesetFlag] - -- ^ Flags passed to @landlock_create_ruleset@. Since no flags but - -- 'CreateRulesetVersion' (@LANDLOCK_CREATE_RULESET_VERSION@) are - -- defined, and this flag must not be used when creating an actual - -- ruleset, this should be an empty list. - -> [RestrictSelfFlag] - -- ^ Flags passed to @landlock_restrict_self@. Since no flags are - -- defined, this should be an empty list. - -> ((Storable (Rule r) => Rule r -> [AddRuleFlag] -> m ()) -> m a) - -- ^ Action that will be called before the Landlock sandbox is - -- enforced. The provided function can be used to register - -- sandboxing rules (internally using @landlock_add_rule@), - -- given a 'Rule' and a set of 'AddRuleFlag's. However, since no - -- flags are currently defined, this should be an empty list. - -> m a - -- ^ Result of the given action. -landlock attr createRulesetFlags restrictSelfFlags act = - bracket (liftIO $ createRuleset attr createRulesetFlags) (liftIO . closeFd . unLandlockFd) $ \fd -> do - res <- act (addRule fd) - liftIO $ do - void $ prctl #{const PR_SET_NO_NEW_PRIVS} 1 0 0 0 - restrictSelf fd restrictSelfFlags - return res - --- | Flags passed to @landlock_add_rule@. --- --- In the current kernel API, no such flags are defined, hence this is a type --- without any constructors. -data AddRuleFlag - deriving (Show, Eq) - --- | Register a new 'Rule' with a Landlock instance. -addRule :: (MonadIO m, Storable (Rule a)) - => LandlockFd - -- ^ Handle to a Landlock instance. - -> Rule a - -- ^ Sandboxing 'Rule' to register with the Landlock instance. - -> [AddRuleFlag] - -- ^ Flags. Since no flags are defined, this should be an empty - -- list. - -> m () -addRule fd rule flags = liftIO $ with rule $ \ruleAttrp -> - void $ landlock_add_rule (fromIntegral $ unLandlockFd fd) (ruleType rule) ruleAttrp flags' - where - flags' = toBits flags $ \case {} - --- | --- $example --- --- Example usage: --- --- @ --- -- Retrieve the Landlock ABI version --- abi <- abiVersion --- --- -- Calculate access flag sets --- -- Note: in production code, find the highest matching version or similar --- let Just flags = lookup abi accessFsFlags --- readOnlyFlags = filter accessFsFlagIsReadOnly flags --- --- -- Sandbox the process --- landlock (RulesetAttr flags) [] [] $ \\addRule -> do --- -- Allow read-only access to the /usr hierarchy --- withOpenPath "/usr" defaultOpenPathFlags{ directory = True } $ \\fd -> --- addRule (pathBeneath fd readOnlyFlags) [] --- --- -- Allow read access to my public key --- withOpenPath "\/home\/nicolas\/.ssh\/id_ed25519.pub" defaultOpenPathFlags $ \\fd -> --- addRule (pathBeneath fd [AccessFsReadFile]) [] --- --- withFile "\/home\/nicolas\/.ssh\/id_ed25519.pub" ReadMode (\\fd -> putStrLn \"Success\") --- -- Success --- --- withFile "\/usr\/bin\/ghc" ReadMode (\\fd -> putStrLn \"Success\") --- -- Success --- --- openFile "\/home\/nicolas\/.ssh\/id_ed25519" ReadMode --- -- *** Exception: \/home\/nicolas\/.ssh\/id_ed25519: openFile: permission denied (Permission denied) --- @ diff --git a/test/ReadmeUtils.hs b/test/ReadmeUtils.hs new file mode 100644 --- /dev/null +++ b/test/ReadmeUtils.hs @@ -0,0 +1,53 @@ +module ReadmeUtils + ( withFakeRoot, + -- Control.Exception.Base + handleJust, + -- Control.Monad + unless, + -- System.Directory + removeFile, + -- System.FilePath + (), + -- System.IO + IOMode (..), + hPutStrLn, + withFile, + writeFile, + -- System.IO.Error + isPermissionError, + -- System.Process + readProcess, + ) +where + +import Control.Exception.Base (handleJust) +import Control.Monad (unless) +import System.Directory (createDirectory, removeFile) +import System.FilePath (()) +import System.IO (IOMode (..), hPutStrLn, withFile) +import System.IO.Error (isPermissionError) +import System.IO.Temp (withSystemTempDirectory) +import System.Process (readProcess) + +withFakeRoot :: (FilePath -> IO a) -> IO a +withFakeRoot fn = withSystemTempDirectory "landlock-readme" $ \tmp -> do + let homeDir = tmp "home" + userDir = homeDir "user" + sshDir = userDir ".ssh" + tmpDir = tmp "tmp" + + mapM_ + createDirectory + [ homeDir, + userDir, + sshDir, + tmpDir + ] + + let privateKey = sshDir "id_ed25519" + publicKey = sshDir "id_ed25519.pub" + + writeFile privateKey "private" + writeFile publicKey "public" + + fn tmp diff --git a/test/ThreadedScenario.hs b/test/ThreadedScenario.hs --- a/test/ThreadedScenario.hs +++ b/test/ThreadedScenario.hs @@ -1,68 +1,68 @@ +{-# LANGUAGE CApiFFI #-} + module ThreadedScenario (scenario) where import Control.Concurrent.Async (Async, wait) -import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar) +import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) import Control.Exception.Base (handleJust) -import System.IO (IOMode(ReadMode), withFile) +import System.IO (IOMode (ReadMode), withFile) import System.IO.Error (isPermissionError) -import System.Posix.Types (CPid(..)) - +import System.Landlock (AccessFsFlag (..), RulesetAttr (..), landlock) +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 +foreign import capi 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 + step "Starting scenario" - tidMVar <- newEmptyMVar - continueMVar <- newEmptyMVar + mainTid <- gettid + step $ "Main TID = " ++ show mainTid - step "Launching thread" - withAsync (thread tidMVar continueMVar) $ \child -> do - _ <- takeMVar tidMVar + tidMVar <- newEmptyMVar + continueMVar <- newEmptyMVar - step "Setting up Landlock sandbox" - let flags = [AccessFsReadFile] - landlock (RulesetAttr flags) [] [] $ \_ -> return () + step "Launching thread" + withAsync (thread tidMVar continueMVar) $ \child -> do + _ <- takeMVar tidMVar - step "Assert file not readable from main thread" - assertFileNotReadable "main" - step "Success" + step "Setting up Landlock sandbox" + let flags = [AccessFsReadFile] + landlock (RulesetAttr flags) [] [] $ \_ -> return () - step "Letting thread continue" - putMVar continueMVar () + step "Assert file not readable from main thread" + assertFileNotReadable "main" + step "Success" - step "Waiting for thread to exit" - wait child + step "Letting thread continue" + putMVar continueMVar () + step "Waiting for thread to exit" + wait child where thread tidMVar continueMVar = do - step "Running in thread" + step "Running in thread" - tid <- gettid - step $ "Thread TID = " ++ show tid - putMVar tidMVar tid + tid <- gettid + step $ "Thread TID = " ++ show tid + putMVar tidMVar tid - step "Waiting for the signal..." - () <- takeMVar continueMVar - step "Received signal, continuing" + step "Waiting for the signal..." + () <- takeMVar continueMVar + step "Received signal, continuing" - step "Assert file not readable from thread" - assertFileNotReadable "thread" - step "Success" + step "Assert file not readable from thread" + assertFileNotReadable "thread" + step "Success" file = "/etc/resolv.conf" - assertFileNotReadable env = handleJust permissionError return $ withFile file ReadMode $ \_ -> + 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 --- a/test/landlock-test-threaded.hs +++ b/test/landlock-test-threaded.hs @@ -1,20 +1,13 @@ 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' - ] + defaultMain $ + testGroup + "Threaded" + [ scenario withAsyncBound + ] diff --git a/test/landlock-test.hs b/test/landlock-test.hs --- a/test/landlock-test.hs +++ b/test/landlock-test.hs @@ -1,9 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} - {-# OPTIONS_GHC -Wno-orphans #-} module Main (main) where @@ -11,28 +9,49 @@ 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 Data.List (nub, sort, (\\)) +import Data.Proxy (Proxy (Proxy)) import System.Environment (lookupEnv) -import System.Exit (ExitCode(..)) +import System.Exit (ExitCode (..)) import System.FilePath (()) -import System.IO (IOMode(..), withFile) +import System.IO (IOMode (..), withFile) import System.IO.Error (isPermissionError) +import System.Landlock + ( AccessFsFlag (..), + OpenPathFlags (..), + RulesetAttr (..), + abiVersion, + accessFsFlags, + defaultOpenPathFlags, + isSupported, + landlock, + version1, + version2, + version3, + withOpenPath, + ) +import System.Landlock.Flags + ( CreateRulesetFlag, + accessFsFlagToBit, + createRulesetFlagToBit, + ) +import System.Landlock.Rules (Rule, RuleType (..), pathBeneath) +import System.Landlock.Syscalls (LandlockRulesetAttr (..)) +import System.Landlock.Version (Version (..)) import System.Posix.Types (Fd) -import System.Process (CreateProcess(..), proc, readCreateProcessWithExitCode) - -import Test.QuickCheck.Monadic (assert, monadicIO, run) +import System.Process (CreateProcess (..), proc, readCreateProcessWithExitCode) +import Test.QuickCheck ((=/=), (===)) +import Test.QuickCheck.Classes.Base + ( Laws (..), + boundedEnumLaws, + eqLaws, + ordLaws, + showLaws, + storableLaws, + ) 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 Test.Tasty.HUnit (assertBool, assertFailure, testCase, testCaseSteps, (@=?), (@?), (@?=)) +import Test.Tasty.QuickCheck (Arbitrary (..), arbitraryBoundedEnum, testProperty) import ThreadedScenario (scenario) -- This test-suite is a bit "weird". We want to test various privilege-related @@ -54,106 +73,210 @@ landlockTestEnvironmentVariable = "LANDLOCK_TEST" main :: IO () -main = lookupEnv "LANDLOCK_TEST" >>= \case +main = + lookupEnv "LANDLOCK_TEST" >>= \case Nothing -> do - hasLandlock <- isSupported - defaultMain (tests hasLandlock) + defaultMain tests Just testName -> case lookup testName functionalTestCases of - Nothing -> fail $ "Unknown test: " ++ testName - Just act -> act + 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) +tests :: TestTree +tests = + testGroup + "Tests" + [ properties, + unitTests, + functionalTests, + scenario withAsync ] properties :: TestTree -properties = testGroup "Properties" [ - storable "LandlockRulesetAttr" (Proxy @LandlockRulesetAttr) - , storable "Rule 'PathBeneath" (Proxy @(Rule 'PathBeneath)) +properties = + testGroup + "Properties" + [ testGroup "LandlockRulesetAttr" $ + map + lawsToTestTree + [ eqLaws (Proxy @LandlockRulesetAttr), + showLaws (Proxy @LandlockRulesetAttr), + storableLaws (Proxy @LandlockRulesetAttr) + ], + testGroup "RulesetAttr" $ + map + lawsToTestTree + [ eqLaws (Proxy @RulesetAttr), + showLaws (Proxy @RulesetAttr) + ], + testGroup "CreateRulesetFlag" $ + map + lawsToTestTree + [ eqLaws (Proxy @CreateRulesetFlag), + showLaws (Proxy @CreateRulesetFlag) + -- boundedEnum laws don't work nicely with single-constructor enums + -- , boundedEnumLaws (Proxy @CreateRulesetFlag) + ], + testGroup "AccessFsFlag" $ + map + lawsToTestTree + [ eqLaws (Proxy @AccessFsFlag), + showLaws (Proxy @AccessFsFlag), + boundedEnumLaws (Proxy @AccessFsFlag), + ordLaws (Proxy @AccessFsFlag) + ], + testGroup "OpenPathFlags" $ + map + lawsToTestTree + [ eqLaws (Proxy @OpenPathFlags), + showLaws (Proxy @OpenPathFlags) + ], + testGroup "Rule 'PathBeneath" $ + map + lawsToTestTree + [ eqLaws (Proxy @(Rule 'PathBeneath)), + showLaws (Proxy @(Rule 'PathBeneath)), + storableLaws (Proxy @(Rule 'PathBeneath)) + ], + testGroup "Version" $ + map + lawsToTestTree + [ eqLaws (Proxy @Version), + showLaws (Proxy @Version), + ordLaws (Proxy @Version) + ], + testProperty "accessFsFlagToBit is different for different flags" $ + mapEq accessFsFlagToBit, + testProperty "createRulesetFlagToBit is different for different flags" $ + mapEq createRulesetFlagToBit ] + where + lawsToTestTree laws = testGroup (lawsTypeclass laws) $ flip map (lawsProperties laws) $ uncurry testProperty + mapEq fn a b = + let cmp = if a == b then (===) else (=/=) + in fn a `cmp` fn b -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 Version where + arbitrary = Version <$> arbitrary +instance Arbitrary OpenPathFlags where + arbitrary = OpenPathFlags <$> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary RulesetAttr where + arbitrary = RulesetAttr <$> arbitrary + +instance Arbitrary CreateRulesetFlag where + arbitrary = arbitraryBoundedEnum + instance Arbitrary LandlockRulesetAttr where - arbitrary = LandlockRulesetAttr <$> arbitrary + arbitrary = LandlockRulesetAttr <$> arbitrary instance Arbitrary (Rule 'PathBeneath) where - arbitrary = pathBeneath <$> fmap (fromIntegral :: Int -> Fd) arbitrary - <*> fmap (nub . sort) arbitrary + arbitrary = + pathBeneath + <$> fmap (fromIntegral :: Int -> Fd) arbitrary + <*> fmap (nub . sort) arbitrary instance Arbitrary AccessFsFlag where - arbitrary = arbitraryBoundedEnum + arbitrary = arbitraryBoundedEnum +unitTests :: TestTree +unitTests = + testGroup + "Unit Tests" + [ testCase "lookup version1 accessFsFlags" $ + lookup version1 accessFsFlags @?= Just [AccessFsExecute .. AccessFsMakeSym], + testCase "lookup version2 accessFsFlags" $ + lookup version2 accessFsFlags @?= Just [AccessFsExecute .. AccessFsRefer], + testCase "lookup version3 accessFsFlags" $ + lookup version3 accessFsFlags @?= Just [AccessFsExecute .. AccessFsTruncate], + testCase "ABI v2 introduced [AccessFsRefer]" $ + (\\) + <$> lookup version2 accessFsFlags + <*> lookup version1 accessFsFlags + @?= Just [AccessFsRefer], + testCase "ABI v3 introduced [AccessFsTruncate]" $ + (\\) + <$> lookup version3 accessFsFlags + <*> lookup version2 accessFsFlags + @?= Just [AccessFsTruncate], + testCase "accessFsFlagToBit is unique for all AccessFsFlags" $ + length (nub (sort (map accessFsFlagToBit [minBound .. maxBound]))) + @?= length [minBound :: AccessFsFlag .. maxBound], + testCase "createRulesetFlagToBit is unique for all CreateRulesetFlags" $ + length (nub (sort (map createRulesetFlagToBit [minBound .. maxBound]))) + @?= length [minBound :: CreateRulesetFlag .. maxBound] + ] 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 +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, + testCase "isSupported" $ + isSupported >>= assertBool "landlock API not supported" + ] + ++ 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 + 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 - } + 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) - ] +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 + let fn = "/etc/resolv.conf" + try act = withFile fn ReadMode act - -- First, try to open as-is - try (\_ -> return ()) + -- 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 + -- Then, sandbox and try again + v1Restrictions <- case lookup version1 accessFsFlags of + Nothing -> assertFailure $ "Unknown ABI version: " ++ show version1 + Just r -> return r + 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 + let dir = "/etc" + file = dir "passwd" + act = withFile file ReadMode $ \_ -> return () + v1Restrictions <- case lookup version1 accessFsFlags of + Nothing -> assertFailure $ "Unknown ABI version: " ++ show version1 + Just r -> return r - act + act - landlock (RulesetAttr v1Restrictions) [] [] $ \addRule -> do - withOpenPath dir defaultOpenPathFlags { directory = True } $ \fd -> do - addRule (pathBeneath fd [AccessFsReadFile, AccessFsReadDir, AccessFsExecute]) [] + landlock (RulesetAttr v1Restrictions) [] [] $ \addRule -> do + withOpenPath dir defaultOpenPathFlags {directory = True} $ \fd -> do + addRule (pathBeneath fd [AccessFsReadFile, AccessFsReadDir, AccessFsExecute]) [] - act + act catchPermissionDenied :: IO () -> IO () catchPermissionDenied = handleJust (\exc -> if isPermissionError exc then Just () else Nothing) return diff --git a/test/landlocked-test.hs b/test/landlocked-test.hs new file mode 100644 --- /dev/null +++ b/test/landlocked-test.hs @@ -0,0 +1,60 @@ +module Main (main) where + +import System.Exit (ExitCode (..)) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import System.Process (readProcessWithExitCode) +import Test.Tasty (TestTree, defaultMain, testGroup) +import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = + testGroup + "landlocked" + [ testCase "landlocked" $ do + rc <- landlocked [] + case rc of + ExitSuccess -> assertFailure "Unexpected success" + ExitFailure _ -> return (), + testCase "landlocked true" $ do + rc <- landlocked ["true"] + rc @?= ExitFailure 126, + testCase "landlocked nosuchexecutablereally" $ do + rc <- landlocked ["nosuchexecutablereally"] + rc @?= ExitFailure 127, + testCase "landlocked --ro /usr /usr/bin/true" $ do + rc <- landlocked ["--ro", "/usr", "/usr/bin/true"] + rc @?= ExitSuccess, + testCase "landlocked --ro /usr true" $ do + rc <- landlocked ["--ro", "/usr", "true"] + rc @?= ExitSuccess, + testCase "landlocked --ro /usr /usr/bin/false" $ do + rc <- landlocked ["--ro", "/usr", "/usr/bin/false"] + rc @?= ExitFailure 1, + testCase "landlocked --ro /usr /usr/bin/touch TEMP_PATH/test" $ + withSystemTempDirectory "landlocked-test" $ \tmp -> do + rc <- landlocked ["--ro", "/usr", "/usr/bin/touch", tmp "test"] + rc @?= ExitFailure 1, + testCase "landlocked --ro /usr --rw TEMP_PATH /usr/bin/touch TEMP_PATH/test" $ + withSystemTempDirectory "landlocked-test" $ \tmp -> do + rc <- landlocked ["--ro", "/usr", "--rw", tmp, "/usr/bin/touch", tmp "test"] + rc @?= ExitSuccess, + testCase "landlocked --ro /usr --ro TEMP_PATH /usr/bin/touch TEMP_PATH/test" $ + withSystemTempDirectory "landlocked-test" $ \tmp -> do + rc <- landlocked ["--ro", "/usr", "--ro", tmp, "/usr/bin/touch", tmp "test"] + rc @?= ExitFailure 1, + testCase "landlocked --version" $ do + rc <- landlocked ["--version"] + rc @?= ExitSuccess, + testCase "landlocked --help" $ do + rc <- landlocked ["--help"] + rc @?= ExitSuccess + ] + +landlocked :: [String] -> IO ExitCode +landlocked args = do + (rc, _, _) <- readProcessWithExitCode "landlocked" args "" + return rc