diff options
Diffstat (limited to 'source/Render')
| -rw-r--r-- | source/Render/Html.hs | 169 | ||||
| -rw-r--r-- | source/Render/Html/Context.hs | 64 | ||||
| -rw-r--r-- | source/Render/Html/Export.hs | 213 | ||||
| -rw-r--r-- | source/Render/Html/Layout.hs | 15 | ||||
| -rw-r--r-- | source/Render/Html/Output.hs | 315 |
5 files changed, 401 insertions, 375 deletions
diff --git a/source/Render/Html.hs b/source/Render/Html.hs index 20ac33b..c37a278 100644 --- a/source/Render/Html.hs +++ b/source/Render/Html.hs @@ -4,7 +4,11 @@ {-# LANGUAGE RecordWildCards #-} module Render.Html - ( renderDocument + ( HtmlRenderIndex + , HtmlPagePresentation + , buildRenderIndex + , htmlPagePresentationSource + , renderDocument , supportScriptAssetContents ) where @@ -61,6 +65,21 @@ type AnchorMap = Map Marker Text type BlockRenderInfo = (Int, Block, Text) type PreviewMap = Map Marker PreviewEntry +data HtmlRenderIndex = HtmlRenderIndex + !(Map Marker IndexedReferenceTarget) + +data HtmlPagePresentation = HtmlPagePresentation + { htmlPagePresentationSource :: !ResolvedSource + , pagePresentationBlockInfos :: ![BlockRenderInfo] + , pagePresentationAnchors :: !AnchorMap + , pagePresentationReferencedMarkers :: !(Set Marker) + } + +data IndexedReferenceTarget = IndexedReferenceTarget + !Int + !ResolvedSource + !ReferenceTarget + data ReferenceContext = ReferenceContext { referenceAnchors :: AnchorMap , referencePreviews :: PreviewMap @@ -112,36 +131,36 @@ referenceGroupThreshold = 5 renderDocument :: HtmlRenderContext -> Text - -> [Block] - -> [(ResolvedSource, [Block])] + -> HtmlRenderIndex + -> HtmlPagePresentation -> Either HtmlRenderContextError Text -renderDocument context hintsSource blocks sourceBlocks = do - let indexedBlocks = zip [1 :: Int ..] blocks - blockInfos = - [ (index, block, blockAnchorId index block) - | (index, block) <- indexedBlocks - ] - rootTargets = - concatMap referenceTargetsOfBlockRenderInfo blockInfos - anchors = Map.fromList - [ (targetMarker, targetAnchorId) - | ReferenceTarget{targetMarker, targetAnchorId} <- - rootTargets - ] - referencedMarkers = collectReferencedMarkers blocks +renderDocument + context + hintsSource + renderIndex + HtmlPagePresentation + { pagePresentationBlockInfos = blockInfos + , pagePresentationAnchors = anchors + , pagePresentationReferencedMarkers = referencedMarkers + } = do previews <- buildPreviewMap context referencedMarkers anchors - sourceBlocks + renderIndex let result = case formatMissingHintWarning missingHints of Nothing -> rendered Just warningText -> trace (Text.unpack warningText) rendered hints = parseHints hintsSource - missingHints = collectMissingHints hints blocks + missingHints = + collectMissingHints + hints + [ block + | (_index, block, _blockId) <- blockInfos + ] rendered = LazyText.toStrict (renderText (renderPage hints)) pageLabel = htmlCurrentPageLabel context tocBlocks = [(index, blockId, block) | (index, block, blockId) <- blockInfos, includeInToc block] @@ -182,6 +201,73 @@ renderDocument context hintsSource blocks sourceBlocks = do ("" :: Text) Right result +-- | Index every block target and every page's referenced markers once in +-- deterministic source order. Rendering a page subsequently performs only +-- marker lookups in the shared index. +buildRenderIndex + :: NonEmpty (ResolvedSource, [Block]) + -> (HtmlRenderIndex, NonEmpty HtmlPagePresentation) +buildRenderIndex sourceBlocks = + ( HtmlRenderIndex + (Map.fromList + [ ( targetMarker target + , IndexedReferenceTarget ordinal source target + ) + | (ordinal, (source, target)) <- + zip [1 :: Int ..] orderedTargets + ]) + , pages + ) + where + analysedPages = + uncurry analysePage <$> sourceBlocks + pages = + fst <$> analysedPages + orderedTargets = + [ (htmlPagePresentationSource page, target) + | (page, targets) <- NonEmpty.toList analysedPages + , target <- targets + ] + + analysePage source blocks = + ( HtmlPagePresentation + { htmlPagePresentationSource = source + , pagePresentationBlockInfos = blockInfos + , pagePresentationAnchors = + Map.fromList + [ (targetMarker, targetAnchorId) + | ReferenceTarget + { targetMarker + , targetAnchorId + } <- targets + ] + , pagePresentationReferencedMarkers = + foldMap + (\(_blockInfo, _targets, references) -> references) + analysedBlocks + } + , targets + ) + where + analysedBlocks = + [ ( blockInfo + , referenceTargetsOfBlockRenderInfo blockInfo + , collectReferencedMarkersOfBlock block + ) + | (index, block) <- zip [1 :: Int ..] blocks + , let blockInfo = + (index, block, blockAnchorId index block) + ] + blockInfos = + [ blockInfo + | (blockInfo, _targets, _references) <- analysedBlocks + ] + targets = + concat + [ blockTargets + | (_blockInfo, blockTargets, _references) <- analysedBlocks + ] + pageStyles :: Text pageStyles = Text.unlines @@ -955,10 +1041,10 @@ referencePreviewScript = Text.unlines , "})();" ] -collectReferencedMarkers :: [Block] -> Set Marker -collectReferencedMarkers = - foldMap collectBlock - where +collectReferencedMarkersOfBlock :: Block -> Set Marker +collectReferencedMarkersOfBlock = + collectBlock + where collectBlock :: Block -> Set Marker collectBlock = \case BlockProof _start proof _end -> @@ -2376,29 +2462,30 @@ buildPreviewMap :: HtmlRenderContext -> Set Marker -> AnchorMap - -> [(ResolvedSource, [Block])] + -> HtmlRenderIndex -> Either HtmlRenderContextError PreviewMap -buildPreviewMap context referencedMarkers anchors sourceBlocks = +buildPreviewMap + context + referencedMarkers + anchors + (HtmlRenderIndex targetIndex) = Map.fromList <$> traverse makePreviewEntry indexedTargets where targets = - [ (source, target) - | (source, blocks) <- sourceBlocks - , let indexedBlocks = zip [1 :: Int ..] blocks - , let blockInfos = - [ (index, block, blockAnchorId index block) - | (index, block) <- indexedBlocks - ] - , target <- - concatMap - referenceTargetsOfBlockRenderInfo - blockInfos - , targetMarker target `Set.member` referencedMarkers - , targetMarker target `Map.notMember` anchors - , source /= htmlCurrentSource context - ] + List.sortOn targetOrdinal + [ indexed + | marker <- Set.toList referencedMarkers + , marker `Map.notMember` anchors + , Just indexed@(IndexedReferenceTarget _ source _target) <- + [Map.lookup marker targetIndex] + , source /= htmlCurrentSource context + ] + targetOrdinal (IndexedReferenceTarget ordinal _source _target) = + ordinal + sourceTarget (IndexedReferenceTarget _ordinal source target) = + (source, target) indexedTargets = - zip [1 :: Int ..] targets + zip [1 :: Int ..] (sourceTarget <$> targets) makePreviewEntry (index, (source, target)) = do previewSourceLabel <- diff --git a/source/Render/Html/Context.hs b/source/Render/Html/Context.hs index b8894f5..151edd5 100644 --- a/source/Render/Html/Context.hs +++ b/source/Render/Html/Context.hs @@ -4,9 +4,12 @@ -- | Browser-facing routing authority for one rendered HTML page. module Render.Html.Context - ( HtmlRenderContext + ( HtmlRenderEnvironment + , htmlRenderEnvironment + , HtmlRenderContext , HtmlRenderContextError(..) , htmlRenderContext + , htmlRenderContextFromEnvironment , htmlCurrentSource , htmlCurrentPageUrl , htmlCurrentPageLabel @@ -37,36 +40,56 @@ instance Exception HtmlRenderContextError data HtmlRenderContext = HtmlRenderContext { contextCurrentSource :: !ResolvedSource , contextCurrentPageUrl :: !UrlPath - , contextSourceUrls :: !(Map ResolvedSource UrlPath) - , contextRouteNamespaces :: !(Map SourceMountId UrlPath) - , contextSupportScriptUrl :: !UrlPath + , contextEnvironment :: !HtmlRenderEnvironment } deriving stock (Show, Eq) -htmlRenderContext - :: HtmlLayout - -> ResolvedSource - -> Either HtmlRenderContextError HtmlRenderContext -htmlRenderContext layout currentSource = do - let sourceUrls = +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 sourceUrls) + (Map.lookup + currentSource + (environmentSourceUrls environment)) Right HtmlRenderContext { contextCurrentSource = currentSource , contextCurrentPageUrl = currentPageUrl - , contextSourceUrls = sourceUrls - , contextRouteNamespaces = - htmlMountUrlPrefixes layout - , contextSupportScriptUrl = - routeUrlPath (htmlSupportScriptRoute layout) + , contextEnvironment = environment } htmlCurrentSource :: HtmlRenderContext -> ResolvedSource @@ -85,17 +108,17 @@ htmlRouteNamespaces :: HtmlRenderContext -> Map SourceMountId UrlPath htmlRouteNamespaces = - contextRouteNamespaces + environmentRouteNamespaces . contextEnvironment htmlSourceUrl :: HtmlRenderContext -> ResolvedSource -> Either HtmlRenderContextError UrlPath -htmlSourceUrl HtmlRenderContext{contextSourceUrls} source = +htmlSourceUrl HtmlRenderContext{contextEnvironment} source = maybe (Left (HtmlReferencedSourceNotRouted source)) Right - (Map.lookup source contextSourceUrls) + (Map.lookup source (environmentSourceUrls contextEnvironment)) htmlSourceLabel :: HtmlRenderContext @@ -136,7 +159,8 @@ htmlSupportScriptHref :: HtmlRenderContext -> Text htmlSupportScriptHref context = renderRelativeUrlPath (contextCurrentPageUrl context) - (contextSupportScriptUrl context) + (environmentSupportScriptUrl + (contextEnvironment context)) resolvedSourceLabel :: ResolvedSource -> Text resolvedSourceLabel source = diff --git a/source/Render/Html/Export.hs b/source/Render/Html/Export.hs index 3faf506..8b62f7d 100644 --- a/source/Render/Html/Export.hs +++ b/source/Render/Html/Export.hs @@ -1,11 +1,11 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE NoImplicitPrelude #-} --- | Prepare a complete HTML export from one fresh resolved source graph. +-- | Prepare a complete HTML export from retained parsed presentation. module Render.Html.Export - ( PreparedHtmlExport - , preparedHtmlRootDocument - , preparedHtmlOutputBundle + ( HtmlPresentation + , htmlPresentationFromParsedWorkspace , HtmlExportError(..) , renderHtmlExportError , prepareHtmlExport @@ -14,12 +14,11 @@ module Render.Html.Export import Base import Felix.Parse import Felix.Source -import Felix.Source.Graph import Render.Html qualified as Html import Render.Html.Context import Render.Html.Layout import Render.Html.Output -import Syntax.Abstract qualified as Raw +import Syntax.Abstract (Block) import Control.Exception (Exception) import Data.Bifunctor (first) @@ -28,31 +27,51 @@ import Data.Text qualified as Text import Data.Text.Encoding qualified as TextEncoding -data PreparedHtmlExport = PreparedHtmlExport - !Text - !PreparedHtmlBundle +-- | 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) -preparedHtmlRootDocument :: PreparedHtmlExport -> Text -preparedHtmlRootDocument - (PreparedHtmlExport rootDocument _bundle) = - rootDocument +data HtmlSourcePresentation = HtmlSourcePresentation + !ResolvedSource + ![Block] -preparedHtmlOutputBundle - :: PreparedHtmlExport - -> PreparedHtmlBundle -preparedHtmlOutputBundle - (PreparedHtmlExport _rootDocument bundle) = - bundle +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 - | HtmlExportSourceError !SourceError - | HtmlExportParseError !ParseWorkspaceError | HtmlExportLayoutError !HtmlLayoutError | HtmlExportContextError !HtmlRenderContextError - | HtmlExportOutputError !HtmlOutputError deriving stock (Show) instance Exception HtmlExportError @@ -66,10 +85,6 @@ renderHtmlExportError = \case "could not locate renderer data " <> quotePath path <> ": " <> reason HtmlRendererDataReadFailed path reason -> "could not read renderer data " <> quotePath path <> ": " <> reason - HtmlExportSourceError failure -> - renderSourceError failure - HtmlExportParseError failure -> - renderParseWorkspaceError failure HtmlExportLayoutError failure -> renderHtmlLayoutError failure HtmlExportContextError failure -> @@ -78,8 +93,6 @@ renderHtmlExportError = \case "current source has no HTML route: " <> sourceLabel source HtmlReferencedSourceNotRouted source -> "referenced source has no HTML route: " <> sourceLabel source - HtmlExportOutputError failure -> - renderHtmlOutputError failure where sourceLabel source = sourceMountIdText (resolvedSourceMount source) @@ -92,89 +105,76 @@ renderHtmlExportError = \case prepareHtmlExport :: [(SourceMountId, [Text])] - -> SourceMounts - -> RootRequest + -> HtmlPresentation -> Text - -> IO (Either HtmlExportError PreparedHtmlExport) -prepareHtmlExport mountPrefixes mounts request hints = do - graphResult <- - buildResolvedSourceGraph mounts request - case graphResult of - Left err -> - pure (Left (HtmlExportSourceError err)) - Right graph -> - case - first - HtmlExportLayoutError - (layoutHtmlSourceGraph mountPrefixes graph) of - Left err -> - pure (Left err) - Right layout -> do - workspaceResult <- - parseResolvedSourceGraph graph - pure do - workspace <- - first - HtmlExportParseError - workspaceResult - prepareRenderedExport - hints - layout - workspace + -> 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 prepareRenderedExport :: Text -> HtmlLayout - -> ParsedSourceWorkspace - -> Either HtmlExportError PreparedHtmlExport -prepareRenderedExport hints layout workspace = do - let orderedNodes = - parsedWorkspaceImportedBeforeImporter workspace - sourceBlocks = - [ (parsedModuleResolved node, parsedModuleBlocks node) - | node <- NonEmpty.toList orderedNodes - ] - renderedPages <- + -> 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 - (renderSourcePage hints layout sourceBlocks) - orderedNodes - let (_rootSource, _rootRoute, rootDocument) = - NonEmpty.last renderedPages - pageArtifacts = - [ ( routeDestination route - , TextEncoding.encodeUtf8 document - ) - | (_source, route, document) <- - NonEmpty.toList renderedPages - ] - supportRoute = + (prepareSourceArtifact + renderEnvironment + layout + hints + renderIndex) + pages + let supportRoute = htmlSupportScriptRoute layout supportArtifact = - ( routeDestination supportRoute - , TextEncoding.encodeUtf8 - Html.supportScriptAssetContents - ) - bundle <- - first - HtmlExportOutputError - (preparedHtmlBundle - (pageArtifacts <> [supportArtifact])) - Right (PreparedHtmlExport rootDocument bundle) + 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]) -renderSourcePage - :: Text +prepareSourceArtifact + :: HtmlRenderEnvironment -> HtmlLayout - -> [(ResolvedSource, [Raw.Block])] - -> ParsedModule + -> Text + -> Html.HtmlRenderIndex + -> Html.HtmlPagePresentation -> Either HtmlExportError - (ResolvedSource, HtmlRoute, Text) -renderSourcePage hints layout sourceBlocks node = do - let source = parsedModuleResolved node + PreparedHtmlArtifact +prepareSourceArtifact renderEnvironment layout hints renderIndex page = do + let source = Html.htmlPagePresentationSource page context <- first HtmlExportContextError - (htmlRenderContext layout source) + (htmlRenderContextFromEnvironment + renderEnvironment + source) route <- maybe (Left @@ -182,12 +182,15 @@ renderSourcePage hints layout sourceBlocks node = do (HtmlCurrentSourceNotRouted source))) Right (htmlPageRoute layout source) - document <- - first - HtmlExportContextError - (Html.renderDocument - context - hints - (parsedModuleBlocks node) - sourceBlocks) - Right (source, route, document) + Right + (preparedHtmlArtifact + (routeDestination route) + (first renderHtmlExportError + (TextEncoding.encodeUtf8 + <$> first + HtmlExportContextError + (Html.renderDocument + context + hints + renderIndex + page)))) diff --git a/source/Render/Html/Layout.hs b/source/Render/Html/Layout.hs index 6219107..c26b6b5 100644 --- a/source/Render/Html/Layout.hs +++ b/source/Render/Html/Layout.hs @@ -25,6 +25,7 @@ module Render.Html.Layout , htmlPageRoute , htmlSupportScriptRoute , htmlMountUrlPrefixes + , layoutHtmlSources , layoutHtmlSourceGraph ) where @@ -263,11 +264,20 @@ layoutHtmlSourceGraph :: [(SourceMountId, [Text])] -> ResolvedSourceGraph -> Either HtmlLayoutError HtmlLayout -layoutHtmlSourceGraph specifications graph = do +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 - (sourceNodeResolved <$> sourceGraphNodes graph) + inputSources usedMounts = Set.fromList (resolvedSourceMount <$> sources) missingMounts = @@ -548,7 +558,6 @@ supportScriptAssetComponents :: [Text] supportScriptAssetComponents = ["_static", "naproche-html.js"] --- Used by the current single-page writer until bundle publication lands. percentEncodeUtf8 :: Text -> Text percentEncodeUtf8 = Text.pack diff --git a/source/Render/Html/Output.hs b/source/Render/Html/Output.hs index 0354806..a8b4d93 100644 --- a/source/Render/Html/Output.hs +++ b/source/Render/Html/Output.hs @@ -9,9 +9,9 @@ -- symlinks are rejected without following them; regular generated files may be -- replaced. This policy prevents stable-tree escapes, not TOCTOU attacks. module Render.Html.Output - ( PreparedHtmlBundle - , preparedHtmlBundle - , preparedHtmlBundleDestinations + ( PreparedHtmlArtifact + , preparedHtmlArtifact + , preparedHtmlArtifactDestination , HtmlRoutePlan , htmlRoutePlanDestinations , planHtmlRoutes @@ -37,57 +37,34 @@ import Control.Monad (unless, when) import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE) import Data.ByteString (ByteString) import Data.ByteString qualified as ByteString -import Data.IORef - ( IORef - , atomicModifyIORef' - , newIORef - ) 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 - !ByteString - --- | A complete, destination-unique bundle of strict bytes. -newtype PreparedHtmlBundle = PreparedHtmlBundle - [PreparedHtmlArtifact] - -preparedHtmlBundle - :: [(SafeRelativePath, ByteString)] - -> Either HtmlOutputError PreparedHtmlBundle -preparedHtmlBundle artifacts = - case artifacts of - [] -> - Left EmptyPreparedHtmlBundle - _ -> - case duplicateDestinations - (fst <$> artifacts) of - duplicate : _ -> - Left - (DuplicatePreparedHtmlDestination - duplicate) - [] -> - Right - (PreparedHtmlBundle - [ PreparedHtmlArtifact destination bytes - | (destination, bytes) <- - Map.toAscList - (Map.fromList artifacts) - ]) - -preparedHtmlBundleDestinations - :: PreparedHtmlBundle - -> [SafeRelativePath] -preparedHtmlBundleDestinations (PreparedHtmlBundle artifacts) = - [ destination - | PreparedHtmlArtifact destination _bytes <- artifacts - ] + (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. @@ -106,10 +83,10 @@ newtype HtmlOutputPlan = HtmlOutputPlan data PlannedHtmlArtifact = PlannedHtmlArtifact !SafeRelativePath !FilePath - !ByteString + (Either Text ByteString) data HtmlOutputError - = EmptyPreparedHtmlBundle + = EmptyPreparedHtmlOutput | DuplicatePreparedHtmlDestination !SafeRelativePath | HtmlOutputRouteMismatch ![SafeRelativePath] @@ -125,7 +102,7 @@ data HtmlOutputError renderHtmlOutputError :: HtmlOutputError -> Text renderHtmlOutputError = \case - EmptyPreparedHtmlBundle -> + EmptyPreparedHtmlOutput -> "HTML output contains no artifacts" DuplicatePreparedHtmlDestination relative -> "HTML output contains destination more than once: " @@ -162,13 +139,13 @@ instance Exception HtmlOutputError -- | Validate every destination without changing the filesystem. planHtmlOutput :: FilePath - -> PreparedHtmlBundle + -> [PreparedHtmlArtifact] -> IO (Either HtmlOutputError HtmlOutputPlan) -planHtmlOutput outputRoot bundle = do +planHtmlOutput outputRoot artifacts = do routes <- planHtmlRoutes outputRoot - (preparedHtmlBundleDestinations bundle) - pure (routes >>= (`planHtmlOutputAgainst` bundle)) + (preparedHtmlArtifactDestination <$> artifacts) + pure (routes >>= (`planHtmlOutputAgainst` artifacts)) planHtmlRoutes :: FilePath @@ -177,7 +154,7 @@ planHtmlRoutes planHtmlRoutes outputRoot destinations = runExceptT do when (null destinations) - (throwE EmptyPreparedHtmlBundle) + (throwE EmptyPreparedHtmlOutput) case duplicateDestinations destinations of duplicate : _ -> throwE @@ -227,33 +204,41 @@ planHtmlRoutes outputRoot destinations = planHtmlOutputAgainst :: HtmlRoutePlan - -> PreparedHtmlBundle + -> [PreparedHtmlArtifact] -> Either HtmlOutputError HtmlOutputPlan planHtmlOutputAgainst (HtmlRoutePlan routes) - (PreparedHtmlBundle artifacts) - | plannedDestinations /= bundleDestinations = + artifacts + | null artifacts = + Left EmptyPreparedHtmlOutput + | duplicate : _ <- duplicateDestinations preparedDestinations = + Left (DuplicatePreparedHtmlDestination duplicate) + | Set.fromList plannedDestinations + /= Set.fromList preparedDestinations = Left (HtmlOutputRouteMismatch plannedDestinations - bundleDestinations) - | otherwise = - Right - (HtmlOutputPlan - [ PlannedHtmlArtifact - relative - destination - bytes - | ( (relative, destination) - , PreparedHtmlArtifact _ bytes - ) <- zip routes artifacts - ]) + preparedDestinations) + | otherwise = HtmlOutputPlan <$> traverse attach artifacts where plannedDestinations = fst <$> routes - bundleDestinations = - [ relative - | PreparedHtmlArtifact relative _bytes <- artifacts - ] + 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] @@ -293,127 +278,68 @@ renderHtmlPublicationError failure = (quoteRelative <$> committed) ] -data StagedHtmlArtifact = StagedHtmlArtifact - !SafeRelativePath - !FilePath - !FilePath - --- | Publish a completely preflighted bundle. --- --- All strict bytes are staged in temporary siblings before the first rename. --- Each rename atomically replaces one directory entry. The bundle as a whole --- is not atomic: a later failure reports the already committed destinations --- and removes the remaining temporary files. +-- | 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) = - Exception.mask \restore -> do - stagedRef <- newIORef [] - result <- - restore - (stageAndPublish stagedRef planned) - `Exception.onException` - cleanupStagedRef stagedRef - cleanupStagedRef stagedRef - pure result - -stageAndPublish - :: IORef [StagedHtmlArtifact] - -> [PlannedHtmlArtifact] - -> IO (Either HtmlPublicationError ()) -stageAndPublish stagedRef planned = do - stagedResult <- stageAll stagedRef planned - case stagedResult of - Left err -> - pure (Left err) - Right staged -> - publishAll stagedRef [] staged - -stageAll - :: IORef [StagedHtmlArtifact] - -> [PlannedHtmlArtifact] - -> IO - (Either - HtmlPublicationError - [StagedHtmlArtifact]) -stageAll stagedRef = - go [] - where - go staged [] = - pure (Right (reverse staged)) - go staged - (artifact@(PlannedHtmlArtifact relative _destination _bytes) - : remaining) = do - result <- tryIOException (stageArtifact artifact) - case result of - Left err -> - pure - (Left - (publicationError - [] - relative - err)) - Right stagedArtifact -> do - atomicModifyIORef' stagedRef - \current -> - (stagedArtifact : current, ()) - go - (stagedArtifact : staged) - remaining - -stageArtifact - :: PlannedHtmlArtifact - -> IO StagedHtmlArtifact -stageArtifact - (PlannedHtmlArtifact relative destination bytes) = do - let directory = Posix.takeDirectory destination - Directory.createDirectoryIfMissing True directory - bracketOnError - (openBinaryTempFileWithDefaultPermissions - directory - (Posix.takeFileName destination <> ".tmp")) - cleanupTemporary - \(temporary, handle) -> do - ByteString.hPut handle bytes - hFlush handle - hClose handle - pure - (StagedHtmlArtifact - relative - destination - temporary) + publishAll [] planned publishAll - :: IORef [StagedHtmlArtifact] - -> [SafeRelativePath] - -> [StagedHtmlArtifact] + :: [SafeRelativePath] + -> [PlannedHtmlArtifact] -> IO (Either HtmlPublicationError ()) -publishAll _stagedRef _committed [] = +publishAll _committed [] = pure (Right ()) publishAll - stagedRef - committedReversed - ( staged@(StagedHtmlArtifact relative destination temporary) - : remaining - ) = do - result <- - tryIOException - (Directory.renameFile temporary destination) - case result of - Left err -> - pure - (Left - (publicationError - (reverse committedReversed) - relative - err)) - Right () -> do - forgetStaged stagedRef staged - publishAll - stagedRef - (relative : committedReversed) - remaining + 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 + bracketOnError + (openBinaryTempFileWithDefaultPermissions + directory + (Posix.takeFileName destination <> ".tmp")) + cleanupTemporary + \(temporary, handle) -> do + ByteString.hPut handle bytes + hFlush handle + hClose handle + Directory.renameFile temporary destination publicationError :: [SafeRelativePath] @@ -428,29 +354,6 @@ publicationError committed failed err = Text.pack (displayException err) } -forgetStaged - :: IORef [StagedHtmlArtifact] - -> StagedHtmlArtifact - -> IO () -forgetStaged stagedRef (StagedHtmlArtifact _ _ temporary) = - atomicModifyIORef' stagedRef - \staged -> - ( List.filter - (\(StagedHtmlArtifact _ _ candidate) -> - candidate /= temporary) - staged - , () - ) - -cleanupStagedRef :: IORef [StagedHtmlArtifact] -> IO () -cleanupStagedRef stagedRef = do - staged <- atomicModifyIORef' stagedRef (\current -> ([], current)) - traverse_ cleanupStagedPath staged - -cleanupStagedPath :: StagedHtmlArtifact -> IO () -cleanupStagedPath (StagedHtmlArtifact _ _ temporary) = - void (tryIOError (Directory.removeFile temporary)) - cleanupTemporary :: (FilePath, Handle) -> IO () cleanupTemporary (temporary, handle) = do void (tryIOError (hClose handle)) |