path: root/source/Render/Html/Output.hs

{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE NoImplicitPrelude #-}

-- | Confined filesystem authority for HTML output.
--
-- The output root is assumed to be user-owned and not concurrently changed by
-- a hostile actor between planning and writing. Existing parent symlinks are
-- accepted only when they resolve inside the canonical root. Final-target
-- symlinks are rejected without following them; regular generated files may be
-- replaced. This policy prevents stable-tree escapes, not TOCTOU attacks.
module Render.Html.Output
    ( PreparedHtmlArtifact
    , preparedHtmlArtifact
    , preparedHtmlArtifactDestination
    , HtmlRoutePlan
    , htmlRoutePlanDestinations
    , planHtmlRoutes
    , HtmlOutputPlan
    , HtmlOutputError(..)
    , renderHtmlOutputError
    , planHtmlOutput
    , planHtmlOutputAgainst
    , HtmlPublicationError(..)
    , renderHtmlPublicationError
    , writeHtmlOutput
    ) where

import Base
import Felix.Source
    ( SafeRelativePath
    , safeRelativePathFilePath
    )

import Control.Exception (Exception, IOException, displayException)
import Control.Exception qualified as Exception
import Control.Monad (unless, when)
import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)
import Data.ByteString (ByteString)
import Data.ByteString qualified as ByteString
import Data.List qualified as List
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Data.Text qualified as Text
import System.Directory qualified as Directory
import System.FilePath.Posix qualified as Posix
import System.Posix.Files qualified as PosixFiles


-- | One lazily rendered artifact.  The destination is available for complete
-- preflight without demanding the strict bytes or a renderer failure.
data PreparedHtmlArtifact = PreparedHtmlArtifact
    !SafeRelativePath
    (Either Text ByteString)

preparedHtmlArtifact
    :: SafeRelativePath
    -> Either Text ByteString
    -> PreparedHtmlArtifact
preparedHtmlArtifact =
    PreparedHtmlArtifact

preparedHtmlArtifactDestination
    :: PreparedHtmlArtifact
    -> SafeRelativePath
preparedHtmlArtifactDestination
        (PreparedHtmlArtifact destination _rendered) =
    destination


-- Constructors and absolute paths stay private to this module.
newtype HtmlRoutePlan = HtmlRoutePlan
    [(SafeRelativePath, FilePath)]

htmlRoutePlanDestinations
    :: HtmlRoutePlan
    -> [(SafeRelativePath, FilePath)]
htmlRoutePlanDestinations (HtmlRoutePlan routes) =
    routes

newtype HtmlOutputPlan = HtmlOutputPlan
    [PlannedHtmlArtifact]

data PlannedHtmlArtifact = PlannedHtmlArtifact
    !SafeRelativePath
    !FilePath
    (Either Text ByteString)

data HtmlOutputError
    = EmptyPreparedHtmlOutput
    | DuplicatePreparedHtmlDestination !SafeRelativePath
    | HtmlOutputRouteMismatch
        ![SafeRelativePath]
        ![SafeRelativePath]
    | EmptyHtmlOutputRoot
    | HtmlOutputPathInspectionFailed !FilePath !Text
    | HtmlOutputRootNotDirectory !FilePath
    | HtmlOutputParentNotDirectory !FilePath
    | HtmlOutputParentEscapesRoot !FilePath !FilePath
    | HtmlOutputTargetIsSymbolicLink !FilePath
    | HtmlOutputTargetNotRegularFile !FilePath
    deriving stock (Show, Eq)

renderHtmlOutputError :: HtmlOutputError -> Text
renderHtmlOutputError = \case
    EmptyPreparedHtmlOutput ->
        "HTML output contains no artifacts"
    DuplicatePreparedHtmlDestination relative ->
        "HTML output contains destination more than once: "
            <> quoteRelative relative
    HtmlOutputRouteMismatch planned prepared ->
        "prepared HTML destinations do not match the reserved routes; planned "
            <> renderRelatives planned <> ", prepared " <> renderRelatives prepared
    EmptyHtmlOutputRoot ->
        "HTML output root is empty"
    HtmlOutputPathInspectionFailed path reason ->
        "could not inspect HTML output path " <> quotePath path <> ": " <> reason
    HtmlOutputRootNotDirectory path ->
        "HTML output root is not a directory: " <> quotePath path
    HtmlOutputParentNotDirectory path ->
        "HTML output parent is not a directory: " <> quotePath path
    HtmlOutputParentEscapesRoot root parent ->
        "HTML output parent " <> quotePath parent
            <> " resolves outside root " <> quotePath root
    HtmlOutputTargetIsSymbolicLink path ->
        "HTML output target is a symbolic link: " <> quotePath path
    HtmlOutputTargetNotRegularFile path ->
        "HTML output target is not a regular file: " <> quotePath path
  where
    renderRelatives = Text.intercalate ", " . fmap quoteRelative

quoteRelative :: SafeRelativePath -> Text
quoteRelative = quotePath . safeRelativePathFilePath

quotePath :: FilePath -> Text
quotePath = Text.pack . show

instance Exception HtmlOutputError

-- | Validate every destination without changing the filesystem.
planHtmlOutput
    :: FilePath
    -> [PreparedHtmlArtifact]
    -> IO (Either HtmlOutputError HtmlOutputPlan)
planHtmlOutput outputRoot artifacts = do
    routes <- planHtmlRoutes
        outputRoot
        (preparedHtmlArtifactDestination <$> artifacts)
    pure (routes >>= (`planHtmlOutputAgainst` artifacts))

planHtmlRoutes
    :: FilePath
    -> [SafeRelativePath]
    -> IO (Either HtmlOutputError HtmlRoutePlan)
planHtmlRoutes outputRoot destinations =
    runExceptT do
        when (null destinations)
            (throwE EmptyPreparedHtmlOutput)
        case duplicateDestinations destinations of
            duplicate : _ ->
                throwE
                    (DuplicatePreparedHtmlDestination duplicate)
            [] ->
                pure ()
        when (null outputRoot) (throwE EmptyHtmlOutputRoot)
        absoluteRoot <-
            inspectPath
                outputRoot
                (Directory.makeAbsolute outputRoot)
        rootIsLink <- inspectSymbolicLink absoluteRoot
        rootExists <-
            inspectPath
                absoluteRoot
                (Directory.doesPathExist absoluteRoot)
        rootIsDirectory <-
            inspectPath
                absoluteRoot
                (Directory.doesDirectoryExist absoluteRoot)
        when
            ((rootIsLink || rootExists) && not rootIsDirectory)
            (throwE (HtmlOutputRootNotDirectory absoluteRoot))
        canonicalRoot <-
            inspectPath
                absoluteRoot
                (Directory.canonicalizePath absoluteRoot)
        planned <- for (List.sort destinations)
            \relative -> do
                let components =
                        Posix.splitDirectories
                            (safeRelativePathFilePath relative)
                    destination =
                        confinedDestination
                            absoluteRoot
                            components
                preflightDestination
                    canonicalRoot
                    absoluteRoot
                    components
                    destination
                pure
                    ( relative
                    , destination
                    )
        pure (HtmlRoutePlan planned)

planHtmlOutputAgainst
    :: HtmlRoutePlan
    -> [PreparedHtmlArtifact]
    -> Either HtmlOutputError HtmlOutputPlan
planHtmlOutputAgainst
        (HtmlRoutePlan routes)
        artifacts
    | null artifacts =
        Left EmptyPreparedHtmlOutput
    | duplicate : _ <- duplicateDestinations preparedDestinations =
        Left (DuplicatePreparedHtmlDestination duplicate)
    | Set.fromList plannedDestinations
        /= Set.fromList preparedDestinations =
        Left
            (HtmlOutputRouteMismatch
                plannedDestinations
                preparedDestinations)
    | otherwise = HtmlOutputPlan <$> traverse attach artifacts
  where
    plannedDestinations = fst <$> routes
    preparedDestinations =
        preparedHtmlArtifactDestination <$> artifacts
    routeDestinations = Map.fromList routes

    attach (PreparedHtmlArtifact relative rendered) =
        case Map.lookup relative routeDestinations of
            Nothing ->
                Left
                    (HtmlOutputRouteMismatch
                        plannedDestinations
                        preparedDestinations)
            Just destination ->
                Right
                    (PlannedHtmlArtifact
                        relative
                        destination
                        rendered)

duplicateDestinations
    :: [SafeRelativePath]
    -> [SafeRelativePath]
duplicateDestinations destinations =
    [ destination
    | (destination, multiplicity) <-
        Map.toAscList
            (Map.fromListWith (+)
                [ (destination, 1 :: Int)
                | destination <- destinations
                ])
    , multiplicity > 1
    ]


data HtmlPublicationError = IncompleteHtmlPublication
    { committedHtmlDestinations :: ![SafeRelativePath]
    , failedHtmlDestination :: !SafeRelativePath
    , htmlPublicationFailure :: !Text
    }
    deriving stock (Show, Eq)

instance Exception HtmlPublicationError

renderHtmlPublicationError :: HtmlPublicationError -> [Text]
renderHtmlPublicationError failure =
    [ "HTML publication failed at "
        <> quoteRelative (failedHtmlDestination failure)
        <> ": " <> htmlPublicationFailure failure
    ]
        <> case committedHtmlDestinations failure of
            [] -> []
            committed ->
                [ "HTML files published before the failure: "
                    <> Text.intercalate ", "
                        (quoteRelative <$> committed)
                ]

-- | Render, stage, and atomically replace each completely preflighted artifact
-- in the supplied source order.  No later artifact is rendered or staged
-- before the preceding destination has been replaced.
writeHtmlOutput
    :: HtmlOutputPlan
    -> IO (Either HtmlPublicationError ())
writeHtmlOutput (HtmlOutputPlan planned) =
    publishAll [] planned

publishAll
    :: [SafeRelativePath]
    -> [PlannedHtmlArtifact]
    -> IO (Either HtmlPublicationError ())
publishAll _committed [] =
    pure (Right ())
publishAll
        committedReversed
        (PlannedHtmlArtifact relative destination rendered : remaining) =
    case rendered of
        Left failure ->
            pure
                (Left
                    (IncompleteHtmlPublication
                        { committedHtmlDestinations =
                            reverse committedReversed
                        , failedHtmlDestination = relative
                        , htmlPublicationFailure = failure
                        }))
        Right bytes -> do
            result <-
                tryIOException
                    (stageAndReplace destination bytes)
            case result of
                Left err ->
                    pure
                        (Left
                            (publicationError
                                (reverse committedReversed)
                                relative
                                err))
                Right () ->
                    publishAll
                        (relative : committedReversed)
                        remaining

stageAndReplace
    :: FilePath
    -> ByteString
    -> IO ()
stageAndReplace destination bytes = do
    let directory = Posix.takeDirectory destination
    Directory.createDirectoryIfMissing True directory
    bracketOnError
        (openBinaryTempFileWithDefaultPermissions
            directory
            (Posix.takeFileName destination <> ".tmp"))
        cleanupTemporary
        \(temporary, handle) -> do
            ByteString.hPut handle bytes
            hFlush handle
            hClose handle
            Directory.renameFile temporary destination

publicationError
    :: [SafeRelativePath]
    -> SafeRelativePath
    -> IOException
    -> HtmlPublicationError
publicationError committed failed err =
    IncompleteHtmlPublication
        { committedHtmlDestinations = committed
        , failedHtmlDestination = failed
        , htmlPublicationFailure =
            Text.pack (displayException err)
        }

cleanupTemporary :: (FilePath, Handle) -> IO ()
cleanupTemporary (temporary, handle) = do
    void (tryIOError (hClose handle))
    void (tryIOError (Directory.removeFile temporary))

tryIOException :: IO a -> IO (Either IOException a)
tryIOException =
    Exception.try


preflightDestination
    :: FilePath
    -> FilePath
    -> [FilePath]
    -> FilePath
    -> ExceptT HtmlOutputError IO ()
preflightDestination canonicalRoot outputRoot components destination = do
    traverse_
        (preflightParent canonicalRoot)
        (destinationParents outputRoot components)
    preflightTarget destination

destinationParents :: FilePath -> [FilePath] -> [FilePath]
destinationParents root components =
    take
        (length components)
        (scanl (Posix.</>) root components)

confinedDestination :: FilePath -> [FilePath] -> FilePath
confinedDestination =
    foldl' (Posix.</>)

preflightParent
    :: FilePath
    -> FilePath
    -> ExceptT HtmlOutputError IO ()
preflightParent canonicalRoot parent = do
    parentIsLink <- inspectSymbolicLink parent
    parentExists <-
        inspectPath parent (Directory.doesPathExist parent)
    parentIsDirectory <-
        inspectPath parent (Directory.doesDirectoryExist parent)
    when (parentIsLink || parentExists) do
        unless
            parentIsDirectory
            (throwE (HtmlOutputParentNotDirectory parent))
        canonicalParent <-
            inspectPath
                parent
                (Directory.canonicalizePath parent)
        unless
            (isComponentwiseChild canonicalRoot canonicalParent)
            (throwE
                (HtmlOutputParentEscapesRoot
                    parent
                    canonicalParent))

preflightTarget
    :: FilePath
    -> ExceptT HtmlOutputError IO ()
preflightTarget target = do
    statusResult <-
        liftIO
            (tryIOError
                (PosixFiles.getSymbolicLinkStatus target))
    case statusResult of
        Left err
            | isDoesNotExistError err ->
                pure ()
            | otherwise ->
                throwE
                    (HtmlOutputPathInspectionFailed
                        target
                        (Text.pack (displayException err)))
        Right status
            | PosixFiles.isSymbolicLink status ->
                throwE
                    (HtmlOutputTargetIsSymbolicLink target)
            | PosixFiles.isRegularFile status ->
                pure ()
            | otherwise ->
                throwE
                    (HtmlOutputTargetNotRegularFile target)

isComponentwiseChild :: FilePath -> FilePath -> Bool
isComponentwiseChild root child =
    canonicalComponents root
        `List.isPrefixOf`
            canonicalComponents child

canonicalComponents :: FilePath -> [FilePath]
canonicalComponents =
    Posix.splitDirectories
        . Posix.dropTrailingPathSeparator

inspectSymbolicLink
    :: FilePath
    -> ExceptT HtmlOutputError IO Bool
inspectSymbolicLink path = do
    result <-
        liftIO
            (tryIOError
                (Directory.pathIsSymbolicLink path))
    case result of
        Right isLink ->
            pure isLink
        Left err
            | isDoesNotExistError err ->
                pure False
            | otherwise ->
                throwE
                    (HtmlOutputPathInspectionFailed
                        path
                        (Text.pack (displayException err)))

inspectPath
    :: FilePath
    -> IO a
    -> ExceptT HtmlOutputError IO a
inspectPath path action = do
    result <- liftIO (tryIOError action)
    case result of
        Right value ->
            pure value
        Left err ->
            throwE
                (HtmlOutputPathInspectionFailed
                    path
                    (Text.pack (displayException err)))