diff options
Diffstat (limited to 'source/Render/Html/Output.hs')
| -rw-r--r-- | source/Render/Html/Output.hs | 471 |
1 files changed, 0 insertions, 471 deletions
diff --git a/source/Render/Html/Output.hs b/source/Render/Html/Output.hs deleted file mode 100644 index 685c83a..0000000 --- a/source/Render/Html/Output.hs +++ /dev/null @@ -1,471 +0,0 @@ -{-# 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.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))) |