diff options
Diffstat (limited to 'source/Render/Html/Output.hs')
| -rw-r--r-- | source/Render/Html/Output.hs | 315 |
1 files changed, 109 insertions, 206 deletions
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)) |