summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Propellor/Exception.hs13
-rw-r--r--src/Propellor/Property.hs16
-rw-r--r--src/Propellor/Property/ConfFile.hs17
-rw-r--r--src/Propellor/Property/File.hs120
-rw-r--r--src/Propellor/Property/Firejail.hs31
-rw-r--r--src/Propellor/Types/Exception.hs5
-rw-r--r--src/Utility/Exception.hs8
7 files changed, 144 insertions, 66 deletions
diff --git a/src/Propellor/Exception.hs b/src/Propellor/Exception.hs
index 3ab783bf..463402e4 100644
--- a/src/Propellor/Exception.hs
+++ b/src/Propellor/Exception.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE CPP, ScopedTypeVariables #-}
module Propellor.Exception where
@@ -8,11 +8,15 @@ import Propellor.Message
import Utility.Exception
import Control.Exception (AsyncException)
+#if MIN_VERSION_base(4,7,0)
+import Control.Exception (SomeAsyncException)
+#endif
import Control.Monad.Catch
import Control.Monad.IO.Class (MonadIO)
+import Prelude
-- | Catches all exceptions (except for `StopPropellorException` and
--- `AsyncException`) and returns FailedChange.
+-- `AsyncException` and `SomeAsyncException`) and returns FailedChange.
catchPropellor :: (MonadIO m, MonadCatch m) => m Result -> m Result
catchPropellor a = either err return =<< tryPropellor a
where
@@ -21,6 +25,9 @@ catchPropellor a = either err return =<< tryPropellor a
catchPropellor' :: MonadCatch m => m a -> (SomeException -> m a) -> m a
catchPropellor' a onerr = a `catches`
[ Handler (\ (e :: AsyncException) -> throwM e)
+#if MIN_VERSION_base(4,7,0)
+ , Handler (\ (e :: SomeAsyncException) -> throwM e)
+#endif
, Handler (\ (e :: StopPropellorException) -> throwM e)
, Handler (\ (e :: SomeException) -> onerr e)
]
@@ -28,4 +35,4 @@ catchPropellor' a onerr = a `catches`
-- | Catches all exceptions (except for `StopPropellorException` and
-- `AsyncException`).
tryPropellor :: MonadCatch m => m a -> m (Either SomeException a)
-tryPropellor a = (Right <$> a) `catchPropellor'` (pure . Left)
+tryPropellor a = (return . Right =<< a) `catchPropellor'` (return . Left)
diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs
index af36ed58..7ee9397e 100644
--- a/src/Propellor/Property.hs
+++ b/src/Propellor/Property.hs
@@ -16,6 +16,7 @@ module Propellor.Property (
, check
, fallback
, revert
+ , applyToList
-- * Property descriptions
, describe
, (==>)
@@ -53,6 +54,7 @@ import System.Posix.Files
import qualified Data.Hash.MD5 as MD5
import Data.List
import Control.Applicative
+import Data.Foldable hiding (and, elem)
import Prelude
import Propellor.Types
@@ -81,7 +83,7 @@ flagFile' p getflagfile = adjustPropertySatisfy p $ \satisfy -> do
go _ _ True = return NoChange
go satisfy flagfile False = do
r <- satisfy
- when (r == MadeChange) $ liftIO $
+ when (r == MadeChange) $ liftIO $
unlessM (doesFileExist flagfile) $ do
createDirectoryIfMissing True (takeDirectory flagfile)
writeFile flagfile ""
@@ -277,7 +279,7 @@ pickOS
, SingI c
-- Would be nice to have this constraint, but
-- union will not generate metatypes lists with the same
- -- order of OS's as is used everywhere else. So,
+ -- order of OS's as is used everywhere else. So,
-- would need a type-level sort.
--, Union a b ~ c
)
@@ -295,7 +297,7 @@ pickOS a b = c `addChildren` [toChildProperty a, toChildProperty b]
then getSatisfy b
else unsupportedOS'
matching Nothing _ = False
- matching (Just o) p =
+ matching (Just o) p =
Targeting (systemToTargetOS o)
`elem`
fromSing (proptype p)
@@ -341,6 +343,14 @@ unsupportedOS' = go =<< getOS
revert :: RevertableProperty setup undo -> RevertableProperty undo setup
revert (RevertableProperty p1 p2) = RevertableProperty p2 p1
+-- | Apply a property to each element of a list.
+applyToList
+ :: (Foldable t, Functor t, IsProp p, Combines p p, p ~ CombinedType p p)
+ => (b -> p)
+ -> t b
+ -> p
+prop `applyToList` xs = Data.Foldable.foldr1 before $ prop <$> xs
+
makeChange :: IO () -> Propellor Result
makeChange a = liftIO a >> return MadeChange
diff --git a/src/Propellor/Property/ConfFile.hs b/src/Propellor/Property/ConfFile.hs
index d91c7724..b49c626e 100644
--- a/src/Propellor/Property/ConfFile.hs
+++ b/src/Propellor/Property/ConfFile.hs
@@ -44,7 +44,7 @@ adjustSection desc start past adjust insert = fileProperty desc go
go ls = let (pre, wanted, post) = foldl' find ([], [], []) ls
in if null wanted
then insert ls
- else pre ++ (adjust wanted) ++ post
+ else pre ++ adjust wanted ++ post
find (pre, wanted, post) l
| null wanted && null post && (not . start) l =
(pre ++ [l], wanted, post)
@@ -79,8 +79,7 @@ adjustIniSection desc header =
-- | Ensures that a .ini file exists and contains a section
-- with a key=value setting.
containsIniSetting :: FilePath -> (IniSection, IniKey, String) -> Property UnixLike
-containsIniSetting f (header, key, value) =
- adjustIniSection
+containsIniSetting f (header, key, value) = adjustIniSection
(f ++ " section [" ++ header ++ "] contains " ++ key ++ "=" ++ value)
header
go
@@ -90,28 +89,26 @@ containsIniSetting f (header, key, value) =
confheader = iniHeader header
confline = key ++ "=" ++ value
go [] = [confline]
- go (l:ls) = if isKeyVal l then confline : ls else l : (go ls)
+ go (l:ls) = if isKeyVal l then confline : ls else l : go ls
isKeyVal x = (filter (/= ' ') . takeWhile (/= '=')) x `elem` [key, '#':key]
-- | Ensures that a .ini file exists and contains a section
-- with a given key=value list of settings.
hasIniSection :: FilePath -> IniSection -> [(IniKey, String)] -> Property UnixLike
-hasIniSection f header keyvalues =
- adjustIniSection
+hasIniSection f header keyvalues = adjustIniSection
("set " ++ f ++ " section [" ++ header ++ "]")
header
go
- (++ [confheader] ++ conflines) -- add missing section at end
+ (++ confheader : conflines) -- add missing section at end
f
where
confheader = iniHeader header
conflines = map (\(key, value) -> key ++ "=" ++ value) keyvalues
- go _ = conflines
+ go _ = confheader : conflines
-- | Ensures that a .ini file does not contain the specified section.
lacksIniSection :: FilePath -> IniSection -> Property UnixLike
-lacksIniSection f header =
- adjustIniSection
+lacksIniSection f header = adjustIniSection
(f ++ " lacks section [" ++ header ++ "]")
header
(const []) -- remove all lines of section
diff --git a/src/Propellor/Property/File.hs b/src/Propellor/Property/File.hs
index e072fcaa..95fc6f81 100644
--- a/src/Propellor/Property/File.hs
+++ b/src/Propellor/Property/File.hs
@@ -1,8 +1,11 @@
+{-# LANGUAGE FlexibleInstances #-}
+
module Propellor.Property.File where
import Propellor.Base
import Utility.FileMode
+import qualified Data.ByteString.Lazy as L
import System.Posix.Files
import System.Exit
@@ -14,10 +17,28 @@ f `hasContent` newcontent = fileProperty
("replace " ++ f)
(\_oldcontent -> newcontent) f
+-- | Ensures that a line is present in a file, adding it to the end if not.
+containsLine :: FilePath -> Line -> Property UnixLike
+f `containsLine` l = f `containsLines` [l]
+
+containsLines :: FilePath -> [Line] -> Property UnixLike
+f `containsLines` ls = fileProperty (f ++ " contains:" ++ show ls) go f
+ where
+ go content = content ++ filter (`notElem` content) ls
+
+-- | Ensures that a line is not present in a file.
+-- Note that the file is ensured to exist, so if it doesn't, an empty
+-- file will be written.
+lacksLine :: FilePath -> Line -> Property UnixLike
+f `lacksLine` l = fileProperty (f ++ " remove: " ++ l) (filter (/= l)) f
+
+lacksLines :: FilePath -> [Line] -> Property UnixLike
+f `lacksLines` ls = fileProperty (f ++ " remove: " ++ show [ls]) (filter (`notElem` ls)) f
+
-- | Replaces all the content of a file, ensuring that its modes do not
-- allow it to be read or written by anyone other than the current user
hasContentProtected :: FilePath -> [Line] -> Property UnixLike
-f `hasContentProtected` newcontent = fileProperty' writeFileProtected
+f `hasContentProtected` newcontent = fileProperty' ProtectedWrite
("replace " ++ f)
(\_oldcontent -> newcontent) f
@@ -29,9 +50,9 @@ hasPrivContent :: IsContext c => FilePath -> c -> Property (HasInfo + UnixLike)
hasPrivContent f = hasPrivContentFrom (PrivDataSourceFile (PrivFile f) f) f
-- | Like hasPrivContent, but allows specifying a source
--- for PrivData, rather than using PrivDataSourceFile .
+-- for PrivData, rather than using `PrivDataSourceFile`.
hasPrivContentFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property (HasInfo + UnixLike)
-hasPrivContentFrom = hasPrivContent' writeFileProtected
+hasPrivContentFrom = hasPrivContent' ProtectedWrite
-- | Leaves the file at its default or current mode,
-- allowing "private" data to be read.
@@ -41,68 +62,30 @@ hasPrivContentExposed :: IsContext c => FilePath -> c -> Property (HasInfo + Uni
hasPrivContentExposed f = hasPrivContentExposedFrom (PrivDataSourceFile (PrivFile f) f) f
hasPrivContentExposedFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property (HasInfo + UnixLike)
-hasPrivContentExposedFrom = hasPrivContent' writeFile
+hasPrivContentExposedFrom = hasPrivContent' NormalWrite
-hasPrivContent' :: (IsContext c, IsPrivDataSource s) => (FilePath -> String -> IO ()) -> s -> FilePath -> c -> Property (HasInfo + UnixLike)
-hasPrivContent' writer source f context =
+hasPrivContent' :: (IsContext c, IsPrivDataSource s) => FileWriteMode -> s -> FilePath -> c -> Property (HasInfo + UnixLike)
+hasPrivContent' writemode source f context =
withPrivData source context $ \getcontent ->
property' desc $ \o -> getcontent $ \privcontent ->
- ensureProperty o $ fileProperty' writer desc
- (\_oldcontent -> privDataLines privcontent) f
+ ensureProperty o $ fileProperty' writemode desc
+ (\_oldcontent -> privDataByteString privcontent) f
where
desc = "privcontent " ++ f
--- | Ensures that a line is present in a file, adding it to the end if not.
-containsLine :: FilePath -> Line -> Property UnixLike
-f `containsLine` l = f `containsLines` [l]
-
-containsLines :: FilePath -> [Line] -> Property UnixLike
-f `containsLines` ls = fileProperty (f ++ " contains:" ++ show ls) go f
- where
- go content = content ++ filter (`notElem` content) ls
-
--- | Ensures that a line is not present in a file.
--- Note that the file is ensured to exist, so if it doesn't, an empty
--- file will be written.
-lacksLine :: FilePath -> Line -> Property UnixLike
-f `lacksLine` l = fileProperty (f ++ " remove: " ++ l) (filter (/= l)) f
-
-lacksLines :: FilePath -> [Line] -> Property UnixLike
-f `lacksLines` ls = fileProperty (f ++ " remove: " ++ show [ls]) (filter (`notElem` ls)) f
-
-- | Replaces the content of a file with the transformed content of another file
basedOn :: FilePath -> (FilePath, [Line] -> [Line]) -> Property UnixLike
f `basedOn` (f', a) = property' desc $ \o -> do
tmpl <- liftIO $ readFile f'
ensureProperty o $ fileProperty desc (\_ -> a $ lines $ tmpl) f
where
- desc = "replace " ++ f
+ desc = f ++ " is based on " ++ f'
-- | Removes a file. Does not remove symlinks or non-plain-files.
notPresent :: FilePath -> Property UnixLike
notPresent f = check (doesFileExist f) $ property (f ++ " not present") $
makeChange $ nukeFile f
-fileProperty :: Desc -> ([Line] -> [Line]) -> FilePath -> Property UnixLike
-fileProperty = fileProperty' writeFile
-fileProperty' :: (FilePath -> String -> IO ()) -> Desc -> ([Line] -> [Line]) -> FilePath -> Property UnixLike
-fileProperty' writer desc a f = property desc $ go =<< liftIO (doesFileExist f)
- where
- go True = do
- old <- liftIO $ readFile f
- let new = unlines (a (lines old))
- if old == new
- then noChange
- else makeChange $ updatefile new `viaStableTmp` f
- go False = makeChange $ writer f (unlines $ a [])
-
- -- Replicate the original file's owner and mode.
- updatefile content f' = do
- writer f' content
- s <- getFileStatus f
- setFileMode f' (fileMode s)
- setOwnerAndGroup f' (fileOwner s) (fileGroup s)
-
-- | Ensures a directory exists.
dirExists :: FilePath -> Property UnixLike
dirExists d = check (not <$> doesDirectoryExist d) $ property (d ++ " exists") $
@@ -172,6 +155,49 @@ mode f v = p `changesFile` f
liftIO $ modifyFileMode f (const v)
return NoChange
+class FileContent c where
+ emptyFileContent :: c
+ readFileContent :: FilePath -> IO c
+ writeFileContent :: FileWriteMode -> FilePath -> c -> IO ()
+
+data FileWriteMode = NormalWrite | ProtectedWrite
+
+instance FileContent [Line] where
+ emptyFileContent = []
+ readFileContent f = lines <$> readFile f
+ writeFileContent NormalWrite f ls = writeFile f (unlines ls)
+ writeFileContent ProtectedWrite f ls = writeFileProtected f (unlines ls)
+
+instance FileContent L.ByteString where
+ emptyFileContent = L.empty
+ readFileContent = L.readFile
+ writeFileContent NormalWrite f c = L.writeFile f c
+ writeFileContent ProtectedWrite f c =
+ writeFileProtected' f (`L.hPutStr` c)
+
+-- | A property that applies a pure function to the content of a file.
+fileProperty :: (FileContent c, Eq c) => Desc -> (c -> c) -> FilePath -> Property UnixLike
+fileProperty = fileProperty' NormalWrite
+fileProperty' :: (FileContent c, Eq c) => FileWriteMode -> Desc -> (c -> c) -> FilePath -> Property UnixLike
+fileProperty' writemode desc a f = property desc $ go =<< liftIO (doesFileExist f)
+ where
+ go True = do
+ old <- liftIO $ readFileContent f
+ let new = a old
+ if old == new
+ then noChange
+ else makeChange $ updatefile new `viaStableTmp` f
+ go False = makeChange $ writer f (a emptyFileContent)
+
+ -- Replicate the original file's owner and mode.
+ updatefile content dest = do
+ writer dest content
+ s <- getFileStatus f
+ setFileMode dest (fileMode s)
+ setOwnerAndGroup dest (fileOwner s) (fileGroup s)
+
+ writer = writeFileContent writemode
+
-- | A temp file to use when writing new content for a file.
--
-- This is a stable name so it can be removed idempotently.
diff --git a/src/Propellor/Property/Firejail.hs b/src/Propellor/Property/Firejail.hs
new file mode 100644
index 00000000..b7841e07
--- /dev/null
+++ b/src/Propellor/Property/Firejail.hs
@@ -0,0 +1,31 @@
+-- | Maintainer: Sean Whitton <spwhitton@spwhitton.name>
+
+module Propellor.Property.Firejail (
+ installed,
+ jailed,
+) where
+
+import Propellor.Base
+import qualified Propellor.Property.Apt as Apt
+import qualified Propellor.Property.File as File
+
+-- | Ensures that Firejail is installed
+installed :: Property DebianLike
+installed = Apt.installed ["firejail"]
+
+-- | For each program name passed, create symlinks in /usr/local/bin that
+-- will launch that program in a Firejail sandbox.
+--
+-- The profile for the sandbox will be the same as if the user had run
+-- @firejail@ directly without passing @--profile@ (see "SECURITY PROFILES" in
+-- firejail(1)).
+--
+-- See "DESKTOP INTEGRATION" in firejail(1).
+jailed :: [String] -> Property DebianLike
+jailed ps = (jailed' `applyToList` ps)
+ `requires` installed
+ `describe` unwords ("firejail jailed":ps)
+
+jailed' :: String -> Property UnixLike
+jailed' p = ("/usr/local/bin" </> p)
+ `File.isSymlinkedTo` File.LinkTarget "/usr/bin/firejail"
diff --git a/src/Propellor/Types/Exception.hs b/src/Propellor/Types/Exception.hs
index 3a810d55..9fdcab93 100644
--- a/src/Propellor/Types/Exception.hs
+++ b/src/Propellor/Types/Exception.hs
@@ -1,10 +1,11 @@
+{-# LANGUAGE DeriveDataTypeable #-}
module Propellor.Types.Exception where
import Data.Typeable
import Control.Exception
--- | Normally when an exception is encountered while propellor is
--- ensuring a property, the property fails, but propellor robustly
+-- | Normally when an exception is encountered while propellor is
+-- ensuring a property, the property fails, but propellor robustly
-- continues on to the next property.
--
-- This is the only exception that will stop the entire propellor run,
diff --git a/src/Utility/Exception.hs b/src/Utility/Exception.hs
index e691f13b..f6551b45 100644
--- a/src/Utility/Exception.hs
+++ b/src/Utility/Exception.hs
@@ -5,7 +5,7 @@
- License: BSD-2-clause
-}
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE CPP, ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Exception (
@@ -28,6 +28,9 @@ module Utility.Exception (
import Control.Monad.Catch as X hiding (Handler)
import qualified Control.Monad.Catch as M
import Control.Exception (IOException, AsyncException)
+#if MIN_VERSION_base(4,7,0)
+import Control.Exception (SomeAsyncException)
+#endif
import Control.Monad
import Control.Monad.IO.Class (liftIO, MonadIO)
import System.IO.Error (isDoesNotExistError, ioeGetErrorType)
@@ -74,6 +77,9 @@ bracketIO setup cleanup = bracket (liftIO setup) (liftIO . cleanup)
catchNonAsync :: MonadCatch m => m a -> (SomeException -> m a) -> m a
catchNonAsync a onerr = a `catches`
[ M.Handler (\ (e :: AsyncException) -> throwM e)
+#if MIN_VERSION_base(4,7,0)
+ , M.Handler (\ (e :: SomeAsyncException) -> throwM e)
+#endif
, M.Handler (\ (e :: SomeException) -> onerr e)
]
generated by cgit v1.3-2-g0d8e (git 2.53.0) at 2026-07-02 22:39:27 +0000