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