{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
module System.Landlock
(
landlock,
RulesetAttr (..),
AccessFsFlag (..),
accessFsFlags,
accessFsFlagIsReadOnly,
Rule,
pathBeneath,
isSupported,
abiVersion,
Version,
getVersion,
version1,
version2,
version3,
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)
abiVersion :: IO Version
abiVersion :: IO Version
abiVersion = Word -> Version
Version (Word -> Version) -> (CLong -> Word) -> CLong -> Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CLong -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CLong -> Version) -> IO CLong -> IO Version
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr LandlockRulesetAttr -> CSize -> U32 -> IO CLong
landlock_create_ruleset Ptr LandlockRulesetAttr
forall a. Ptr a
nullPtr CSize
0 U32
flags
where
flags :: U32
flags = (CreateRulesetFlag -> U32) -> [CreateRulesetFlag] -> U32
forall b (f :: * -> *) a.
(Num b, Bits b, Foldable f) =>
(a -> b) -> f a -> b
toBits CreateRulesetFlag -> U32
createRulesetFlagToBit [CreateRulesetFlag
CreateRulesetVersion]
isSupported :: IO Bool
isSupported :: IO Bool
isSupported = (IOError -> Maybe ()) -> (() -> IO Bool) -> IO Bool -> IO Bool
forall e b a.
Exception e =>
(e -> Maybe b) -> (b -> IO a) -> IO a -> IO a
handleJust IOError -> Maybe ()
unsupportedOperation (\() -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False) (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
IO Version -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void IO Version
abiVersion
Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
where
unsupportedOperation :: IOError -> Maybe ()
unsupportedOperation IOError
exc =
if IOError -> Bool
isUnsupportedOperationError IOError
exc then () -> Maybe ()
forall a. a -> Maybe a
Just () else Maybe ()
forall a. Maybe a
Nothing
isUnsupportedOperationError :: IOError -> Bool
isUnsupportedOperationError =
IOErrorType -> Bool
isUnsupportedOperationErrorType (IOErrorType -> Bool)
-> (IOError -> IOErrorType) -> IOError -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> IOErrorType
ioeGetErrorType
isUnsupportedOperationErrorType :: IOErrorType -> Bool
isUnsupportedOperationErrorType = (IOErrorType -> IOErrorType -> Bool
forall a. Eq a => a -> a -> Bool
== IOErrorType
UnsupportedOperation)
data RulesetAttr = RulesetAttr
{
RulesetAttr -> [AccessFsFlag]
rulesetAttrHandledAccessFs :: [AccessFsFlag]
}
deriving (Int -> RulesetAttr -> ShowS
[RulesetAttr] -> ShowS
RulesetAttr -> String
(Int -> RulesetAttr -> ShowS)
-> (RulesetAttr -> String)
-> ([RulesetAttr] -> ShowS)
-> Show RulesetAttr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RulesetAttr -> ShowS
showsPrec :: Int -> RulesetAttr -> ShowS
$cshow :: RulesetAttr -> String
show :: RulesetAttr -> String
$cshowList :: [RulesetAttr] -> ShowS
showList :: [RulesetAttr] -> ShowS
Show, RulesetAttr -> RulesetAttr -> Bool
(RulesetAttr -> RulesetAttr -> Bool)
-> (RulesetAttr -> RulesetAttr -> Bool) -> Eq RulesetAttr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RulesetAttr -> RulesetAttr -> Bool
== :: RulesetAttr -> RulesetAttr -> Bool
$c/= :: RulesetAttr -> RulesetAttr -> Bool
/= :: RulesetAttr -> RulesetAttr -> Bool
Eq)
newtype LandlockFd = LandlockFd {LandlockFd -> Fd
unLandlockFd :: Fd}
deriving (Int -> LandlockFd -> ShowS
[LandlockFd] -> ShowS
LandlockFd -> String
(Int -> LandlockFd -> ShowS)
-> (LandlockFd -> String)
-> ([LandlockFd] -> ShowS)
-> Show LandlockFd
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LandlockFd -> ShowS
showsPrec :: Int -> LandlockFd -> ShowS
$cshow :: LandlockFd -> String
show :: LandlockFd -> String
$cshowList :: [LandlockFd] -> ShowS
showList :: [LandlockFd] -> ShowS
Show, LandlockFd -> LandlockFd -> Bool
(LandlockFd -> LandlockFd -> Bool)
-> (LandlockFd -> LandlockFd -> Bool) -> Eq LandlockFd
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LandlockFd -> LandlockFd -> Bool
== :: LandlockFd -> LandlockFd -> Bool
$c/= :: LandlockFd -> LandlockFd -> Bool
/= :: LandlockFd -> LandlockFd -> Bool
Eq)
createRuleset :: RulesetAttr -> [CreateRulesetFlag] -> IO LandlockFd
createRuleset :: RulesetAttr -> [CreateRulesetFlag] -> IO LandlockFd
createRuleset RulesetAttr
attr [CreateRulesetFlag]
flags = LandlockRulesetAttr
-> (Ptr LandlockRulesetAttr -> IO LandlockFd) -> IO LandlockFd
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with LandlockRulesetAttr
attr' ((Ptr LandlockRulesetAttr -> IO LandlockFd) -> IO LandlockFd)
-> (Ptr LandlockRulesetAttr -> IO LandlockFd) -> IO LandlockFd
forall a b. (a -> b) -> a -> b
$ \Ptr LandlockRulesetAttr
attrp ->
CLong -> LandlockFd
wrap (CLong -> LandlockFd) -> IO CLong -> IO LandlockFd
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr LandlockRulesetAttr -> CSize -> U32 -> IO CLong
landlock_create_ruleset Ptr LandlockRulesetAttr
attrp (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> CSize) -> Int -> CSize
forall a b. (a -> b) -> a -> b
$ LandlockRulesetAttr -> Int
forall a. Storable a => a -> Int
sizeOf LandlockRulesetAttr
attr') U32
flags'
where
wrap :: CLong -> LandlockFd
wrap = Fd -> LandlockFd
LandlockFd (Fd -> LandlockFd) -> (CLong -> Fd) -> CLong -> LandlockFd
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CLong -> Fd
forall a b. (Integral a, Num b) => a -> b
fromIntegral
attr' :: LandlockRulesetAttr
attr' =
LandlockRulesetAttr
{ landlockRulesetAttrHandledAccessFs :: U64
landlockRulesetAttrHandledAccessFs = U64
handledAccessFs
}
handledAccessFs :: U64
handledAccessFs = (AccessFsFlag -> U64) -> [AccessFsFlag] -> U64
forall b (f :: * -> *) a.
(Num b, Bits b, Foldable f) =>
(a -> b) -> f a -> b
toBits AccessFsFlag -> U64
accessFsFlagToBit (RulesetAttr -> [AccessFsFlag]
rulesetAttrHandledAccessFs RulesetAttr
attr)
flags' :: U32
flags' = (CreateRulesetFlag -> U32) -> [CreateRulesetFlag] -> U32
forall b (f :: * -> *) a.
(Num b, Bits b, Foldable f) =>
(a -> b) -> f a -> b
toBits CreateRulesetFlag -> U32
createRulesetFlagToBit [CreateRulesetFlag]
flags
restrictSelf :: LandlockFd -> [RestrictSelfFlag] -> IO ()
restrictSelf :: LandlockFd -> [RestrictSelfFlag] -> IO ()
restrictSelf LandlockFd
fd [RestrictSelfFlag]
flags =
CInt -> U32 -> IO ()
landlock_restrict_self (Fd -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Fd -> CInt) -> Fd -> CInt
forall a b. (a -> b) -> a -> b
$ LandlockFd -> Fd
unLandlockFd LandlockFd
fd) U32
flags'
where
flags' :: U32
flags' = (RestrictSelfFlag -> U32) -> [RestrictSelfFlag] -> U32
forall b (f :: * -> *) a.
(Num b, Bits b, Foldable f) =>
(a -> b) -> f a -> b
toBits RestrictSelfFlag -> U32
restrictSelfFlagToBit [RestrictSelfFlag]
flags
landlock ::
(MonadMask m, MonadIO m) =>
RulesetAttr ->
[CreateRulesetFlag] ->
[RestrictSelfFlag] ->
(((Storable (Rule r)) => Rule r -> [AddRuleFlag] -> m ()) -> m a) ->
m a
landlock :: forall (m :: * -> *) (r :: RuleType) a.
(MonadMask m, MonadIO m) =>
RulesetAttr
-> [CreateRulesetFlag]
-> [RestrictSelfFlag]
-> ((Storable (Rule r) => Rule r -> [AddRuleFlag] -> m ()) -> m a)
-> m a
landlock RulesetAttr
attr [CreateRulesetFlag]
createRulesetFlags [RestrictSelfFlag]
restrictSelfFlags (Storable (Rule r) => Rule r -> [AddRuleFlag] -> m ()) -> m a
act =
m LandlockFd -> (LandlockFd -> m ()) -> (LandlockFd -> m a) -> m a
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket
(IO LandlockFd -> m LandlockFd
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO LandlockFd -> m LandlockFd) -> IO LandlockFd -> m LandlockFd
forall a b. (a -> b) -> a -> b
$ RulesetAttr -> [CreateRulesetFlag] -> IO LandlockFd
createRuleset RulesetAttr
attr [CreateRulesetFlag]
createRulesetFlags)
(IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (LandlockFd -> IO ()) -> LandlockFd -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fd -> IO ()
closeFd (Fd -> IO ()) -> (LandlockFd -> Fd) -> LandlockFd -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LandlockFd -> Fd
unLandlockFd)
((LandlockFd -> m a) -> m a) -> (LandlockFd -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \LandlockFd
fd -> do
a
res <- (Storable (Rule r) => Rule r -> [AddRuleFlag] -> m ()) -> m a
act (LandlockFd -> Rule r -> [AddRuleFlag] -> m ()
forall (m :: * -> *) (a :: RuleType).
(MonadIO m, Storable (Rule a)) =>
LandlockFd -> Rule a -> [AddRuleFlag] -> m ()
addRule LandlockFd
fd)
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
String -> IO CInt -> IO ()
forall a. (Num a, Eq a, Show a) => String -> IO a -> IO ()
throwIfNonZero String
"prtcl" (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$ CInt -> CULong -> CULong -> CULong -> CULong -> IO CInt
prctl CInt
pR_SET_NO_NEW_PRIVS CULong
1 CULong
0 CULong
0 CULong
0
LandlockFd -> [RestrictSelfFlag] -> IO ()
restrictSelf LandlockFd
fd [RestrictSelfFlag]
restrictSelfFlags
a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res
addRule ::
(MonadIO m, Storable (Rule a)) =>
LandlockFd ->
Rule a ->
[AddRuleFlag] ->
m ()
addRule :: forall (m :: * -> *) (a :: RuleType).
(MonadIO m, Storable (Rule a)) =>
LandlockFd -> Rule a -> [AddRuleFlag] -> m ()
addRule LandlockFd
fd Rule a
rule [AddRuleFlag]
flags = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
Rule a -> (Ptr (Rule a) -> IO ()) -> IO ()
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with Rule a
rule ((Ptr (Rule a) -> IO ()) -> IO ())
-> (Ptr (Rule a) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr (Rule a)
ruleAttrp ->
CInt -> U32 -> Ptr (Rule a) -> U32 -> IO ()
forall a. CInt -> U32 -> Ptr a -> U32 -> IO ()
landlock_add_rule
(Fd -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Fd -> CInt) -> Fd -> CInt
forall a b. (a -> b) -> a -> b
$ LandlockFd -> Fd
unLandlockFd LandlockFd
fd)
(Rule a -> U32
forall (a :: RuleType). Rule a -> U32
ruleType Rule a
rule)
Ptr (Rule a)
ruleAttrp
U32
flags'
where
flags' :: U32
flags' = (AddRuleFlag -> U32) -> [AddRuleFlag] -> U32
forall b (f :: * -> *) a.
(Num b, Bits b, Foldable f) =>
(a -> b) -> f a -> b
toBits AddRuleFlag -> U32
addRuleFlagToBit [AddRuleFlag]
flags