diff options
Diffstat (limited to 'source/Felix/Render/Html/Layout.hs')
| -rw-r--r-- | source/Felix/Render/Html/Layout.hs | 602 |
1 files changed, 602 insertions, 0 deletions
diff --git a/source/Felix/Render/Html/Layout.hs b/source/Felix/Render/Html/Layout.hs new file mode 100644 index 0000000..7e5bfcf --- /dev/null +++ b/source/Felix/Render/Html/Layout.hs @@ -0,0 +1,602 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Pure browser and destination routing for a resolved source graph. +module Felix.Render.Html.Layout + ( UrlSegment + , UrlSegmentError(..) + , urlSegment + , renderUrlSegment + , UrlPath + , urlPath + , renderUrlPath + , renderRelativeUrlPath + , renderUrlFragment + , HtmlRoute + , routeDestination + , routeUrlPath + , HtmlRouteOwner(..) + , HtmlUrlRouteCollision(..) + , HtmlDestinationRouteCollision(..) + , HtmlLayoutError(..) + , renderHtmlLayoutError + , HtmlLayout + , htmlPageRoutes + , htmlPageRoute + , htmlSupportScriptRoute + , htmlMountUrlPrefixes + , layoutHtmlSources + , layoutHtmlSourceGraph + ) where + +import Base +import Felix.Source +import Felix.Source.Graph + +import Control.Exception (Exception) +import Data.Bifunctor (first) +import Data.ByteString qualified as ByteString +import Data.Char (chr) +import Data.List qualified as List +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as Text +import Data.Text.Encoding qualified as TextEncoding +import Data.Word (Word8) +import System.FilePath.Posix qualified as Posix + + +-- | One canonical percent-encoded URL path segment. +newtype UrlSegment = UrlSegment Text + deriving stock (Show, Eq, Ord) + +data UrlSegmentError + = EmptyUrlSegment + | DotUrlSegment !Text + | UrlSegmentContainsSeparator !Text + | UrlSegmentContainsNull !Text + deriving stock (Show, Eq) + +urlSegment :: Text -> Either UrlSegmentError UrlSegment +urlSegment decoded + | Text.null decoded = + Left EmptyUrlSegment + | decoded == "." || decoded == ".." = + Left (DotUrlSegment decoded) + | "/" `Text.isInfixOf` decoded = + Left (UrlSegmentContainsSeparator decoded) + | "\0" `Text.isInfixOf` decoded = + Left (UrlSegmentContainsNull decoded) + | otherwise = + Right (UrlSegment (percentEncodeUtf8 decoded)) + +renderUrlSegment :: UrlSegment -> Text +renderUrlSegment (UrlSegment encoded) = + encoded + + +-- | A root-relative URL path. Its segments are already encoded. +newtype UrlPath = UrlPath [UrlSegment] + deriving stock (Show, Eq, Ord) + +urlPath :: [Text] -> Either UrlSegmentError UrlPath +urlPath = + fmap UrlPath . traverse urlSegment + +renderUrlPath :: UrlPath -> Text +renderUrlPath (UrlPath segments) = + "/" <> Text.intercalate "/" (renderUrlSegment <$> segments) + +-- | Render a target path relative to the directory of a current page. +renderRelativeUrlPath :: UrlPath -> UrlPath -> Text +renderRelativeUrlPath + (UrlPath currentPageSegments) + (UrlPath targetSegments) = + case relativeSegments of + [] -> + "." + _ -> + Text.intercalate "/" relativeSegments + where + currentDirectorySegments = + case reverse currentPageSegments of + [] -> + [] + _page : directoryReversed -> + reverse directoryReversed + (remainingCurrent, remainingTarget) = + dropCommonPrefix currentDirectorySegments targetSegments + relativeSegments = + replicate (length remainingCurrent) ".." + <> (renderUrlSegment <$> remainingTarget) + +-- | Render an exact source marker as an encoded URL fragment. +renderUrlFragment :: Text -> Text +renderUrlFragment marker = + "#" <> percentEncodeUtf8 marker + + +data HtmlRoute = HtmlRoute + { routeDestination :: !SafeRelativePath + , routeUrlPath :: !UrlPath + } + deriving stock (Show, Eq) + +data HtmlRouteOwner + = HtmlPage !ResolvedSource + | HtmlSupportScript + deriving stock (Show, Eq, Ord) + +data HtmlUrlRouteCollision = HtmlUrlRouteCollision + !UrlPath + !(NonEmpty HtmlRouteOwner) + deriving stock (Show, Eq) + +data HtmlDestinationRouteCollision = HtmlDestinationRouteCollision + !SafeRelativePath + !(NonEmpty HtmlRouteOwner) + | NestedHtmlDestinationRouteCollision + !SafeRelativePath + !HtmlRouteOwner + !SafeRelativePath + !HtmlRouteOwner + deriving stock (Show, Eq) + +data HtmlLayoutError + = DuplicateHtmlMountId !SourceMountId + | InvalidHtmlMountPrefixSegment + !SourceMountId + !Text + !UrlSegmentError + | DuplicateHtmlMountPrefix + ![Text] + !(NonEmpty SourceMountId) + | MissingHtmlMountPrefix !SourceMountId + | InvalidHtmlRouteSegment + !HtmlRouteOwner + !Text + !UrlSegmentError + | InvalidHtmlRouteDestination + !HtmlRouteOwner + !FilePath + !RelativePathError + | CollidingHtmlRoutes + ![HtmlUrlRouteCollision] + ![HtmlDestinationRouteCollision] + deriving stock (Show, Eq) + +instance Exception HtmlLayoutError + +renderHtmlLayoutError :: HtmlLayoutError -> Text +renderHtmlLayoutError = \case + DuplicateHtmlMountId mount -> + "HTML mount is configured more than once: " + <> quoteText (sourceMountIdText mount) + InvalidHtmlMountPrefixSegment mount segment _problem -> + "HTML mount " <> quoteText (sourceMountIdText mount) + <> " has invalid route segment " <> quoteText segment + DuplicateHtmlMountPrefix prefix mounts -> + "HTML route prefix " <> quoteText (Text.intercalate "/" prefix) + <> " is shared by mounts " + <> Text.intercalate ", " + (quoteText . sourceMountIdText <$> toList mounts) + MissingHtmlMountPrefix mount -> + "no HTML route prefix is configured for mount " + <> quoteText (sourceMountIdText mount) + InvalidHtmlRouteSegment owner segment _problem -> + renderOwner owner <> " has invalid route segment " <> quoteText segment + InvalidHtmlRouteDestination owner path _problem -> + renderOwner owner <> " has invalid HTML destination " <> quotePath path + CollidingHtmlRoutes urlCollisions destinationCollisions -> + "HTML routes collide: " + <> Text.intercalate "; " + ( (renderUrlCollision <$> urlCollisions) + <> (renderDestinationCollision <$> destinationCollisions) + ) + where + renderUrlCollision (HtmlUrlRouteCollision path owners) = + "URL " <> quoteText (renderUrlPath path) + <> " is owned by " + <> Text.intercalate ", " (renderOwner <$> toList owners) + + renderDestinationCollision + (HtmlDestinationRouteCollision path owners) = + "destination " + <> quotePath (safeRelativePathFilePath path) + <> " is owned by " + <> Text.intercalate ", " (renderOwner <$> toList owners) + renderDestinationCollision + (NestedHtmlDestinationRouteCollision + ancestor ancestorOwner descendant descendantOwner) = + "destination " <> quotePath (safeRelativePathFilePath ancestor) + <> " for " <> renderOwner ancestorOwner + <> " is an ancestor of " + <> quotePath (safeRelativePathFilePath descendant) + <> " for " <> renderOwner descendantOwner + +renderOwner :: HtmlRouteOwner -> Text +renderOwner = \case + HtmlPage source -> + "page " + <> quoteText + (sourceMountIdText (resolvedSourceMount source) + <> ":" + <> Text.pack + (safeRelativePathFilePath + (resolvedSourceRelativePath source))) + HtmlSupportScript -> + "support script" + +quotePath :: FilePath -> Text +quotePath = Text.pack . show + +quoteText :: Text -> Text +quoteText = Text.pack . show + +data HtmlLayout = HtmlLayout + !(Map ResolvedSource HtmlRoute) + !HtmlRoute + !(Map SourceMountId UrlPath) + deriving stock (Show, Eq) + +htmlPageRoutes :: HtmlLayout -> [(ResolvedSource, HtmlRoute)] +htmlPageRoutes (HtmlLayout routes _supportScript _mountPrefixes) = + Map.toAscList routes + +htmlPageRoute :: HtmlLayout -> ResolvedSource -> Maybe HtmlRoute +htmlPageRoute (HtmlLayout routes _supportScript _mountPrefixes) source = + Map.lookup source routes + +htmlSupportScriptRoute :: HtmlLayout -> HtmlRoute +htmlSupportScriptRoute (HtmlLayout _routes supportScript _mountPrefixes) = + supportScript + +htmlMountUrlPrefixes :: HtmlLayout -> Map SourceMountId UrlPath +htmlMountUrlPrefixes (HtmlLayout _routes _supportScript mountPrefixes) = + mountPrefixes + + +data ValidatedMountPrefix = ValidatedMountPrefix + ![Text] + ![UrlSegment] + +layoutHtmlSourceGraph + :: [(SourceMountId, [Text])] + -> ResolvedSourceGraph + -> Either HtmlLayoutError HtmlLayout +layoutHtmlSourceGraph specifications graph = + layoutHtmlSources + specifications + (sourceNodeResolved <$> sourceGraphNodes graph) + +layoutHtmlSources + :: [(SourceMountId, [Text])] + -> [ResolvedSource] + -> Either HtmlLayoutError HtmlLayout +layoutHtmlSources specifications inputSources = do + prefixes <- validateMountPrefixes specifications + let sources = + List.sort + inputSources + usedMounts = + Set.fromList (resolvedSourceMount <$> sources) + missingMounts = + usedMounts `Set.difference` Map.keysSet prefixes + case Set.lookupMin missingMounts of + Just missing -> + Left (MissingHtmlMountPrefix missing) + Nothing -> do + pageEntries <- + traverse + (makePageRoute prefixes) + sources + encodedSupportScript <- + encodeRouteSegments + HtmlSupportScript + supportScriptAssetComponents + supportScript <- + makeRoute + HtmlSupportScript + supportScriptAssetComponents + encodedSupportScript + let ownedRoutes = + (HtmlSupportScript, supportScript) + : [ (HtmlPage source, route) + | (source, route) <- pageEntries + ] + urlCollisions = + collectUrlCollisions ownedRoutes + destinationCollisions = + collectDestinationCollisions ownedRoutes + <> collectNestedDestinationCollisions ownedRoutes + if null urlCollisions && null destinationCollisions + then + Right + (HtmlLayout + (Map.fromList pageEntries) + supportScript + (Map.map + (\(ValidatedMountPrefix _decoded encoded) -> + UrlPath encoded) + prefixes)) + else + Left + (CollidingHtmlRoutes + urlCollisions + destinationCollisions) + +validateMountPrefixes + :: [(SourceMountId, [Text])] + -> Either HtmlLayoutError (Map SourceMountId ValidatedMountPrefix) +validateMountPrefixes specifications = + case duplicateValues (fst <$> specifications) of + duplicate : _ -> + Left (DuplicateHtmlMountId duplicate) + [] -> do + validated <- traverse validatePrefix (List.sort specifications) + case duplicatePrefixGroups validated of + duplicate : _ -> + Left duplicate + [] -> + Right + (Map.fromList + [ (mount, prefix) + | (mount, _decoded, prefix) <- validated + ]) + where + validatePrefix (mount, decoded) = do + encoded <- traverse + (\segment -> + first + (InvalidHtmlMountPrefixSegment mount segment) + (urlSegment segment)) + decoded + Right + ( mount + , decoded + , ValidatedMountPrefix decoded encoded + ) + +duplicatePrefixGroups + :: [(SourceMountId, [Text], ValidatedMountPrefix)] + -> [HtmlLayoutError] +duplicatePrefixGroups validated = + [ DuplicateHtmlMountPrefix prefix (firstMount :| otherMounts) + | (prefix, mounts) <- + Map.toAscList + (Map.fromListWith (<>) + [ (decoded, [mount]) + | (mount, decoded, _prefix) <- validated + ]) + , firstMount : secondMount : remainingMounts <- + [List.sort mounts] + , let otherMounts = secondMount : remainingMounts + ] + +duplicateValues :: Ord a => [a] -> [a] +duplicateValues values = + [ value + | (value, multiplicity) <- + Map.toAscList + (Map.fromListWith (+) + [(value, 1 :: Int) | value <- values]) + , multiplicity > 1 + ] + +makePageRoute + :: Map SourceMountId ValidatedMountPrefix + -> ResolvedSource + -> Either HtmlLayoutError (ResolvedSource, HtmlRoute) +makePageRoute prefixes source = do + prefix <- case Map.lookup (resolvedSourceMount source) prefixes of + Nothing -> + Left + (MissingHtmlMountPrefix + (resolvedSourceMount source)) + Just found -> + Right found + let sourceComponents = + Text.splitOn + "/" + (Text.pack + (safeRelativePathFilePath + (resolvedSourceRelativePath source))) + destinationComponents = + replaceFinalComponent + (\component -> + dropFinalExtension component <> ".html") + sourceComponents + urlComponents = + replaceFinalComponent + dropFinalExtension + sourceComponents + ValidatedMountPrefix decodedPrefix encodedPrefix = + prefix + owner = HtmlPage source + encodedPageComponents <- + encodeRouteSegments owner urlComponents + route <- + makeRoute + owner + (decodedPrefix <> destinationComponents) + (encodedPrefix <> encodedPageComponents) + Right (source, route) + +replaceFinalComponent :: (a -> a) -> [a] -> [a] +replaceFinalComponent transform components = + case reverse components of + [] -> + [] + final : precedingReversed -> + reverse precedingReversed <> [transform final] + +dropFinalExtension :: Text -> Text +dropFinalExtension component = + case Text.breakOnEnd "." component of + ("", _suffix) -> + component + (".", _suffix) -> + component + (prefix, _suffix) -> + Text.dropEnd 1 prefix + +makeRoute + :: HtmlRouteOwner + -> [Text] + -> [UrlSegment] + -> Either HtmlLayoutError HtmlRoute +makeRoute owner destinationComponents encodedUrlComponents = do + let destinationSpelling = + List.intercalate + "/" + (Text.unpack <$> destinationComponents) + destination <- + first + (InvalidHtmlRouteDestination + owner + destinationSpelling) + (safeRelativePath destinationSpelling) + Right + HtmlRoute + { routeDestination = destination + , routeUrlPath = UrlPath encodedUrlComponents + } + +encodeRouteSegments + :: HtmlRouteOwner + -> [Text] + -> Either HtmlLayoutError [UrlSegment] +encodeRouteSegments owner = + traverse + (\decoded -> + first + (InvalidHtmlRouteSegment owner decoded) + (urlSegment decoded)) + +collectUrlCollisions + :: [(HtmlRouteOwner, HtmlRoute)] + -> [HtmlUrlRouteCollision] +collectUrlCollisions ownedRoutes = + [ HtmlUrlRouteCollision path owners + | (path, collidingOwners) <- + Map.toAscList + (Map.fromListWith (<>) + [ (routeUrlPath route, [owner]) + | (owner, route) <- ownedRoutes + ]) + , owners <- + collisionOwners collidingOwners + ] + +collectDestinationCollisions + :: [(HtmlRouteOwner, HtmlRoute)] + -> [HtmlDestinationRouteCollision] +collectDestinationCollisions ownedRoutes = + [ HtmlDestinationRouteCollision destination owners + | (destination, collidingOwners) <- + Map.toAscList + (Map.fromListWith (<>) + [ (routeDestination route, [owner]) + | (owner, route) <- ownedRoutes + ]) + , owners <- + collisionOwners collidingOwners + ] + +collectNestedDestinationCollisions + :: [(HtmlRouteOwner, HtmlRoute)] + -> [HtmlDestinationRouteCollision] +collectNestedDestinationCollisions ownedRoutes = + take 1 + [ NestedHtmlDestinationRouteCollision + ancestor + ancestorOwner + descendant + descendantOwner + | ( (ancestorComponents, ancestor, ancestorOwner) + , (descendantComponents, descendant, descendantOwner) + ) <- zip destinations (drop 1 destinations) + , strictComponentPrefix ancestorComponents descendantComponents + ] + where + destinations = + List.sort + [ ( relativePathComponents destination + , destination + , owner + ) + | (owner, route) <- ownedRoutes + , let destination = routeDestination route + ] + +relativePathComponents :: SafeRelativePath -> [FilePath] +relativePathComponents = + Posix.splitDirectories . safeRelativePathFilePath + +strictComponentPrefix :: [FilePath] -> [FilePath] -> Bool +strictComponentPrefix possibleAncestor possibleDescendant = + length possibleAncestor < length possibleDescendant + && possibleAncestor `List.isPrefixOf` possibleDescendant + +collisionOwners :: [HtmlRouteOwner] -> [NonEmpty HtmlRouteOwner] +collisionOwners owners = + case List.sort owners of + firstOwner : secondOwner : rest -> + [firstOwner :| (secondOwner : rest)] + _ -> + [] + +dropCommonPrefix :: Eq a => [a] -> [a] -> ([a], [a]) +dropCommonPrefix (left : lefts) (right : rights) + | left == right = + dropCommonPrefix lefts rights +dropCommonPrefix left right = + (left, right) + + +supportScriptAssetComponents :: [Text] +supportScriptAssetComponents = + ["_static", "naproche-html.js"] + +percentEncodeUtf8 :: Text -> Text +percentEncodeUtf8 = + Text.pack + . concatMap encodeByte + . ByteString.unpack + . TextEncoding.encodeUtf8 + +encodeByte :: Word8 -> String +encodeByte byte + | isUnreservedAscii byte = + [chr (fromIntegral byte)] + | otherwise = + [ '%' + , hexadecimalDigit (byte `div` 16) + , hexadecimalDigit (byte `mod` 16) + ] + +isUnreservedAscii :: Word8 -> Bool +isUnreservedAscii byte = + isAsciiUpper byte + || isAsciiLower byte + || isAsciiDigit byte + || byte `elem` fmap (fromIntegral . fromEnum) ("-._~" :: String) + +isAsciiUpper :: Word8 -> Bool +isAsciiUpper byte = + byte >= 65 && byte <= 90 + +isAsciiLower :: Word8 -> Bool +isAsciiLower byte = + byte >= 97 && byte <= 122 + +isAsciiDigit :: Word8 -> Bool +isAsciiDigit byte = + byte >= 48 && byte <= 57 + +hexadecimalDigit :: Word8 -> Char +hexadecimalDigit value + | value < 10 = + chr (fromIntegral value + fromEnum '0') + | otherwise = + chr (fromIntegral value - 10 + fromEnum 'A') |