diff options
Diffstat (limited to 'source/Render/Html')
| -rw-r--r-- | source/Render/Html/Context.hs | 171 | ||||
| -rw-r--r-- | source/Render/Html/Export.hs | 277 | ||||
| -rw-r--r-- | source/Render/Html/Layout.hs | 602 | ||||
| -rw-r--r-- | source/Render/Html/Output.hs | 471 |
4 files changed, 0 insertions, 1521 deletions
diff --git a/source/Render/Html/Context.hs b/source/Render/Html/Context.hs deleted file mode 100644 index 151edd5..0000000 --- a/source/Render/Html/Context.hs +++ /dev/null @@ -1,171 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NoImplicitPrelude #-} - --- | Browser-facing routing authority for one rendered HTML page. -module 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 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/Render/Html/Export.hs b/source/Render/Html/Export.hs deleted file mode 100644 index 2c747d8..0000000 --- a/source/Render/Html/Export.hs +++ /dev/null @@ -1,277 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE NoImplicitPrelude #-} - --- | Prepare a complete HTML export from retained parsed presentation. -module Render.Html.Export - ( HtmlPresentation - , htmlPresentationFromParsedWorkspace - , HtmlExportError(..) - , renderHtmlExportError - , prepareHtmlExport - , prepareHtmlExportWithLayout - , prepareHtmlExportWithLayoutFromRendererRoots - ) where - -import Base -import Felix.Parse -import Felix.Source -import Render.Html qualified as Html -import Render.Html.Context -import Render.Html.Layout -import Render.Html.Output -import 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/Render/Html/Layout.hs b/source/Render/Html/Layout.hs deleted file mode 100644 index c26b6b5..0000000 --- a/source/Render/Html/Layout.hs +++ /dev/null @@ -1,602 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE NoImplicitPrelude #-} - --- | Pure browser and destination routing for a resolved source graph. -module 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/Render/Html/Output.hs b/source/Render/Html/Output.hs deleted file mode 100644 index 685c83a..0000000 --- a/source/Render/Html/Output.hs +++ /dev/null @@ -1,471 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE NoImplicitPrelude #-} - --- | Confined filesystem authority for HTML output. --- --- The output root is assumed to be user-owned and not concurrently changed by --- a hostile actor between planning and writing. Existing parent symlinks are --- accepted only when they resolve inside the canonical root. Final-target --- symlinks are rejected without following them; regular generated files may be --- replaced. This policy prevents stable-tree escapes, not TOCTOU attacks. -module Render.Html.Output - ( 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))) |