Migrate to `Felix` namespaceHEADhotg

4 files changed, 1521 insertions, 0 deletions

diff --git a/source/Felix/Render/Html/Context.hs b/source/Felix/Render/Html/Context.hs
new file mode 100644
index 0000000..469d986
--- /dev/null
+++ b/source/Felix/Render/Html/Context.hs
@@ -0,0 +1,171 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+-- | Browser-facing routing authority for one rendered HTML page.
+module Felix.Render.Html.Context
+    ( HtmlRenderEnvironment
+    , htmlRenderEnvironment
+    , HtmlRenderContext
+    , HtmlRenderContextError(..)
+    , htmlRenderContext
+    , htmlRenderContextFromEnvironment
+    , htmlCurrentSource
+    , htmlCurrentPageUrl
+    , htmlCurrentPageLabel
+    , htmlRouteNamespaces
+    , htmlSourceUrl
+    , htmlSourceLabel
+    , htmlSourcePageHref
+    , htmlSourceFragmentHref
+    , htmlSupportScriptHref
+    ) where
+
+import Base
+import Felix.Source
+import Felix.Render.Html.Layout
+
+import Control.Exception (Exception)
+import Data.Map.Strict qualified as Map
+import Data.Text qualified as Text
+
+
+data HtmlRenderContextError
+    = HtmlCurrentSourceNotRouted !ResolvedSource
+    | HtmlReferencedSourceNotRouted !ResolvedSource
+    deriving stock (Show, Eq)
+
+instance Exception HtmlRenderContextError
+
+data HtmlRenderContext = HtmlRenderContext
+    { contextCurrentSource :: !ResolvedSource
+    , contextCurrentPageUrl :: !UrlPath
+    , contextEnvironment :: !HtmlRenderEnvironment
+    }
+    deriving stock (Show, Eq)
+
+data HtmlRenderEnvironment = HtmlRenderEnvironment
+    { environmentSourceUrls :: !(Map ResolvedSource UrlPath)
+    , environmentRouteNamespaces :: !(Map SourceMountId UrlPath)
+    , environmentSupportScriptUrl :: !UrlPath
+    }
+    deriving stock (Show, Eq)
+
+htmlRenderEnvironment :: HtmlLayout -> HtmlRenderEnvironment
+htmlRenderEnvironment layout =
+    HtmlRenderEnvironment
+        { environmentSourceUrls =
+            Map.fromList
+                [ (source, routeUrlPath route)
+                | (source, route) <- htmlPageRoutes layout
+                ]
+        , environmentRouteNamespaces =
+            htmlMountUrlPrefixes layout
+        , environmentSupportScriptUrl =
+            routeUrlPath (htmlSupportScriptRoute layout)
+        }
+
+htmlRenderContext
+    :: HtmlLayout
+    -> ResolvedSource
+    -> Either HtmlRenderContextError HtmlRenderContext
+htmlRenderContext layout =
+    htmlRenderContextFromEnvironment
+        (htmlRenderEnvironment layout)
+
+htmlRenderContextFromEnvironment
+    :: HtmlRenderEnvironment
+    -> ResolvedSource
+    -> Either HtmlRenderContextError HtmlRenderContext
+htmlRenderContextFromEnvironment environment currentSource = do
+    currentPageUrl <-
+        maybe
+            (Left (HtmlCurrentSourceNotRouted currentSource))
+            Right
+            (Map.lookup
+                currentSource
+                (environmentSourceUrls environment))
+    Right
+        HtmlRenderContext
+            { contextCurrentSource = currentSource
+            , contextCurrentPageUrl = currentPageUrl
+            , contextEnvironment = environment
+            }
+
+htmlCurrentSource :: HtmlRenderContext -> ResolvedSource
+htmlCurrentSource =
+    contextCurrentSource
+
+htmlCurrentPageUrl :: HtmlRenderContext -> UrlPath
+htmlCurrentPageUrl =
+    contextCurrentPageUrl
+
+htmlCurrentPageLabel :: HtmlRenderContext -> Text
+htmlCurrentPageLabel context =
+    resolvedSourceLabel (contextCurrentSource context)
+
+htmlRouteNamespaces
+    :: HtmlRenderContext
+    -> Map SourceMountId UrlPath
+htmlRouteNamespaces =
+    environmentRouteNamespaces . contextEnvironment
+
+htmlSourceUrl
+    :: HtmlRenderContext
+    -> ResolvedSource
+    -> Either HtmlRenderContextError UrlPath
+htmlSourceUrl HtmlRenderContext{contextEnvironment} source =
+    maybe
+        (Left (HtmlReferencedSourceNotRouted source))
+        Right
+        (Map.lookup source (environmentSourceUrls contextEnvironment))
+
+htmlSourceLabel
+    :: HtmlRenderContext
+    -> ResolvedSource
+    -> Either HtmlRenderContextError Text
+htmlSourceLabel context source = do
+    _url <- htmlSourceUrl context source
+    Right (resolvedSourceLabel source)
+
+htmlSourcePageHref
+    :: HtmlRenderContext
+    -> ResolvedSource
+    -> Either HtmlRenderContextError Text
+htmlSourcePageHref context source =
+    renderRelativeUrlPath
+        (contextCurrentPageUrl context)
+        <$> htmlSourceUrl context source
+
+htmlSourceFragmentHref
+    :: HtmlRenderContext
+    -> ResolvedSource
+    -> Text
+    -> Either HtmlRenderContextError Text
+htmlSourceFragmentHref context source fragment = do
+    target <- htmlSourceUrl context source
+    let encodedFragment =
+            renderUrlFragment fragment
+    Right
+        (if target == contextCurrentPageUrl context
+            then encodedFragment
+            else
+                renderRelativeUrlPath
+                    (contextCurrentPageUrl context)
+                    target
+                    <> encodedFragment)
+
+htmlSupportScriptHref :: HtmlRenderContext -> Text
+htmlSupportScriptHref context =
+    renderRelativeUrlPath
+        (contextCurrentPageUrl context)
+        (environmentSupportScriptUrl
+            (contextEnvironment context))
+
+resolvedSourceLabel :: ResolvedSource -> Text
+resolvedSourceLabel source =
+    sourceMountIdText (resolvedSourceMount source)
+        <> ":"
+        <> Text.pack
+            (safeRelativePathFilePath
+                (resolvedSourceRelativePath source))
diff --git a/source/Felix/Render/Html/Export.hs b/source/Felix/Render/Html/Export.hs
new file mode 100644
index 0000000..a3f0e39
--- /dev/null
+++ b/source/Felix/Render/Html/Export.hs
@@ -0,0 +1,277 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+-- | Prepare a complete HTML export from retained parsed presentation.
+module Felix.Render.Html.Export
+    ( HtmlPresentation
+    , htmlPresentationFromParsedWorkspace
+    , HtmlExportError(..)
+    , renderHtmlExportError
+    , prepareHtmlExport
+    , prepareHtmlExportWithLayout
+    , prepareHtmlExportWithLayoutFromRendererRoots
+    ) where
+
+import Base
+import Felix.Parse
+import Felix.Source
+import Felix.Render.Html qualified as Html
+import Felix.Render.Html.Context
+import Felix.Render.Html.Layout
+import Felix.Render.Html.Output
+import Felix.Syntax.Abstract (Block)
+
+import Control.Exception (Exception, IOException, displayException)
+import Control.Exception qualified as Exception
+import Data.Bifunctor (first)
+import Data.List.NonEmpty qualified as NonEmpty
+import Data.Text qualified as Text
+import Data.Text.Encoding qualified as TextEncoding
+import Data.Text.Encoding.Error (UnicodeException)
+import Data.Text.IO qualified as TextIO
+import System.Directory (doesFileExist)
+import System.FilePath.Posix ((</>))
+
+
+-- | The strict, invocation-local subset of parsed presentation needed by the
+-- renderer. Construction forces the complete module sequence and every page
+-- shell, severing references to parser payloads, syntax interfaces, and
+-- canonical cache payloads.
+data HtmlPresentation = HtmlPresentation
+    !(NonEmpty HtmlSourcePresentation)
+
+data HtmlSourcePresentation = HtmlSourcePresentation
+    !ResolvedSource
+    ![Block]
+
+htmlPresentationFromParsedWorkspace
+    :: ParsedSourceWorkspace
+    -> HtmlPresentation
+htmlPresentationFromParsedWorkspace workspace =
+    HtmlPresentation
+        (strictMapNonEmpty project parsedModules)
+  where
+    parsedModules =
+        parsedWorkspaceImportedBeforeImporter workspace
+    project parsedModule =
+        HtmlSourcePresentation
+            (parsedModuleResolved parsedModule)
+            (parsedModuleBlocks parsedModule)
+
+strictMapNonEmpty :: (a -> b) -> NonEmpty a -> NonEmpty b
+strictMapNonEmpty f (value :| values) =
+    let !firstPage = f value
+        !rest = strictMapList f values
+    in firstPage :| rest
+
+strictMapList :: (a -> b) -> [a] -> [b]
+strictMapList _ [] =
+    []
+strictMapList f (value : values) =
+    let !next = f value
+        !rest = strictMapList f values
+    in next : rest
+
+data HtmlExportError
+    = HtmlRendererDataNotFound !FilePath ![FilePath]
+    | HtmlRendererDataLookupFailed !FilePath !Text
+    | HtmlRendererDataReadFailed !FilePath !Text
+    | HtmlExportLayoutError !HtmlLayoutError
+    | HtmlExportContextError !HtmlRenderContextError
+    deriving stock (Show)
+
+instance Exception HtmlExportError
+
+renderHtmlExportError :: HtmlExportError -> Text
+renderHtmlExportError = \case
+    HtmlRendererDataNotFound requested searched ->
+        "renderer data " <> quotePath requested <> " was not found; searched "
+            <> Text.intercalate ", " (quotePath <$> searched)
+    HtmlRendererDataLookupFailed path reason ->
+        "could not locate renderer data " <> quotePath path <> ": " <> reason
+    HtmlRendererDataReadFailed path reason ->
+        "could not read renderer data " <> quotePath path <> ": " <> reason
+    HtmlExportLayoutError failure ->
+        renderHtmlLayoutError failure
+    HtmlExportContextError failure ->
+        case failure of
+            HtmlCurrentSourceNotRouted source ->
+                "current source has no HTML route: " <> sourceLabel source
+            HtmlReferencedSourceNotRouted source ->
+                "referenced source has no HTML route: " <> sourceLabel source
+  where
+    sourceLabel source =
+        sourceMountIdText (resolvedSourceMount source)
+            <> ":"
+            <> Text.pack
+                (safeRelativePathFilePath
+                    (resolvedSourceRelativePath source))
+
+    quotePath = Text.pack . show
+
+prepareHtmlExport
+    :: [(SourceMountId, [Text])]
+    -> HtmlPresentation
+    -> Text
+    -> Either HtmlExportError [PreparedHtmlArtifact]
+prepareHtmlExport
+        mountPrefixes
+        (HtmlPresentation presentation)
+        hints = do
+    let sources =
+            sourceOf <$> NonEmpty.toList presentation
+    layout <-
+        first
+            HtmlExportLayoutError
+            (layoutHtmlSources mountPrefixes sources)
+    prepareRenderedExport hints layout presentation
+  where
+    sourceOf (HtmlSourcePresentation source _blocks) =
+        source
+
+prepareHtmlExportWithLayout
+    :: HtmlLayout
+    -> HtmlPresentation
+    -> Text
+    -> Either HtmlExportError [PreparedHtmlArtifact]
+prepareHtmlExportWithLayout
+        layout
+        (HtmlPresentation presentation)
+        hints =
+    prepareRenderedExport hints layout presentation
+
+prepareHtmlExportWithLayoutFromRendererRoots
+    :: [FilePath]
+    -> HtmlLayout
+    -> HtmlPresentation
+    -> IO (Either HtmlExportError [PreparedHtmlArtifact])
+prepareHtmlExportWithLayoutFromRendererRoots roots layout presentation = do
+    hintsResult <- findAndReadRendererFile roots "lexicon.tsv"
+    pure do
+        hints <- hintsResult
+        prepareHtmlExportWithLayout layout presentation hints
+
+-- Renderer data follows the established current-directory,
+-- configured-library, and debug-directory lookup policy.
+findAndReadRendererFile
+    :: [FilePath]
+    -> FilePath
+    -> IO (Either HtmlExportError Text)
+findAndReadRendererFile roots path =
+    selectRendererData path ((</> path) <$> roots) >>= \case
+        Left failure -> pure (Left failure)
+        Right selectedPath -> do
+            readResult <- tryRendererRead (TextIO.readFile selectedPath)
+            pure case readResult of
+                Left reason ->
+                    Left (HtmlRendererDataReadFailed selectedPath reason)
+                Right contents -> Right contents
+
+selectRendererData
+    :: FilePath
+    -> [FilePath]
+    -> IO (Either HtmlExportError FilePath)
+selectRendererData requested candidates = go candidates
+  where
+    go = \case
+        [] -> pure (Left (HtmlRendererDataNotFound requested candidates))
+        candidate : remaining ->
+            tryRendererIO (doesFileExist candidate) >>= \case
+                Left failure ->
+                    pure
+                        (Left
+                            (HtmlRendererDataLookupFailed
+                                candidate
+                                (Text.pack (displayException failure))))
+                Right True -> pure (Right candidate)
+                Right False -> go remaining
+
+tryRendererIO :: IO value -> IO (Either IOException value)
+tryRendererIO = Exception.try
+
+tryRendererRead :: IO value -> IO (Either Text value)
+tryRendererRead action =
+    Exception.catch
+        (Exception.catch (Right <$> action) renderIOException)
+        renderUnicodeException
+  where
+    renderIOException :: IOException -> IO (Either Text value)
+    renderIOException = pure . Left . Text.pack . displayException
+
+    renderUnicodeException
+        :: UnicodeException
+        -> IO (Either Text value)
+    renderUnicodeException = pure . Left . Text.pack . displayException
+
+prepareRenderedExport
+    :: Text
+    -> HtmlLayout
+    -> NonEmpty HtmlSourcePresentation
+    -> Either HtmlExportError [PreparedHtmlArtifact]
+prepareRenderedExport hints layout presentation = do
+    let sourceBlocks =
+            (\(HtmlSourcePresentation source blocks) ->
+                (source, blocks))
+                <$> presentation
+        (unforcedRenderIndex, pages) =
+            Html.buildRenderIndex sourceBlocks
+        !renderIndex = unforcedRenderIndex
+        renderEnvironment =
+            htmlRenderEnvironment layout
+    pageArtifacts <-
+        traverse
+            (prepareSourceArtifact
+                renderEnvironment
+                layout
+                hints
+                renderIndex)
+            pages
+    let supportRoute =
+            htmlSupportScriptRoute layout
+        supportArtifact =
+            preparedHtmlArtifact
+                (routeDestination supportRoute)
+                (Right
+                    (TextEncoding.encodeUtf8
+                        Html.supportScriptAssetContents))
+        -- Page artifacts retain imported-before-importer source order.  The
+        -- singleton support asset is published deterministically afterward.
+    Right (NonEmpty.toList pageArtifacts <> [supportArtifact])
+
+prepareSourceArtifact
+    :: HtmlRenderEnvironment
+    -> HtmlLayout
+    -> Text
+    -> Html.HtmlRenderIndex
+    -> Html.HtmlPagePresentation
+    -> Either
+        HtmlExportError
+        PreparedHtmlArtifact
+prepareSourceArtifact renderEnvironment layout hints renderIndex page = do
+    let source = Html.htmlPagePresentationSource page
+    context <-
+        first
+            HtmlExportContextError
+            (htmlRenderContextFromEnvironment
+                renderEnvironment
+                source)
+    route <-
+        maybe
+            (Left
+                (HtmlExportContextError
+                    (HtmlCurrentSourceNotRouted source)))
+            Right
+            (htmlPageRoute layout source)
+    Right
+        (preparedHtmlArtifact
+            (routeDestination route)
+            (first renderHtmlExportError
+                (TextEncoding.encodeUtf8
+                    <$> first
+                        HtmlExportContextError
+                        (Html.renderDocument
+                            context
+                            hints
+                            renderIndex
+                            page))))
diff --git a/source/Felix/Render/Html/Layout.hs b/source/Felix/Render/Html/Layout.hs
new file mode 100644
index 0000000..7e5bfcf
--- /dev/null
+++ b/source/Felix/Render/Html/Layout.hs
@@ -0,0 +1,602 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+-- | Pure browser and destination routing for a resolved source graph.
+module Felix.Render.Html.Layout
+    ( UrlSegment
+    , UrlSegmentError(..)
+    , urlSegment
+    , renderUrlSegment
+    , UrlPath
+    , urlPath
+    , renderUrlPath
+    , renderRelativeUrlPath
+    , renderUrlFragment
+    , HtmlRoute
+    , routeDestination
+    , routeUrlPath
+    , HtmlRouteOwner(..)
+    , HtmlUrlRouteCollision(..)
+    , HtmlDestinationRouteCollision(..)
+    , HtmlLayoutError(..)
+    , renderHtmlLayoutError
+    , HtmlLayout
+    , htmlPageRoutes
+    , htmlPageRoute
+    , htmlSupportScriptRoute
+    , htmlMountUrlPrefixes
+    , layoutHtmlSources
+    , layoutHtmlSourceGraph
+    ) where
+
+import Base
+import Felix.Source
+import Felix.Source.Graph
+
+import Control.Exception (Exception)
+import Data.Bifunctor (first)
+import Data.ByteString qualified as ByteString
+import Data.Char (chr)
+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 Data.Text.Encoding qualified as TextEncoding
+import Data.Word (Word8)
+import System.FilePath.Posix qualified as Posix
+
+
+-- | One canonical percent-encoded URL path segment.
+newtype UrlSegment = UrlSegment Text
+    deriving stock (Show, Eq, Ord)
+
+data UrlSegmentError
+    = EmptyUrlSegment
+    | DotUrlSegment !Text
+    | UrlSegmentContainsSeparator !Text
+    | UrlSegmentContainsNull !Text
+    deriving stock (Show, Eq)
+
+urlSegment :: Text -> Either UrlSegmentError UrlSegment
+urlSegment decoded
+    | Text.null decoded =
+        Left EmptyUrlSegment
+    | decoded == "." || decoded == ".." =
+        Left (DotUrlSegment decoded)
+    | "/" `Text.isInfixOf` decoded =
+        Left (UrlSegmentContainsSeparator decoded)
+    | "\0" `Text.isInfixOf` decoded =
+        Left (UrlSegmentContainsNull decoded)
+    | otherwise =
+        Right (UrlSegment (percentEncodeUtf8 decoded))
+
+renderUrlSegment :: UrlSegment -> Text
+renderUrlSegment (UrlSegment encoded) =
+    encoded
+
+
+-- | A root-relative URL path. Its segments are already encoded.
+newtype UrlPath = UrlPath [UrlSegment]
+    deriving stock (Show, Eq, Ord)
+
+urlPath :: [Text] -> Either UrlSegmentError UrlPath
+urlPath =
+    fmap UrlPath . traverse urlSegment
+
+renderUrlPath :: UrlPath -> Text
+renderUrlPath (UrlPath segments) =
+    "/" <> Text.intercalate "/" (renderUrlSegment <$> segments)
+
+-- | Render a target path relative to the directory of a current page.
+renderRelativeUrlPath :: UrlPath -> UrlPath -> Text
+renderRelativeUrlPath
+    (UrlPath currentPageSegments)
+    (UrlPath targetSegments) =
+        case relativeSegments of
+            [] ->
+                "."
+            _ ->
+                Text.intercalate "/" relativeSegments
+  where
+    currentDirectorySegments =
+        case reverse currentPageSegments of
+            [] ->
+                []
+            _page : directoryReversed ->
+                reverse directoryReversed
+    (remainingCurrent, remainingTarget) =
+        dropCommonPrefix currentDirectorySegments targetSegments
+    relativeSegments =
+        replicate (length remainingCurrent) ".."
+            <> (renderUrlSegment <$> remainingTarget)
+
+-- | Render an exact source marker as an encoded URL fragment.
+renderUrlFragment :: Text -> Text
+renderUrlFragment marker =
+    "#" <> percentEncodeUtf8 marker
+
+
+data HtmlRoute = HtmlRoute
+    { routeDestination :: !SafeRelativePath
+    , routeUrlPath :: !UrlPath
+    }
+    deriving stock (Show, Eq)
+
+data HtmlRouteOwner
+    = HtmlPage !ResolvedSource
+    | HtmlSupportScript
+    deriving stock (Show, Eq, Ord)
+
+data HtmlUrlRouteCollision = HtmlUrlRouteCollision
+    !UrlPath
+    !(NonEmpty HtmlRouteOwner)
+    deriving stock (Show, Eq)
+
+data HtmlDestinationRouteCollision = HtmlDestinationRouteCollision
+        !SafeRelativePath
+        !(NonEmpty HtmlRouteOwner)
+    | NestedHtmlDestinationRouteCollision
+        !SafeRelativePath
+        !HtmlRouteOwner
+        !SafeRelativePath
+        !HtmlRouteOwner
+    deriving stock (Show, Eq)
+
+data HtmlLayoutError
+    = DuplicateHtmlMountId !SourceMountId
+    | InvalidHtmlMountPrefixSegment
+        !SourceMountId
+        !Text
+        !UrlSegmentError
+    | DuplicateHtmlMountPrefix
+        ![Text]
+        !(NonEmpty SourceMountId)
+    | MissingHtmlMountPrefix !SourceMountId
+    | InvalidHtmlRouteSegment
+        !HtmlRouteOwner
+        !Text
+        !UrlSegmentError
+    | InvalidHtmlRouteDestination
+        !HtmlRouteOwner
+        !FilePath
+        !RelativePathError
+    | CollidingHtmlRoutes
+        ![HtmlUrlRouteCollision]
+        ![HtmlDestinationRouteCollision]
+    deriving stock (Show, Eq)
+
+instance Exception HtmlLayoutError
+
+renderHtmlLayoutError :: HtmlLayoutError -> Text
+renderHtmlLayoutError = \case
+    DuplicateHtmlMountId mount ->
+        "HTML mount is configured more than once: "
+            <> quoteText (sourceMountIdText mount)
+    InvalidHtmlMountPrefixSegment mount segment _problem ->
+        "HTML mount " <> quoteText (sourceMountIdText mount)
+            <> " has invalid route segment " <> quoteText segment
+    DuplicateHtmlMountPrefix prefix mounts ->
+        "HTML route prefix " <> quoteText (Text.intercalate "/" prefix)
+            <> " is shared by mounts "
+            <> Text.intercalate ", "
+                (quoteText . sourceMountIdText <$> toList mounts)
+    MissingHtmlMountPrefix mount ->
+        "no HTML route prefix is configured for mount "
+            <> quoteText (sourceMountIdText mount)
+    InvalidHtmlRouteSegment owner segment _problem ->
+        renderOwner owner <> " has invalid route segment " <> quoteText segment
+    InvalidHtmlRouteDestination owner path _problem ->
+        renderOwner owner <> " has invalid HTML destination " <> quotePath path
+    CollidingHtmlRoutes urlCollisions destinationCollisions ->
+        "HTML routes collide: "
+            <> Text.intercalate "; "
+                ( (renderUrlCollision <$> urlCollisions)
+                    <> (renderDestinationCollision <$> destinationCollisions)
+                )
+  where
+    renderUrlCollision (HtmlUrlRouteCollision path owners) =
+        "URL " <> quoteText (renderUrlPath path)
+            <> " is owned by "
+            <> Text.intercalate ", " (renderOwner <$> toList owners)
+
+    renderDestinationCollision
+            (HtmlDestinationRouteCollision path owners) =
+        "destination "
+            <> quotePath (safeRelativePathFilePath path)
+            <> " is owned by "
+            <> Text.intercalate ", " (renderOwner <$> toList owners)
+    renderDestinationCollision
+            (NestedHtmlDestinationRouteCollision
+                ancestor ancestorOwner descendant descendantOwner) =
+        "destination " <> quotePath (safeRelativePathFilePath ancestor)
+            <> " for " <> renderOwner ancestorOwner
+            <> " is an ancestor of "
+            <> quotePath (safeRelativePathFilePath descendant)
+            <> " for " <> renderOwner descendantOwner
+
+renderOwner :: HtmlRouteOwner -> Text
+renderOwner = \case
+    HtmlPage source ->
+        "page "
+            <> quoteText
+                (sourceMountIdText (resolvedSourceMount source)
+                    <> ":"
+                    <> Text.pack
+                        (safeRelativePathFilePath
+                            (resolvedSourceRelativePath source)))
+    HtmlSupportScript ->
+        "support script"
+
+quotePath :: FilePath -> Text
+quotePath = Text.pack . show
+
+quoteText :: Text -> Text
+quoteText = Text.pack . show
+
+data HtmlLayout = HtmlLayout
+    !(Map ResolvedSource HtmlRoute)
+    !HtmlRoute
+    !(Map SourceMountId UrlPath)
+    deriving stock (Show, Eq)
+
+htmlPageRoutes :: HtmlLayout -> [(ResolvedSource, HtmlRoute)]
+htmlPageRoutes (HtmlLayout routes _supportScript _mountPrefixes) =
+    Map.toAscList routes
+
+htmlPageRoute :: HtmlLayout -> ResolvedSource -> Maybe HtmlRoute
+htmlPageRoute (HtmlLayout routes _supportScript _mountPrefixes) source =
+    Map.lookup source routes
+
+htmlSupportScriptRoute :: HtmlLayout -> HtmlRoute
+htmlSupportScriptRoute (HtmlLayout _routes supportScript _mountPrefixes) =
+    supportScript
+
+htmlMountUrlPrefixes :: HtmlLayout -> Map SourceMountId UrlPath
+htmlMountUrlPrefixes (HtmlLayout _routes _supportScript mountPrefixes) =
+    mountPrefixes
+
+
+data ValidatedMountPrefix = ValidatedMountPrefix
+    ![Text]
+    ![UrlSegment]
+
+layoutHtmlSourceGraph
+    :: [(SourceMountId, [Text])]
+    -> ResolvedSourceGraph
+    -> Either HtmlLayoutError HtmlLayout
+layoutHtmlSourceGraph specifications graph =
+    layoutHtmlSources
+        specifications
+        (sourceNodeResolved <$> sourceGraphNodes graph)
+
+layoutHtmlSources
+    :: [(SourceMountId, [Text])]
+    -> [ResolvedSource]
+    -> Either HtmlLayoutError HtmlLayout
+layoutHtmlSources specifications inputSources = do
+    prefixes <- validateMountPrefixes specifications
+    let sources =
+            List.sort
+                inputSources
+        usedMounts =
+            Set.fromList (resolvedSourceMount <$> sources)
+        missingMounts =
+            usedMounts `Set.difference` Map.keysSet prefixes
+    case Set.lookupMin missingMounts of
+        Just missing ->
+            Left (MissingHtmlMountPrefix missing)
+        Nothing -> do
+            pageEntries <-
+                traverse
+                    (makePageRoute prefixes)
+                    sources
+            encodedSupportScript <-
+                encodeRouteSegments
+                    HtmlSupportScript
+                    supportScriptAssetComponents
+            supportScript <-
+                makeRoute
+                    HtmlSupportScript
+                    supportScriptAssetComponents
+                    encodedSupportScript
+            let ownedRoutes =
+                    (HtmlSupportScript, supportScript)
+                        : [ (HtmlPage source, route)
+                          | (source, route) <- pageEntries
+                          ]
+                urlCollisions =
+                    collectUrlCollisions ownedRoutes
+                destinationCollisions =
+                    collectDestinationCollisions ownedRoutes
+                        <> collectNestedDestinationCollisions ownedRoutes
+            if null urlCollisions && null destinationCollisions
+                then
+                    Right
+                        (HtmlLayout
+                            (Map.fromList pageEntries)
+                            supportScript
+                            (Map.map
+                                (\(ValidatedMountPrefix _decoded encoded) ->
+                                    UrlPath encoded)
+                                prefixes))
+                else
+                    Left
+                        (CollidingHtmlRoutes
+                            urlCollisions
+                            destinationCollisions)
+
+validateMountPrefixes
+    :: [(SourceMountId, [Text])]
+    -> Either HtmlLayoutError (Map SourceMountId ValidatedMountPrefix)
+validateMountPrefixes specifications =
+    case duplicateValues (fst <$> specifications) of
+        duplicate : _ ->
+            Left (DuplicateHtmlMountId duplicate)
+        [] -> do
+            validated <- traverse validatePrefix (List.sort specifications)
+            case duplicatePrefixGroups validated of
+                duplicate : _ ->
+                    Left duplicate
+                [] ->
+                    Right
+                        (Map.fromList
+                            [ (mount, prefix)
+                            | (mount, _decoded, prefix) <- validated
+                            ])
+  where
+    validatePrefix (mount, decoded) = do
+        encoded <- traverse
+            (\segment ->
+                first
+                    (InvalidHtmlMountPrefixSegment mount segment)
+                    (urlSegment segment))
+            decoded
+        Right
+            ( mount
+            , decoded
+            , ValidatedMountPrefix decoded encoded
+            )
+
+duplicatePrefixGroups
+    :: [(SourceMountId, [Text], ValidatedMountPrefix)]
+    -> [HtmlLayoutError]
+duplicatePrefixGroups validated =
+    [ DuplicateHtmlMountPrefix prefix (firstMount :| otherMounts)
+    | (prefix, mounts) <-
+        Map.toAscList
+            (Map.fromListWith (<>)
+                [ (decoded, [mount])
+                | (mount, decoded, _prefix) <- validated
+                ])
+    , firstMount : secondMount : remainingMounts <-
+        [List.sort mounts]
+    , let otherMounts = secondMount : remainingMounts
+    ]
+
+duplicateValues :: Ord a => [a] -> [a]
+duplicateValues values =
+    [ value
+    | (value, multiplicity) <-
+        Map.toAscList
+            (Map.fromListWith (+)
+                [(value, 1 :: Int) | value <- values])
+    , multiplicity > 1
+    ]
+
+makePageRoute
+    :: Map SourceMountId ValidatedMountPrefix
+    -> ResolvedSource
+    -> Either HtmlLayoutError (ResolvedSource, HtmlRoute)
+makePageRoute prefixes source = do
+    prefix <- case Map.lookup (resolvedSourceMount source) prefixes of
+        Nothing ->
+            Left
+                (MissingHtmlMountPrefix
+                    (resolvedSourceMount source))
+        Just found ->
+            Right found
+    let sourceComponents =
+            Text.splitOn
+                "/"
+                (Text.pack
+                    (safeRelativePathFilePath
+                        (resolvedSourceRelativePath source)))
+        destinationComponents =
+            replaceFinalComponent
+                (\component ->
+                    dropFinalExtension component <> ".html")
+                sourceComponents
+        urlComponents =
+            replaceFinalComponent
+                dropFinalExtension
+                sourceComponents
+        ValidatedMountPrefix decodedPrefix encodedPrefix =
+            prefix
+        owner = HtmlPage source
+    encodedPageComponents <-
+        encodeRouteSegments owner urlComponents
+    route <-
+        makeRoute
+            owner
+            (decodedPrefix <> destinationComponents)
+            (encodedPrefix <> encodedPageComponents)
+    Right (source, route)
+
+replaceFinalComponent :: (a -> a) -> [a] -> [a]
+replaceFinalComponent transform components =
+    case reverse components of
+        [] ->
+            []
+        final : precedingReversed ->
+            reverse precedingReversed <> [transform final]
+
+dropFinalExtension :: Text -> Text
+dropFinalExtension component =
+    case Text.breakOnEnd "." component of
+        ("", _suffix) ->
+            component
+        (".", _suffix) ->
+            component
+        (prefix, _suffix) ->
+            Text.dropEnd 1 prefix
+
+makeRoute
+    :: HtmlRouteOwner
+    -> [Text]
+    -> [UrlSegment]
+    -> Either HtmlLayoutError HtmlRoute
+makeRoute owner destinationComponents encodedUrlComponents = do
+    let destinationSpelling =
+            List.intercalate
+                "/"
+                (Text.unpack <$> destinationComponents)
+    destination <-
+        first
+            (InvalidHtmlRouteDestination
+                owner
+                destinationSpelling)
+            (safeRelativePath destinationSpelling)
+    Right
+        HtmlRoute
+            { routeDestination = destination
+            , routeUrlPath = UrlPath encodedUrlComponents
+            }
+
+encodeRouteSegments
+    :: HtmlRouteOwner
+    -> [Text]
+    -> Either HtmlLayoutError [UrlSegment]
+encodeRouteSegments owner =
+    traverse
+        (\decoded ->
+            first
+                (InvalidHtmlRouteSegment owner decoded)
+                (urlSegment decoded))
+
+collectUrlCollisions
+    :: [(HtmlRouteOwner, HtmlRoute)]
+    -> [HtmlUrlRouteCollision]
+collectUrlCollisions ownedRoutes =
+    [ HtmlUrlRouteCollision path owners
+    | (path, collidingOwners) <-
+        Map.toAscList
+            (Map.fromListWith (<>)
+                [ (routeUrlPath route, [owner])
+                | (owner, route) <- ownedRoutes
+                ])
+    , owners <-
+        collisionOwners collidingOwners
+    ]
+
+collectDestinationCollisions
+    :: [(HtmlRouteOwner, HtmlRoute)]
+    -> [HtmlDestinationRouteCollision]
+collectDestinationCollisions ownedRoutes =
+    [ HtmlDestinationRouteCollision destination owners
+    | (destination, collidingOwners) <-
+        Map.toAscList
+            (Map.fromListWith (<>)
+                [ (routeDestination route, [owner])
+                | (owner, route) <- ownedRoutes
+                ])
+    , owners <-
+        collisionOwners collidingOwners
+    ]
+
+collectNestedDestinationCollisions
+    :: [(HtmlRouteOwner, HtmlRoute)]
+    -> [HtmlDestinationRouteCollision]
+collectNestedDestinationCollisions ownedRoutes =
+    take 1
+        [ NestedHtmlDestinationRouteCollision
+            ancestor
+            ancestorOwner
+            descendant
+            descendantOwner
+        | ( (ancestorComponents, ancestor, ancestorOwner)
+            , (descendantComponents, descendant, descendantOwner)
+            ) <- zip destinations (drop 1 destinations)
+        , strictComponentPrefix ancestorComponents descendantComponents
+        ]
+  where
+    destinations =
+        List.sort
+            [ ( relativePathComponents destination
+              , destination
+              , owner
+              )
+            | (owner, route) <- ownedRoutes
+            , let destination = routeDestination route
+            ]
+
+relativePathComponents :: SafeRelativePath -> [FilePath]
+relativePathComponents =
+    Posix.splitDirectories . safeRelativePathFilePath
+
+strictComponentPrefix :: [FilePath] -> [FilePath] -> Bool
+strictComponentPrefix possibleAncestor possibleDescendant =
+    length possibleAncestor < length possibleDescendant
+        && possibleAncestor `List.isPrefixOf` possibleDescendant
+
+collisionOwners :: [HtmlRouteOwner] -> [NonEmpty HtmlRouteOwner]
+collisionOwners owners =
+    case List.sort owners of
+        firstOwner : secondOwner : rest ->
+            [firstOwner :| (secondOwner : rest)]
+        _ ->
+            []
+
+dropCommonPrefix :: Eq a => [a] -> [a] -> ([a], [a])
+dropCommonPrefix (left : lefts) (right : rights)
+    | left == right =
+        dropCommonPrefix lefts rights
+dropCommonPrefix left right =
+    (left, right)
+
+
+supportScriptAssetComponents :: [Text]
+supportScriptAssetComponents =
+    ["_static", "naproche-html.js"]
+
+percentEncodeUtf8 :: Text -> Text
+percentEncodeUtf8 =
+    Text.pack
+        . concatMap encodeByte
+        . ByteString.unpack
+        . TextEncoding.encodeUtf8
+
+encodeByte :: Word8 -> String
+encodeByte byte
+    | isUnreservedAscii byte =
+        [chr (fromIntegral byte)]
+    | otherwise =
+        [ '%'
+        , hexadecimalDigit (byte `div` 16)
+        , hexadecimalDigit (byte `mod` 16)
+        ]
+
+isUnreservedAscii :: Word8 -> Bool
+isUnreservedAscii byte =
+    isAsciiUpper byte
+        || isAsciiLower byte
+        || isAsciiDigit byte
+        || byte `elem` fmap (fromIntegral . fromEnum) ("-._~" :: String)
+
+isAsciiUpper :: Word8 -> Bool
+isAsciiUpper byte =
+    byte >= 65 && byte <= 90
+
+isAsciiLower :: Word8 -> Bool
+isAsciiLower byte =
+    byte >= 97 && byte <= 122
+
+isAsciiDigit :: Word8 -> Bool
+isAsciiDigit byte =
+    byte >= 48 && byte <= 57
+
+hexadecimalDigit :: Word8 -> Char
+hexadecimalDigit value
+    | value < 10 =
+        chr (fromIntegral value + fromEnum '0')
+    | otherwise =
+        chr (fromIntegral value - 10 + fromEnum 'A')
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)))