salmon-ops-0.2.0.0: src/Salmon/Builtin/Nodes/Filesystem.hs
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Salmon.Builtin.Nodes.Filesystem where
import Salmon.Builtin.Extension
import Salmon.Op.Ref
import qualified Data.Aeson as Aeson
import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Base64.URL as Base64.URL
import qualified Data.ByteString.Char8 as C8
import qualified Data.ByteString.Lazy as LBytestring
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Crypto.Hash.SHA256 as SHA256
import Data.Bits ((.&.))
import Control.Exception (IOException, try)
import Control.Monad (when)
import Data.List (isPrefixOf)
import System.IO.Error (isDoesNotExistError)
import Data.Time (defaultTimeLocale, formatTime, getCurrentTime)
import Numeric (showOct)
import qualified System.Posix.Files as Posix
import qualified System.Posix.Types as Posix
import qualified System.Posix.User as PosixUser
import GHC.TypeLits (Symbol)
import Salmon.Actions.UpDown (CheckResult (..), skipIfDirectoryIsMissing)
import Salmon.Op.OpGraph (OpGraph (..), inject)
import Salmon.Op.Supervision (defaultSupervision, supReapply, supervised)
import Salmon.Op.Track
import System.Directory
import System.FilePath
newtype Directory = Directory {directoryPath :: FilePath}
deriving (Eq, Ord, Show)
{- | (R9). No 'check', by design rather than by omission: there is nothing
about a directory's existence worth a separate question, since
'createDirectoryIfMissing' already costs about what 'doesDirectoryExist'
would. So this declares 'Salmon.Op.Supervision.supReapply' instead — under
@run serve@ a tending machine for this node re-runs @up@ on the adaptive
delay rather than parking, which is what makes a directory removed behind
salmon's back come back on its own. Under a one-shot @run up@\/@run down@
this changes nothing at all: the field is read only by
"Salmon.Actions.Upkeep", and the check still answers
'Salmon.Actions.UpDown.Immaterial' either way.
This is the node 'Salmon.Op.Supervision.supReapply' was written for — see
its haddock for why almost nothing else in this tree should set it.
-}
dir :: Directory -> Op
dir directory =
op "directory" nodeps $ \actions ->
actions
{ help = Text.pack $ "ensures " <> path <> " exists, including subdirs"
, notes =
[ "create dir recursively"
, "does not delete contents of the directory"
, "reapplies rather than parking under supervision; see supReapply"
]
, ref = mkRef "directory" path
, up = createDirectoryIfMissing True path
, -- same reasoning as 'filecontents': an absent directory is
-- this node's effect being absent. A *non-empty* one still
-- throws, which is a real signal (something in it was not
-- declared, or did not go down).
down = removeDirectoryIfPresent path
, dynamics = [supervised defaultSupervision{supReapply = True}]
}
where
path :: FilePath
path = directory.directoryPath
{- | Like 'dir', except 'down' renames the directory to a timestamped suffix
instead of deleting it, for a directory whose contents are worth keeping
around after teardown rather than losing (e.g. retired certificate material —
see "Salmon.Builtin.Nodes.Certificates"). Idempotent the same way every other
@down@ is: a directory already gone is left alone rather than erroring.
-}
retainedDir :: Directory -> Op
retainedDir directory =
op "retained-directory" nodeps $ \actions ->
actions
{ help = Text.pack $ "ensures " <> path <> " exists, including subdirs"
, notes =
[ "create dir recursively"
, "does not delete contents of the directory"
, "down renames the directory to a timestamped suffix instead of deleting it"
, "reapplies rather than parking under supervision; see supReapply"
]
, ref = mkRef "retained-directory" path
, up = createDirectoryIfMissing True path
, down = retireDirectory path
, dynamics = [supervised defaultSupervision{supReapply = True}]
}
where
path :: FilePath
path = directory.directoryPath
{- | A directory that is not salmon's alone: a system directory a package
ships and fills (@\/etc\/haproxy@, @\/etc\/sudoers.d@, @\/etc\/pgbouncer@,
an nginx @conf.d@), or one something else also writes into (a
pre-provisioned credentials file next to a rendered config). Created if
missing, like 'dir'; left alone by @down@.
'dir''s @down@ refuses a non-empty directory on purpose, so a file declared
in such a directory through 'filecontents' was removed cleanly and then its
directory reported @Failed@, which also blocks the teardown of whatever was
declared under it. Removing the directory would be wrong anyway: salmon
cannot prove it made it.
Its own kind (@"shared-directory"@, keyed on the path), so it never collides
with a 'dir' of the same path; reapplies under supervision, as 'dir' does.
The systemd and quadlet unit directories have nodes of the same shape
('Salmon.Builtin.Nodes.Systemd.unitDirectory' and the quadlet's
@unitDirNode@), which predate this one and keep their own refs.
-}
sharedDir :: Directory -> Op
sharedDir directory =
op "shared-directory" nodeps $ \actions ->
actions
{ help = Text.pack $ "ensures " <> path <> " exists, including subdirs"
, notes =
[ "create dir recursively"
, "shared with what salmon does not declare: down leaves it"
, "reapplies rather than parking under supervision; see supReapply"
]
, ref = mkRef "shared-directory" path
, up = createDirectoryIfMissing True path
, dynamics = [supervised defaultSupervision{supReapply = True}]
}
where
path :: FilePath
path = directory.directoryPath
{- | 'filecontents' standing on a 'sharedDir' of its enclosing directory
instead of a 'dir'. The file node itself is exactly what 'filecontents'
renders (same 'ref', @help@, @notes@, @check@, @up@ and @down@); only its
predecessor differs. For a file in a directory holding things salmon does
not declare, where 'dir''s @down@ would fail on what is left.
-}
filecontentsInSharedDir :: (EncodeFileContents a) => FileContents a -> Op
filecontentsInSharedDir fcontents =
file{predecessors = deps [sharedDir (Directory (takeDirectory fcontents.filePath))]}
where
file :: Op
file = filecontents fcontents
{- | A scratch directory salmon owns outright: 'down' removes it /and
everything in it/. Opt-in, for a directory whose contents cannot be declared
(logs written by child processes, pid files, a transient dump) and whose
teardown must leave nothing behind. 'dir' would refuse to remove it (non-empty)
and 'retainedDir' would leave a timestamped copy behind on every @down@.
A recursive delete destroys data, so it is guarded by the directory's
__identity__, not by its path:
* @up@ creates the leaf itself (never adopts one that is already there) and
then writes, inside it, an ownership claim ('scratchClaimFile') naming the
declared path and the directory's own device and inode numbers.
* @down@ removes the tree only when the path is still /that/ directory: a
real directory (not a symlink), whose device and inode match the claim
inside it. A claim copied into another directory, a directory recreated by
someone else at the same path, or one mounted over it does not match, and
@down@ throws without deleting anything.
* @down@ also refuses a tree that crosses into another filesystem (a mount
point or bind mount somewhere underneath): it walks the tree first, never
following a symlink, and compares every directory's device. Symlinks inside
the tree are removed themselves, never their targets.
* Some paths are refused outright, at @up@ as at @down@: a relative path, one
with @.@ or @..@ components, @/@ and any top-level directory (@/tmp@,
@/var@), and the user's home or any of its ancestors ('scratchPathRefusal').
@up@ also throws when the path exists without a matching claim: salmon never
takes over a directory it cannot prove it made. A crash between the
@mkdir@ and the claim write leaves exactly that state; recovering it is a
manual @rmdir@, deliberately.
A @down@ of an absent directory succeeds, as for 'dir', so a second @down@ is
a no-op. The @check@ answers 'Success' when the directory is there with a
matching claim, so a directory removed behind salmon's back is noticed (and
put back) under @run serve@.
Two things a caller should know. The claim file lives inside the directory,
so whatever writes there must not delete it (if it does, @down@ refuses and
says why). And nodes declared /inside/ a scratch directory should not stand
on 'dir' of the same path (as 'filecontents' does through its enclosing
directory): that is a second, differently-keyed node for the same path whose
own @down@ fails on a non-empty directory.
-}
scratchDir :: Directory -> Op
scratchDir directory =
op "scratch-directory" nodeps $ \actions ->
actions
{ help = Text.pack $ "ensures " <> path <> " exists as a salmon-owned scratch directory"
, notes =
[ "create the directory and an ownership claim inside it"
, "down removes the whole tree, only if the claim matches the directory's device and inode"
, "never adopts a directory it did not create"
]
, ref = mkRef "scratch-directory" path
, check = checkScratchDir path
, up = createScratchDir path
, down = removeScratchDir path
}
where
path :: FilePath
path = directory.directoryPath
-- | The ownership claim 'scratchDir' writes inside the directory it creates.
scratchClaimFile :: FilePath
scratchClaimFile = ".salmon-scratch-dir"
{- | Why a path may never be a 'scratchDir', if it may not. Pure part of the
guard; 'scratchPathRefusalIO' adds the home directory.
-}
scratchPathRefusal :: FilePath -> Maybe String
scratchPathRefusal path
| not (isAbsolute path) = Just "not an absolute path"
| any (`elem` [".", ".."]) components = Just "has . or .. components"
| length components < 3 = Just "is / or a top-level directory"
| otherwise = Nothing
where
-- splitDirectories "/a/b" == ["/", "a", "b"]
components = splitDirectories path
scratchPathRefusalIO :: FilePath -> IO (Maybe String)
scratchPathRefusalIO path = case scratchPathRefusal path of
Just r -> pure (Just r)
Nothing -> do
home <- either (const Nothing) Just <$> (try getHomeDirectory :: IO (Either IOException FilePath))
pure $ case home of
Just h
| isAbsolute h
, splitDirectories path `isPrefixOf` splitDirectories h ->
Just "is the home directory or one of its ancestors"
_ -> Nothing
-- | The claim's text: a fixed header, the declared path, device and inode.
renderScratchClaim :: FilePath -> Posix.DeviceID -> Posix.FileID -> String
renderScratchClaim path dev ino =
unlines
[ "salmon-scratch-dir v1"
, "path " <> path
, "device " <> show (toInteger dev)
, "inode " <> show (toInteger ino)
]
-- | What the path holds, as far as 'scratchDir' is concerned.
data ScratchState
= ScratchAbsent
| ScratchOwned
| ScratchForeign String
deriving (Eq, Show)
scratchState :: FilePath -> IO ScratchState
scratchState path = do
refusal <- scratchPathRefusalIO path
case refusal of
Just r -> pure (ScratchForeign r)
Nothing -> do
-- lstat, so a dangling symlink is not mistaken for absence
lstat <- try (Posix.getSymbolicLinkStatus path) :: IO (Either IOException Posix.FileStatus)
case lstat of
Left e
| isDoesNotExistError e -> pure ScratchAbsent
| otherwise -> pure (ScratchForeign "cannot be inspected")
Right st
| Posix.isSymbolicLink st -> pure (ScratchForeign "is a symbolic link")
| not (Posix.isDirectory st) -> pure (ScratchForeign "is not a directory")
| otherwise -> do
let claim = path </> scratchClaimFile
claimStat <- try (Posix.getSymbolicLinkStatus claim) :: IO (Either IOException Posix.FileStatus)
case claimStat of
Right cst | Posix.isRegularFile cst -> do
there <- C8.unpack <$> ByteString.readFile claim
pure $
if there == renderScratchClaim path (Posix.deviceID st) (Posix.fileID st)
then ScratchOwned
else ScratchForeign "its ownership claim does not match this directory"
_ -> pure (ScratchForeign "has no salmon ownership claim")
checkScratchDir :: FilePath -> IO CheckResult
checkScratchDir path = do
s <- scratchState path
pure $ case s of
ScratchOwned -> Success
ScratchAbsent -> Failure ("missing: " <> Text.pack path)
ScratchForeign why -> Failure (Text.pack $ path <> " " <> why)
createScratchDir :: FilePath -> IO ()
createScratchDir path = do
s <- scratchState path
case s of
ScratchOwned -> pure ()
ScratchForeign why -> ioError (userError $ "refusing scratch directory " <> path <> ": " <> why)
ScratchAbsent -> do
createDirectoryIfMissing True (takeDirectory path)
-- not createDirectoryIfMissing: the leaf must be ours.
createDirectory path
st <- Posix.getSymbolicLinkStatus path
writeFile (path </> scratchClaimFile) (renderScratchClaim path (Posix.deviceID st) (Posix.fileID st))
removeScratchDir :: FilePath -> IO ()
removeScratchDir path = do
s <- scratchState path
case s of
ScratchAbsent -> pure ()
ScratchForeign why -> ioError (userError $ "refusing to remove " <> path <> ": " <> why)
ScratchOwned -> do
st <- Posix.getSymbolicLinkStatus path
crossing <- firstOtherDevice (Posix.deviceID st) path
case crossing of
Just p -> ioError (userError $ "refusing to remove " <> path <> ": " <> p <> " is on another filesystem")
Nothing -> removeDirectoryRecursive path
-- | The first directory under @root@ whose device differs, never following
-- a symlink.
firstOtherDevice :: Posix.DeviceID -> FilePath -> IO (Maybe FilePath)
firstOtherDevice dev root = listDirectory root >>= go . map (root </>)
where
go [] = pure Nothing
go (p : ps) = do
st <- Posix.getSymbolicLinkStatus p
if Posix.isDirectory st
then
if Posix.deviceID st /= dev
then pure (Just p)
else do
below <- firstOtherDevice dev p
maybe (go ps) (pure . Just) below
else go ps
-- | Renames @path@ to @path@ suffixed with the current UTC timestamp. A
-- no-op if @path@ is already gone.
retireDirectory :: FilePath -> IO ()
retireDirectory path = do
exists <- doesDirectoryExist path
when exists $ do
now <- getCurrentTime
let suffix = formatTime defaultTimeLocale "%Y%m%dT%H%M%SZ" now
renameDirectory path (path <> "." <> suffix)
-------------------------------------------------------------------------------
{- | Some file contents that get set once.
Default behaviour is to delete the file on down action
-}
data FileContents a = FileContents {filePath :: FilePath, contents :: a}
deriving (Eq, Ord, Show, Functor)
filecontents :: (EncodeFileContents a) => FileContents a -> Op
filecontents fcontents =
op "file-contents" (deps [enclosingdir]) $ \actions ->
actions
{ help = Text.pack $ "writes " <> path <> " with some contents"
, notes =
[ "depends on the enclosing directory"
]
-- (I6): a content-derived note, when the instance can
-- give one, is what makes a content-only re-declaration
-- a genuine 'Salmon.Op.Dag.Representative' change —
-- see 'EncodeFileContents.contentFingerprint'.
<> maybe [] (\h -> ["content-hash: " <> h]) (contentFingerprint fcontents.contents)
, ref = mkRef "file-contents" path
, check = checkFileContents fcontents
, up = ByteString.writeFile path =<< encodeFileContents fcontents.contents
, -- a `down` that throws blocks the teardown of everything the
-- node was declared on top of (here: the enclosing directory),
-- and a file that is already gone is this node's effect being
-- gone. Found by a teardown that could not remove its own
-- working directory because an earlier pass had already removed
-- the file inside it.
down = removeFileIfPresent path
}
where
enclosingdir :: Op
enclosingdir = dir (Directory $ takeDirectory path)
path :: FilePath
path = fcontents.filePath
{- | Are the bytes on disk already the bytes this node would write?
The second builtin to get a real @check@, after
'Salmon.Builtin.Nodes.Systemd.checkService', and the one that reaches the
most graphs: nearly every recipe here writes a config file. Two things it
buys that are worth separating.
Under a one-shot @run up@ it is an /optimisation with a visible consequence/:
a file whose contents already match is 'Salmon.Actions.UpDown.Skipped', so
its mtime stops moving. That is not cosmetic downstream —
'Salmon.Builtin.Nodes.Systemd.systemdService' writes its unit file through
this node and then asks systemd whether the unit needs reloading, and
systemd answers that from the file's mtime. Rewriting identical bytes every
pass therefore made @NeedDaemonReload@ true every pass, which made
@checkService@ say 'Salmon.Actions.UpDown.Failure' every pass, which
reloaded and restarted a perfectly healthy service. The unit check could not
deliver what it promised until this one existed.
Under @run serve@ it is what makes a config file /supervised/: a
'Salmon.Actions.UpDown.Immaterial' node is parked and never looks again,
where this one notices the file being edited, truncated or deleted behind
salmon's back and puts it back. It also backstops a re-declaration that
changes a node's contents without changing its 'Salmon.Op.Ref.Ref': for an
instance without a 'EncodeFileContents.contentFingerprint' (the @IO a@
one), the convergence pass still records that node as converged and skips
it, and this check — on the tending machine's own next look — is the only
thing that then notices the new content (see (I6) in
@specs/per-node-state-machines-remaining.md@). For every other instance,
'filecontents' puts the fingerprint into 'notes', so the pass itself
notices the change and re-runs this check right away instead of waiting on
the tending loop.
Comparing bytes rather than mere existence is deliberate:
'Salmon.Actions.UpDown.skipIfFileExists' would call a file with the wrong
contents satisfied, which is the failure mode this node most needs to avoid.
The comparison is cheap in the sense that matters — the node's contents are
already in hand, since 'up' is about to encode them anyway.
Three details:
* __The size is compared first__, and a mismatch answers without reading the
file. It is one @stat@, and it bounds what a node holding a few hundred
bytes will read if something else has clobbered its path with something
enormous.
* __The reason never quotes the contents.__ Failure text goes into reports,
and the files this node writes include @pgbouncer@ userlists and
@postgrest@ configurations with signing keys in them.
* __Contents are all it answers about__, because contents are all 'up' sets.
A file whose mode somebody changed still matches; nothing here ever set
the mode, so there is nothing to restore.
One hazard, for the @'EncodeFileContents' (IO a)@ instance only: the check
runs the encoder, so a generator with side effects runs once more per look,
and one that is not deterministic (a timestamp) makes this always answer
'Salmon.Actions.UpDown.Failure' and rewrite the file on every pass. That is
the safe direction rather than a correctness problem, but a node built that
way should either be given a stable encoder or set its own 'check'.
-}
checkFileContents :: (EncodeFileContents a) => FileContents a -> IO CheckResult
checkFileContents fcontents = do
exists <- doesFileExist path
if not exists
then pure (Failure ("missing: " <> Text.pack path))
else do
wanted <- encodeFileContents fcontents.contents
size <- getFileSize path
if size /= fromIntegral (ByteString.length wanted)
then pure (Failure ("wrong size: " <> Text.pack path))
else do
there <- ByteString.readFile path
pure $
if there == wanted
then Success
else Failure ("contents differ: " <> Text.pack path)
where
path :: FilePath
path = fcontents.filePath
{- | Utility class to write various file contents.
The Text instance encodes contents in UTF8.
-}
class EncodeFileContents a where
encodeFileContents :: a -> IO ByteString.ByteString
{- | A pure, stable fingerprint of the content this would write — (I6):
what lets 'filecontents' put something content-derived into 'notes', so
a re-declaration that only changes this node's content is a genuine
'Salmon.Op.Dag.Representative' change (@Serve.record@'s 'changed' set)
rather than one indistinguishable from "nothing changed". 'Nothing' —
the default, and what the @IO a@ instance below must keep — opts a type
out: its whole point is that the content isn't known until
'encodeFileContents' actually runs, so nothing pure is available to put
here, and (per 'checkFileContents'\'s haddock) that generator already
has its own hazards to manage.
-}
contentFingerprint :: a -> Maybe Text.Text
contentFingerprint _ = Nothing
instance EncodeFileContents Text.Text where
encodeFileContents = pure . Text.encodeUtf8
contentFingerprint = Just . hashBytes . Text.encodeUtf8
instance EncodeFileContents ByteString.ByteString where
encodeFileContents = pure . id
contentFingerprint = Just . hashBytes
instance EncodeFileContents String where
encodeFileContents = pure . C8.pack
contentFingerprint = Just . hashBytes . C8.pack
instance EncodeFileContents Aeson.Value where
encodeFileContents = pure . LBytestring.toStrict . Aeson.encode
contentFingerprint = Just . hashBytes . LBytestring.toStrict . Aeson.encode
instance (EncodeFileContents a) => EncodeFileContents (IO a) where
encodeFileContents ioX = ioX >>= encodeFileContents
-- default (Nothing) is correct here: deliberately not overridden.
-- | The same short, stable, content-derived tag 'Salmon.Actions.Query.shortRef'
-- uses for a 'Salmon.Op.Ref.Ref', applied to a file's content instead.
hashBytes :: ByteString.ByteString -> Text.Text
hashBytes = Text.take 12 . Text.decodeUtf8 . Base64.URL.encode . SHA256.hash
-------------------------------------------------------------------------------
fileCopy :: FilePath -> FilePath -> Op
fileCopy src tgt =
op "file-copy" (deps [enclosingdir]) $ \actions ->
actions
{ help = Text.pack $ "copies " <> src <> " " <> tgt
, ref = mkRef "file-copy" (src, tgt)
, up = copyFile src tgt
, down = removeFile tgt
}
where
enclosingdir :: Op
enclosingdir = dir (Directory $ takeDirectory tgt)
-------------------------------------------------------------------------------
moveDirectory :: FilePath -> FilePath -> (Extension -> Extension) -> Op
moveDirectory src tgt modActions =
op "move-dir" (deps [enclosingdir]) $ \actions ->
modActions $
actions
{ help = Text.pack $ "moves " <> src <> " " <> tgt
, ref = mkRef "move-dir" (src, tgt)
, up = renameDirectory src tgt
}
where
enclosingdir :: Op
enclosingdir = dir (Directory $ takeDirectory tgt)
-------------------------------------------------------------------------------
replaceDirectory :: FilePath -> FilePath -> FilePath -> Op
replaceDirectory src tgt trash =
op "replace-dir" (deps [delete3 `inject` move2 `inject` move1]) $ \actions ->
actions
{ help = Text.pack $ "replace " <> src <> " " <> tgt
, ref = mkRef "replace-dir" (src, tgt)
}
where
move1 :: Op
move1 = moveDirectory tgt trash $ \actions ->
actions{check = skipIfDirectoryIsMissing tgt}
move2 :: Op
move2 = moveDirectory src tgt id
delete3 :: Op
delete3 = destroyDirectory trash
-------------------------------------------------------------------------------
destroyDirectory :: FilePath -> Op
destroyDirectory trash =
op "delete-dir" nodeps $ \actions ->
actions
{ help = Text.pack $ "recursively trashes " <> trash
, ref = mkRef "delete-dir" trash
, up = removeDirectoryRecursive trash
, check = skipIfDirectoryIsMissing trash
}
-------------------------------------------------------------------------------
data File (sym :: Symbol)
= PreExisting FilePath
| Generated (Track' FilePath) FilePath
getFilePath :: File a -> FilePath
getFilePath (PreExisting path) = path
getFilePath (Generated _ path) = path
fileOp :: File a -> Op
fileOp (PreExisting path) = placeholder "pre-existing-file" (Text.pack path)
fileOp (Generated t path) = run t path
withFile :: File a -> (FilePath -> Op) -> Op
withFile file@(PreExisting path) f = f path `inject` fileOp file
withFile (Generated mkp path) f = tracking mkp (\x -> (x, x)) path f
generateFileContents :: (EncodeFileContents a) => a -> FilePath -> File b
generateFileContents c path =
Generated (Track $ \_ -> filecontents $ FileContents path c) path
-- | 'removeFile', tolerating a file that is already gone.
removeFileIfPresent :: FilePath -> IO ()
removeFileIfPresent path = do
exists <- doesFileExist path
when exists (removeFile path)
-- | 'removeDirectory', tolerating a directory that is already gone.
removeDirectoryIfPresent :: FilePath -> IO ()
removeDirectoryIfPresent path = do
exists <- doesDirectoryExist path
when exists (removeDirectory path)
-------------------------------------------------------------------------------
-- | A line to ensure is present in a file, appending it if missing.
data AppendLineIfMissing = AppendLineIfMissing {appendLineFilePath :: FilePath, appendLineText :: Text.Text}
{- | Idempotent append: ensures a line is present in a file, appending it if
not already there verbatim (@grep -qxF ... || echo ... >>@, done in-process
rather than via a shell) — the same "append-if-missing" shape used for
@pg_hba.conf@ lines (see @Salmon.Builtin.Nodes.Postgres.ensureHbaLineScript@),
generalized to any file. Does not truncate or otherwise touch the file if the
line is already present. Creates the enclosing directory but not the file
itself (an absent file is treated as empty, and the append creates it).
-}
appendLineIfMissing :: AppendLineIfMissing -> Op
appendLineIfMissing item =
op "append-line-if-missing" (deps [enclosingdir]) $ \actions ->
actions
{ help = Text.pack $ "ensures a line is present in " <> path
, notes = ["append-if-missing", "does not truncate or delete existing lines"]
, ref = mkRef "append-line-if-missing" (path, item.appendLineText)
, up = ensureLine
}
where
path :: FilePath
path = item.appendLineFilePath
enclosingdir :: Op
enclosingdir = dir (Directory $ takeDirectory path)
ensureLine :: IO ()
ensureLine = do
exists <- doesFileExist path
contents <- if exists then Text.decodeUtf8 <$> ByteString.readFile path else pure ""
if item.appendLineText `elem` Text.lines contents
then pure ()
else ByteString.appendFile path (Text.encodeUtf8 $ item.appendLineText <> "\n")
-------------------------------------------------------------------------------
{- | The owner and mode a file must end up with, as a node of its own.
Declared separately from whatever /creates/ the file because the two are
usually authored by different parties: 'filecontents' or 'fileCopy' knows the
bytes, and only the service that will read them knows it must be
@postgres:postgres@ and @0600@. Keeping them apart also keeps the enforcement
idempotent — this node's whole effect is a @chown@ and a @chmod@, so a
re-run is a stat and nothing else.
The motivating case, and the one worth knowing about: Postgres __refuses to
start__ if @ssl_key_file@ is group- or world-readable, and @libpq@ applies
the same rule to a client key. Both fail with a message about permissions
rather than about TLS, some way from the node that wrote the file.
-}
data FileOwnership = FileOwnership
{ ownedPath :: FilePath
, ownedUser :: Maybe Text.Text
-- ^ 'Nothing' leaves the owning user alone.
, ownedGroup :: Maybe Text.Text
, ownedMode :: Posix.FileMode
-- ^ the permission bits, e.g. @0o600@.
}
{- | Ensures a file is owned by 'ownedUser'\/'ownedGroup' and has exactly
'ownedMode'.
The @check@ compares what is on disk, so a file already in the right state is
skipped; a file that is *missing* is a 'Failure' rather than something this
node creates, because the node that owns the bytes is the one that should
have made it and reporting otherwise would hide that failure behind this one.
When 'ownedPath' is a directory, the ownership (but not 'ownedMode') is
applied __recursively__ to everything already underneath it: a rootfs handed
over to an unprivileged user has packages installed into it (openssh-server's
@sshd_config.d@, say) that own only their own top-level entry, and a caller
declaring "this whole subtree is now theirs" means exactly that, not "the
directory entry is theirs but whatever some package dropped inside it stays
root's". Only the directory entry itself gets 'ownedMode' applied (as
before); every descendant keeps its own permission bits — chown, not chmod,
since a config file wanting @0644@ and a host key wanting @0600@ underneath
the same handed-over directory must not both end up at whatever single mode
the caller gave the top of the tree. A missing directory is still a
'Failure', same as a missing file, since walking a tree that is not there
would have nothing to walk.
-}
ownedFile :: FileOwnership -> Op
ownedFile owner =
op "file-ownership" nodeps $ \actions ->
actions
{ help = Text.pack $ "owns " <> owner.ownedPath
, notes = [Text.pack $ "mode " <> showOctalMode owner.ownedMode]
, ref = mkRef "file-ownership" owner.ownedPath
, check = checkOwnership owner
, up = applyOwnership owner
, -- Ownership is not an effect that can be removed on its own:
-- there is no "unowned" state to return the file to, and the
-- node holding the bytes deletes it outright.
down = pure ()
}
showOctalMode :: Posix.FileMode -> String
showOctalMode m = "0o" <> showOct (toInteger m) ""
{- | Resolves the wanted ids and compares them, plus the permission bits,
against the file's current status -- and, for a directory, against every
entry underneath it too (see 'ownedFile').
Note this uses 'doesPathExist' rather than 'doesFileExist': the latter is
'False' for a directory, which used to make this check report every
directory-shaped 'ownedFile' as permanently missing, no matter what @up@ had
already done to it.
-}
checkOwnership :: FileOwnership -> IO CheckResult
checkOwnership owner = do
exists <- doesPathExist owner.ownedPath
if not exists
then pure (Failure $ "missing: " <> Text.pack owner.ownedPath)
else do
status <- Posix.getFileStatus owner.ownedPath
wantedUid <- traverse lookupUid owner.ownedUser
wantedGid <- traverse lookupGid owner.ownedGroup
let actualMode = Posix.fileMode status .&. permissionBits
treeIssue <- checkTreeOwnership wantedUid wantedGid owner.ownedPath
pure $ case () of
_
| actualMode /= owner.ownedMode ->
Failure $
Text.pack $
owner.ownedPath <> " is " <> showOctalMode actualMode <> ", wanted " <> showOctalMode owner.ownedMode
| maybe False (/= Posix.fileOwner status) wantedUid ->
Failure $ "wrong owner: " <> Text.pack owner.ownedPath
| maybe False (/= Posix.fileGroup status) wantedGid ->
Failure $ "wrong group: " <> Text.pack owner.ownedPath
| Just reason <- treeIssue -> Failure reason
| otherwise -> Success
applyOwnership :: FileOwnership -> IO ()
applyOwnership owner = do
uid <- maybe (pure (-1)) lookupUid owner.ownedUser
gid <- maybe (pure (-1)) lookupGid owner.ownedGroup
-- chown before chmod: chown clears setuid/setgid bits, so doing it the
-- other way round silently drops them.
Posix.setOwnerAndGroup owner.ownedPath uid gid
Posix.setFileMode owner.ownedPath owner.ownedMode
isDir <- doesDirectoryExist owner.ownedPath
when isDir $ do
entries <- treeEntries owner.ownedPath
mapM_ (chownEntry uid gid) entries
-- | The bits 'ownedMode' speaks about: permissions and the set-id/sticky
-- trio, never the file-type bits 'Posix.fileMode' also carries.
permissionBits :: Posix.FileMode
permissionBits = 0o7777
-- | Every descendant of a directory -- files, directories and symlinks
-- alike -- depth-first, without ever following a symlink into whatever it
-- points at (so a symlink under a handed-over tree is chowned itself, its
-- target is somebody else's business, and a symlink cycle can't loop this).
treeEntries :: FilePath -> IO [FilePath]
treeEntries path = do
names <- listDirectory path
let children = map (path </>) names
descendants <- concat <$> traverse recurse children
pure (children <> descendants)
where
recurse child = do
isSymlink <- pathIsSymbolicLink child
if isSymlink
then pure []
else do
isDir <- doesDirectoryExist child
if isDir then treeEntries child else pure []
-- | 'Nothing' means "checked only what 'checkOwnership' also checks at the
-- top" (not a directory, or nothing underneath owned wrong); reports the
-- first mismatch found, same shape as the top-level checks above.
checkTreeOwnership :: Maybe Posix.UserID -> Maybe Posix.GroupID -> FilePath -> IO (Maybe Text.Text)
checkTreeOwnership wantedUid wantedGid path = do
isDir <- doesDirectoryExist path
if not isDir
then pure Nothing
else do
entries <- treeEntries path
go entries
where
go [] = pure Nothing
go (p : ps) = do
st <- Posix.getSymbolicLinkStatus p
if maybe False (/= Posix.fileOwner st) wantedUid
then pure (Just $ "wrong owner: " <> Text.pack p)
else
if maybe False (/= Posix.fileGroup st) wantedGid
then pure (Just $ "wrong group: " <> Text.pack p)
else go ps
-- | Never follows a symlink to chown whatever it points at.
chownEntry :: Posix.UserID -> Posix.GroupID -> FilePath -> IO ()
chownEntry uid gid path = do
isSymlink <- pathIsSymbolicLink path
if isSymlink
then Posix.setSymbolicLinkOwnerAndGroup path uid gid
else Posix.setOwnerAndGroup path uid gid
lookupUid :: Text.Text -> IO Posix.UserID
lookupUid name = PosixUser.userID <$> PosixUser.getUserEntryForName (Text.unpack name)
lookupGid :: Text.Text -> IO Posix.GroupID
lookupGid name = PosixUser.groupID <$> PosixUser.getGroupEntryForName (Text.unpack name)