diff options
Diffstat (limited to 'source/Felix/Render/Html/Output.hs')
| -rw-r--r-- | source/Felix/Render/Html/Output.hs | 471 |
1 files changed, 471 insertions, 0 deletions
diff --git a/source/Felix/Render/Html/Output.hs b/source/Felix/Render/Html/Output.hs new file mode 100644 index 0000000..8e36f97 --- /dev/null +++ b/source/Felix/Render/Html/Output.hs @@ -0,0 +1,471 @@ +{-# 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 Felix.Render.Html.Output + ( PreparedHtmlArtifact + , preparedHtmlArtifact + , preparedHtmlArtifactDestination + , HtmlRoutePlan + , htmlRoutePlanDestinations + , planHtmlRoutes + , HtmlOutputPlan + , HtmlOutputError(..) + , renderHtmlOutputError + , planHtmlOutput + , planHtmlOutputAgainst + , HtmlPublicationError(..) + , renderHtmlPublicationError + , writeHtmlOutput + ) where + +import Base +import Felix.Output.Atomic (writeBytesAtomically) +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.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 + writeBytesAtomically destination bytes + +publicationError + :: [SafeRelativePath] + -> SafeRelativePath + -> IOException + -> HtmlPublicationError +publicationError committed failed err = + IncompleteHtmlPublication + { committedHtmlDestinations = committed + , failedHtmlDestination = failed + , htmlPublicationFailure = + Text.pack (displayException err) + } + +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))) |