diff options
Diffstat (limited to 'source/Felix/Test/Unit/HtmlLayout.hs')
| -rw-r--r-- | source/Felix/Test/Unit/HtmlLayout.hs | 478 |
1 files changed, 478 insertions, 0 deletions
diff --git a/source/Felix/Test/Unit/HtmlLayout.hs b/source/Felix/Test/Unit/HtmlLayout.hs new file mode 100644 index 0000000..a3d701f --- /dev/null +++ b/source/Felix/Test/Unit/HtmlLayout.hs @@ -0,0 +1,478 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Felix.Test.Unit.HtmlLayout (unitTests) where + +import Base +import Felix.Source +import Felix.Source.Graph +import Felix.Render.Html.Layout + +import Control.Exception (bracket) +import Data.List qualified as List +import Data.List.NonEmpty qualified as NonEmpty +import Data.Text qualified as Text +import System.Directory qualified as Directory +import System.FilePath.Posix qualified as Posix +import Test.Tasty +import Test.Tasty.HUnit + + +unitTests :: TestTree +unitTests = + testGroup "HTML layout" + [ testCase + "encodes URL segments canonically" + encodesUrlSegments + , testCase + "renders relative typed URLs" + rendersRelativeUrls + , testCase + "separates mounted route namespaces" + separatesMountedNamespaces + , testCase + "routes searched and exact roots identically" + routesRootFormsIdentically + , testCase + "requires an explicit mount for an external root" + requiresExternalMount + , testCase + "reports URL and destination collisions independently" + reportsRouteCollisions + , testCase + "rejects ancestor and descendant destinations" + rejectsNestedDestinations + , testCase + "is independent of graph and configuration traversal order" + isTraversalOrderIndependent + ] + + +encodesUrlSegments :: Assertion +encodesUrlSegments = do + let accepted = + [ ("AZaz09-._~", "AZaz09-._~") + , ("#?% \\", "%23%3F%25%20%5C") + , ("über", "%C3%BCber") + , ("%2f", "%252f") + ] + for_ accepted \(decoded, expected) -> + assertEqual + ("encoded segment " <> Text.unpack decoded) + (Right expected) + (renderUrlSegment <$> urlSegment decoded) + let rejected = + [ ("", EmptyUrlSegment) + , (".", DotUrlSegment ".") + , ("..", DotUrlSegment "..") + , ("a/b", UrlSegmentContainsSeparator "a/b") + ] + for_ rejected \(decoded, expected) -> + assertEqual + ("rejected segment " <> Text.unpack decoded) + (Left expected) + (urlSegment decoded) + assertEqual + "fragment encoding" + "#name%23%C3%BC" + (renderUrlFragment "name#ü") + +rendersRelativeUrls :: Assertion +rendersRelativeUrls = do + let cases = + [ ( ["library", "nested", "über"] + , ["_static", "naproche-html.js"] + , "../../_static/naproche-html.js" + ) + , ( ["first", "entry"] + , ["second", "entry"] + , "../second/entry" + ) + , ( ["mount", "entry"] + , ["mount", "a?b"] + , "a%3Fb" + ) + ] + for_ cases \(currentSegments, targetSegments, expected) -> do + current <- expectRight (urlPath currentSegments) + target <- expectRight (urlPath targetSegments) + assertEqual + "relative URL" + expected + (renderRelativeUrlPath current target) + current <- expectRight (urlPath ["mount", "entry"]) + target <- expectRight (urlPath ["mount", "ü"]) + assertEqual + "encoded path and fragment remain separate" + "%C3%BC#part%23%3F" + ( renderRelativeUrlPath current target + <> renderUrlFragment "part#?" + ) + +separatesMountedNamespaces :: Assertion +separatesMountedNamespaces = + withTemporaryDirectory "felix-html-layout-mounts" \temp -> do + let mountSpecifications = + [ ("project", []) + , ("library", ["library"]) + , ("debug", ["debug"]) + , ("external", ["external"]) + ] + roots <- for mountSpecifications \(ident, _prefix) -> do + let root = temp Posix.</> Text.unpack ident + Directory.createDirectory root + writeTheory (root Posix.</> "entry.tex") [] + pure (sourceMountId ident, root) + mounts <- expectRight =<< prepareSourceMounts roots + routes <- for mountSpecifications \(ident, prefix) -> do + let sourcePath = + temp + Posix.</> Text.unpack ident + Posix.</> "entry.tex" + request <- expectRight =<< existingRoot sourcePath + graph <- expectRight =<< buildResolvedSourceGraph mounts request + layout <- + expectRight + (layoutHtmlSourceGraph + [ (sourceMountId configuredId, configuredPrefix) + | (configuredId, configuredPrefix) <- + mountSpecifications + ] + graph) + route <- requireRootRoute graph layout + pure + ( ident + , renderUrlPath (routeUrlPath route) + , safeRelativePathFilePath + (routeDestination route) + , prefix + ) + assertEqual + "mount URLs" + [ ("project", "/entry") + , ("library", "/library/entry") + , ("debug", "/debug/entry") + , ("external", "/external/entry") + ] + [ (ident, url) | (ident, url, _destination, _prefix) <- routes ] + assertEqual + "mount destinations" + [ ("project", "entry.html") + , ("library", "library/entry.html") + , ("debug", "debug/entry.html") + , ("external", "external/entry.html") + ] + [ (ident, destination) + | (ident, _url, destination, _prefix) <- routes + ] + +routesRootFormsIdentically :: Assertion +routesRootFormsIdentically = + withTemporaryDirectory "felix-html-layout-root-forms" \temp -> do + let libraryRoot = temp Posix.</> "library" + entry = libraryRoot Posix.</> "entry.tex" + Directory.createDirectory libraryRoot + writeTheory entry [] + mounts <- expectRight =<< prepareSourceMounts + [ (sourceMountId "project", temp) + , (sourceMountId "library", libraryRoot) + ] + searched <- expectRight (searchedRoot "library/entry.tex") + exact <- expectRight =<< existingRoot entry + searchedGraph <- + expectRight =<< buildResolvedSourceGraph mounts searched + exactGraph <- + expectRight =<< buildResolvedSourceGraph mounts exact + let configuration = + [ (sourceMountId "project", []) + , (sourceMountId "library", ["library"]) + ] + searchedLayout <- + expectRight + (layoutHtmlSourceGraph configuration searchedGraph) + exactLayout <- + expectRight + (layoutHtmlSourceGraph configuration exactGraph) + searchedRoute <- + requireRootRoute searchedGraph searchedLayout + exactRoute <- + requireRootRoute exactGraph exactLayout + assertEqual "selected route" searchedRoute exactRoute + assertEqual + "most-specific URL" + "/library/entry" + (renderUrlPath (routeUrlPath searchedRoute)) + +requiresExternalMount :: Assertion +requiresExternalMount = + withTemporaryDirectory "felix-html-layout-external" \temp -> do + let projectRoot = temp Posix.</> "project" + externalRoot = temp Posix.</> "vendor" + externalEntry = externalRoot Posix.</> "entry.tex" + Directory.createDirectory projectRoot + Directory.createDirectory externalRoot + writeTheory externalEntry [] + request <- expectRight =<< existingRoot externalEntry + projectMounts <- expectRight =<< prepareSourceMounts + [(sourceMountId "project", projectRoot)] + outsideResult <- + buildResolvedSourceGraph projectMounts request + case outsideResult of + Left RootOutsideConfiguredMount{} -> + pure () + result -> + assertFailure + ("expected external root rejection, got " + <> show result) + mounted <- expectRight =<< prepareSourceMounts + [ (sourceMountId "project", projectRoot) + , (sourceMountId "external", externalRoot) + ] + graph <- expectRight =<< buildResolvedSourceGraph mounted request + layout <- + expectRight + (layoutHtmlSourceGraph + [ (sourceMountId "project", []) + , (sourceMountId "external", ["vendor"]) + ] + graph) + route <- requireRootRoute graph layout + assertEqual + "external URL" + "/vendor/entry" + (renderUrlPath (routeUrlPath route)) + +reportsRouteCollisions :: Assertion +reportsRouteCollisions = do + reportsPageCollisions + reportsAssetUrlCollision + +reportsPageCollisions :: Assertion +reportsPageCollisions = + withTemporaryDirectory "felix-html-layout-page-collision" \temp -> do + let firstRoot = temp Posix.</> "first" + secondRoot = temp Posix.</> "second" + firstEntry = firstRoot Posix.</> "two" Posix.</> "a.tex" + Directory.createDirectory firstRoot + Directory.createDirectory secondRoot + Directory.createDirectory (firstRoot Posix.</> "two") + writeTheory (secondRoot Posix.</> "a.tex") [] + writeTheory firstEntry ["a.tex"] + mounts <- expectRight =<< prepareSourceMounts + [ (sourceMountId "first", firstRoot) + , (sourceMountId "second", secondRoot) + ] + request <- expectRight =<< existingRoot firstEntry + graph <- expectRight =<< buildResolvedSourceGraph mounts request + let configuration = + [ (sourceMountId "first", ["one"]) + , (sourceMountId "second", ["one", "two"]) + ] + case layoutHtmlSourceGraph configuration graph of + Left + (CollidingHtmlRoutes + [HtmlUrlRouteCollision url owners] + [HtmlDestinationRouteCollision destination + destinationOwners]) -> do + assertEqual + "canonical URL collision" + "/one/two/a" + (renderUrlPath url) + assertEqual + "URL owners" + (NonEmpty.toList owners) + (NonEmpty.toList destinationOwners) + assertEqual + "destination collision" + "one/two/a.html" + (safeRelativePathFilePath destination) + result -> + assertFailure + ("expected paired route collisions, got " + <> show result) + +reportsAssetUrlCollision :: Assertion +reportsAssetUrlCollision = + withTemporaryDirectory "felix-html-layout-asset-collision" \temp -> do + let entry = + temp + Posix.</> "_static" + Posix.</> "naproche-html.js.tex" + Directory.createDirectory (temp Posix.</> "_static") + writeTheory entry [] + mounts <- expectRight =<< prepareSourceMounts + [(sourceMountId "project", temp)] + request <- + expectRight + (searchedRoot "_static/naproche-html.js.tex") + graph <- expectRight =<< buildResolvedSourceGraph mounts request + case + layoutHtmlSourceGraph + [(sourceMountId "project", [])] + graph of + Left + (CollidingHtmlRoutes + [HtmlUrlRouteCollision url _owners] + []) -> + assertEqual + "page/asset URL collision" + "/_static/naproche-html.js" + (renderUrlPath url) + result -> + assertFailure + ("expected URL-only asset collision, got " + <> show result) + +rejectsNestedDestinations :: Assertion +rejectsNestedDestinations = + withTemporaryDirectory "felix-html-layout-nested" \temp -> do + let nestedDirectory = temp Posix.</> "a.html" + Directory.createDirectory nestedDirectory + writeTheory (temp Posix.</> "a.tex") [] + writeTheory (nestedDirectory Posix.</> "b.tex") [] + writeTheory + (temp Posix.</> "entry.tex") + ["a.tex", "a.html/b.tex"] + mounts <- expectRight =<< prepareSourceMounts + [(sourceMountId "project", temp)] + request <- expectRight (searchedRoot "entry.tex") + graph <- expectRight =<< buildResolvedSourceGraph mounts request + case layoutHtmlSourceGraph + [(sourceMountId "project", [])] + graph of + Left + (CollidingHtmlRoutes + [] + [NestedHtmlDestinationRouteCollision + ancestor + ancestorOwner + descendant + descendantOwner]) -> do + assertEqual + "ancestor destination" + "a.html" + (safeRelativePathFilePath ancestor) + assertEqual + "ancestor owner" + "a.tex" + (pageOwnerPath ancestorOwner) + assertEqual + "descendant destination" + "a.html/b.html" + (safeRelativePathFilePath descendant) + assertEqual + "descendant owner" + "a.html/b.tex" + (pageOwnerPath descendantOwner) + result -> + assertFailure + ("expected nested destination collision, got " + <> show result) + where + pageOwnerPath = \case + HtmlPage source -> + safeRelativePathFilePath + (resolvedSourceRelativePath source) + HtmlSupportScript -> + "<support script>" + +isTraversalOrderIndependent :: Assertion +isTraversalOrderIndependent = + withTemporaryDirectory "felix-html-layout-order" \temp -> do + writeTheory (temp Posix.</> "a.tex") [] + writeTheory (temp Posix.</> "b.tex") [] + let root = temp Posix.</> "entry.tex" + writeTheory root ["a.tex", "b.tex"] + mounts <- expectRight =<< prepareSourceMounts + [(sourceMountId "project", temp)] + request <- expectRight (searchedRoot "entry.tex") + firstGraph <- + expectRight =<< buildResolvedSourceGraph mounts request + writeTheory root ["b.tex", "a.tex"] + secondGraph <- + expectRight =<< buildResolvedSourceGraph mounts request + let firstConfiguration = + [ (sourceMountId "unused", ["unused"]) + , (sourceMountId "project", []) + ] + firstLayout <- + expectRight + (layoutHtmlSourceGraph + firstConfiguration + firstGraph) + for_ + (zip + (cycle [firstGraph, secondGraph]) + (List.permutations firstConfiguration)) + \(orderedGraph, configuration) -> do + layout <- + expectRight + (layoutHtmlSourceGraph + configuration + orderedGraph) + assertEqual + "route table" + firstLayout + layout + + let collidingConfiguration = + [ (sourceMountId "z", ["same"]) + , (sourceMountId "a", ["same"]) + , (sourceMountId "project", []) + ] + expectedCollision = + layoutHtmlSourceGraph + collidingConfiguration + firstGraph + for_ + (zip + (cycle [firstGraph, secondGraph]) + (List.permutations collidingConfiguration)) + \(orderedGraph, configuration) -> + assertEqual + "collision diagnostic" + expectedCollision + (layoutHtmlSourceGraph + configuration + orderedGraph) + + +requireRootRoute + :: ResolvedSourceGraph + -> HtmlLayout + -> IO HtmlRoute +requireRootRoute graph layout = + case htmlPageRoute layout (sourceGraphRootSource graph) of + Just route -> + pure route + Nothing -> do + assertFailure "layout omitted the root source" + pure (impossible "requireRootRoute: assertFailure returned") + +writeTheory :: FilePath -> [FilePath] -> IO () +writeTheory path imports = + writeFile path + (unlines + (["\\import{" <> imported <> "}" | imported <- imports] + <> [ "\\begin{axiom}\\label{route_fixture}" + , " $x = x$." + , "\\end{axiom}" + ])) + +expectRight :: (Show e, HasCallStack) => Either e a -> IO a +expectRight = \case + Left err -> + assertFailure ("expected Right, got Left " <> show err) + Right value -> + pure value + +withTemporaryDirectory :: String -> (FilePath -> IO a) -> IO a +withTemporaryDirectory template = + bracket create Directory.removePathForcibly + where + create = do + systemTemp <- Directory.getTemporaryDirectory + (path, handle) <- openTempFile systemTemp template + hClose handle + Directory.removeFile path + Directory.createDirectory path + pure path |