diff options
Diffstat (limited to 'source/Test/Unit/HtmlLayout.hs')
| -rw-r--r-- | source/Test/Unit/HtmlLayout.hs | 478 |
1 files changed, 0 insertions, 478 deletions
diff --git a/source/Test/Unit/HtmlLayout.hs b/source/Test/Unit/HtmlLayout.hs deleted file mode 100644 index a248f3b..0000000 --- a/source/Test/Unit/HtmlLayout.hs +++ /dev/null @@ -1,478 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.Unit.HtmlLayout (unitTests) where - -import Base -import Felix.Source -import Felix.Source.Graph -import 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 |