Confine HTML export writes

1 files changed, 263 insertions, 0 deletions

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