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.Monad (when)
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 (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

-- | 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)