summaryrefslogtreecommitdiff
path: root/source/Felix/Render/Html
diff options
context:
space:
mode:
Diffstat (limited to 'source/Felix/Render/Html')
-rw-r--r--source/Felix/Render/Html/Context.hs171
-rw-r--r--source/Felix/Render/Html/Export.hs277
-rw-r--r--source/Felix/Render/Html/Layout.hs602
-rw-r--r--source/Felix/Render/Html/Output.hs471
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)))
generated by cgit v1.2.3 (git 2.39.1) at 2026-08-06 21:31:16 +0000