diff options
Diffstat (limited to 'source/Render')
| -rw-r--r-- | source/Render/Html.hs | 7 | ||||
| -rw-r--r-- | source/Render/Html/Output.hs | 263 |
2 files changed, 265 insertions, 5 deletions
diff --git a/source/Render/Html.hs b/source/Render/Html.hs index 01ac638..71f1668 100644 --- a/source/Render/Html.hs +++ b/source/Render/Html.hs @@ -5,7 +5,6 @@ module Render.Html ( renderDocument - , supportScriptAssetOutputPath , supportScriptAssetContents ) where @@ -15,6 +14,7 @@ import Base import Lucid hiding (Term, for_) import Lucid.Base (makeAttributes) import Lucid.Math +import Render.Html.Output (supportScriptAssetOutputPath) import Control.Monad (unless, when) import Data.Char (digitToInt, isAlphaNum, isDigit, isSpace, toUpper) @@ -525,12 +525,9 @@ pageStyles = Text.unlines , "}" ] -supportScriptAssetOutputPath :: FilePath -supportScriptAssetOutputPath = "_static" </> "naproche-html.js" - supportScriptAssetRelativePath :: FilePath -> FilePath supportScriptAssetRelativePath inputPath = - foldr1 (</>) (replicate depth ".." <> ["_static", "naproche-html.js"]) + foldr1 (</>) (replicate depth ".." <> [supportScriptAssetOutputPath]) where outputDir = takeDirectory (replaceExtension inputPath "html") depth = length (List.filter (`notElem` [".", ""]) (splitDirectories outputDir)) diff --git a/source/Render/Html/Output.hs b/source/Render/Html/Output.hs new file mode 100644 index 0000000..ef36b94 --- /dev/null +++ b/source/Render/Html/Output.hs @@ -0,0 +1,263 @@ +{-# 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 + ( HtmlOutputPlan + , HtmlOutputError(..) + , PreparedHtmlOutput + , planHtmlOutput + , preparedHtmlOutput + , writeHtmlOutput + , supportScriptAssetOutputPath + ) where + +import Base +import Felix.Source + ( RelativePathError + , safeRelativePath + , safeRelativePathFilePath + ) + +import Control.Exception (Exception, displayException) +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.Text qualified as Text +import System.Directory qualified as Directory +import System.FilePath.Posix qualified as Posix +import System.Posix.Files qualified as PosixFiles + + +-- The constructor and paths stay private so only this module can write them. +data HtmlOutputPlan = HtmlOutputPlan + !FilePath + !FilePath + +data HtmlOutputError + = EmptyHtmlOutputRoot + | InvalidHtmlInputRoute !FilePath !RelativePathError + | InvalidDerivedHtmlRoute !FilePath !RelativePathError + | CollidingHtmlOutputRoutes !FilePath + | HtmlOutputPathInspectionFailed !FilePath !Text + | HtmlOutputRootNotDirectory !FilePath + | HtmlOutputParentNotDirectory !FilePath + | HtmlOutputParentEscapesRoot !FilePath !FilePath + | HtmlOutputTargetIsSymbolicLink !FilePath + | HtmlOutputTargetNotRegularFile !FilePath + deriving stock (Show, Eq) + +instance Exception HtmlOutputError + +-- Strict bytes are prepared before the writer receives any authority. +data PreparedHtmlOutput = PreparedHtmlOutput + !ByteString + !ByteString + +preparedHtmlOutput :: ByteString -> ByteString -> PreparedHtmlOutput +preparedHtmlOutput = PreparedHtmlOutput + + +-- | Validate and preflight every destination without changing the filesystem. +planHtmlOutput + :: FilePath + -> FilePath + -> IO (Either HtmlOutputError HtmlOutputPlan) +planHtmlOutput outputRoot inputSpelling = runExceptT do + when (null outputRoot) (throwE EmptyHtmlOutputRoot) + inputRoute <- + either + (throwE . InvalidHtmlInputRoute inputSpelling) + pure + (safeRelativePath inputSpelling) + let pageRouteSpelling = + Posix.replaceExtension + (safeRelativePathFilePath inputRoute) + "html" + pageRoute <- + either + (throwE . InvalidDerivedHtmlRoute pageRouteSpelling) + pure + (safeRelativePath pageRouteSpelling) + supportRoute <- + either + (throwE . InvalidDerivedHtmlRoute supportScriptAssetOutputPath) + pure + (safeRelativePath supportScriptAssetOutputPath) + when + (pageRoute == supportRoute) + (throwE (CollidingHtmlOutputRoutes pageRouteSpelling)) + + 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) + + let pageComponents = + Posix.splitDirectories (safeRelativePathFilePath pageRoute) + supportComponents = + Posix.splitDirectories (safeRelativePathFilePath supportRoute) + pageDestination = confinedDestination absoluteRoot pageComponents + supportDestination = + confinedDestination absoluteRoot supportComponents + preflightDestination canonicalRoot absoluteRoot pageComponents pageDestination + preflightDestination + canonicalRoot + absoluteRoot + supportComponents + supportDestination + pure + (HtmlOutputPlan + pageDestination + supportDestination) + + +-- | Write the two preflighted artifacts as binary strict bytes. +writeHtmlOutput :: HtmlOutputPlan -> PreparedHtmlOutput -> IO () +writeHtmlOutput + (HtmlOutputPlan pageDestination supportDestination) + (PreparedHtmlOutput pageBytes supportBytes) = do + traverse_ + (Directory.createDirectoryIfMissing True . Posix.takeDirectory) + [pageDestination, supportDestination] + replaceFile pageDestination pageBytes + replaceFile supportDestination supportBytes + +replaceFile :: FilePath -> ByteString -> IO () +replaceFile destination bytes = + bracketOnError + (openBinaryTempFileWithDefaultPermissions + (Posix.takeDirectory destination) + (Posix.takeFileName destination <> ".tmp")) + cleanupTemporary + \(temporary, handle) -> do + ByteString.hPut handle bytes + hFlush handle + hClose handle + Directory.renameFile temporary destination + +cleanupTemporary :: (FilePath, Handle) -> IO () +cleanupTemporary (temporary, handle) = do + void (tryIOError (hClose handle)) + void (tryIOError (Directory.removeFile temporary)) + + +supportScriptAssetOutputPath :: FilePath +supportScriptAssetOutputPath = "_static" Posix.</> "naproche-html.js" + + +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))) |