diff options
Diffstat (limited to 'source/Test/Unit/HtmlOutput.hs')
| -rw-r--r-- | source/Test/Unit/HtmlOutput.hs | 560 |
1 files changed, 0 insertions, 560 deletions
diff --git a/source/Test/Unit/HtmlOutput.hs b/source/Test/Unit/HtmlOutput.hs deleted file mode 100644 index 0087f82..0000000 --- a/source/Test/Unit/HtmlOutput.hs +++ /dev/null @@ -1,560 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} - -module Test.Unit.HtmlOutput (unitTests) where - -import Base -import Felix.Parse qualified as Parse -import Felix.Source -import Felix.Source.Graph qualified as SourceGraph -import Render.Html qualified as Html -import Render.Html.Export -import Render.Html.Output - -import Control.Exception (bracket) -import Data.ByteString qualified as ByteString -import Data.List qualified as List -import Data.Text qualified as Text -import Data.Text.Encoding qualified as TextEncoding -import System.Directory qualified as Directory -import System.FilePath.Posix ((</>)) -import System.Posix.Files qualified as PosixFiles -import Test.Tasty -import Test.Tasty.HUnit - - -unitTests :: TestTree -unitTests = - testGroup "HTML output" - [ testCase - "publishes a mounted multi-page UTF-8 export" - publishesMountedExport - , testCase - "writes prepared strict bytes" - writesPreparedBytes - , testCase - "attaches bytes only to reserved routes" - attachesBytesToReservedRoutes - , testCase - "rejects a final symlink before publication" - rejectsFinalSymlink - , testCase - "replaces hard-linked targets without changing peers" - replacesHardLinkedTarget - , testCase - "rejects a FIFO before publication" - rejectsFifo - , testCase - "reports and cleans the source-order publication prefix" - reportsIncompletePublication - ] - - -publishesMountedExport :: Assertion -publishesMountedExport = - withTemporaryDirectory "felix-html-export" \temp -> do - let projectRoot = temp </> "project" - libraryRoot = temp </> "library" - projectDirectory = projectRoot </> "docs" - libraryDirectory = libraryRoot </> "shared" - rootSource = projectDirectory </> "über #.tex" - importedSource = - libraryDirectory </> "sets #.tex" - outputRoot = temp </> "html" - rootPage = outputRoot </> "docs" </> "über #.html" - importedPage = - outputRoot - </> "library" - </> "shared" - </> "sets #.html" - supportAsset = - outputRoot - </> "_static" - </> "naproche-html.js" - configuration = - [ (sourceMountId "project", []) - , (sourceMountId "library", ["library"]) - ] - hints = - "relation\teq\t0\t<mo>=</mo>\n" - Directory.createDirectory projectRoot - Directory.createDirectory libraryRoot - Directory.createDirectory projectDirectory - Directory.createDirectory libraryDirectory - writeImportedTheory importedSource - writeRootTheory rootSource - mounts <- - expectRight =<< - prepareSourceMounts - [ (sourceMountId "project", projectRoot) - , (sourceMountId "library", libraryRoot) - ] - searched <- - expectRight - (searchedRoot "docs/über #.tex") - exact <- - expectRight =<< existingRoot rootSource - searchedExport <- - expectRight =<< - prepareTestHtmlExport - configuration - mounts - searched - hints - exactExport <- - expectRight =<< - prepareTestHtmlExport - configuration - mounts - exact - hints - assertEqual - "root-form-independent destinations" - (preparedHtmlArtifactDestination <$> searchedExport) - (preparedHtmlArtifactDestination <$> exactExport) - - let artifacts = searchedExport - rejectsArtifactEscape temp artifacts - - plan <- - requirePlan =<< - planHtmlOutput outputRoot artifacts - outputExistsBeforePublication <- - Directory.doesPathExist outputRoot - assertBool - "preflight created the output root" - (not outputExistsBeforePublication) - requirePublication =<< writeHtmlOutput plan - - rootText <- readUtf8 rootPage - importedText <- readUtf8 importedPage - supportText <- readUtf8 supportAsset - assertContains - "root heading" - "<h1>project:docs/über #.tex</h1>" - rootText - assertContains - "imported heading" - "<h1>library:shared/sets #.tex</h1>" - importedText - assertContains - "encoded imported reference" - "href=\"../library/shared/sets%20%23#imported_prop\"" - rootText - assertContains - "encoded imported source link" - "href=\"../library/shared/sets%20%23\"><code>library:shared/sets #.tex</code>" - rootText - assertContains - "root support route" - "src=\"../_static/naproche-html.js\"" - rootText - assertContains - "imported support route" - "src=\"../../_static/naproche-html.js\"" - importedText - for_ [rootText, importedText] \document -> - assertContains - "UTF-8 declaration" - "<meta charset=\"utf-8\">" - document - assertEqual - "support asset" - Html.supportScriptAssetContents - supportText - -rejectsArtifactEscape - :: FilePath - -> [PreparedHtmlArtifact] - -> Assertion -rejectsArtifactEscape temp artifacts = do - let outputRoot = temp </> "escape-html" - outsideRoot = temp </> "outside" - outsideMarker = outsideRoot </> "unchanged" - Directory.createDirectory outputRoot - Directory.createDirectory outsideRoot - ByteString.writeFile outsideMarker "outside" - Directory.createDirectoryLink - outsideRoot - (outputRoot </> "docs") - result <- planHtmlOutput outputRoot artifacts - case result of - Left - (HtmlOutputParentEscapesRoot - _parent - canonicalParent) -> do - expectedOutside <- - Directory.canonicalizePath outsideRoot - assertEqual - "escaping route target" - expectedOutside - canonicalParent - other -> - assertFailure - ("expected output-root escape rejection, got " - <> showPlanResult other) - outsideBytes <- ByteString.readFile outsideMarker - assertEqual - "escape planning changed the outside tree" - "outside" - outsideBytes - supportExists <- - Directory.doesPathExist - (outputRoot </> "_static") - assertBool - "escape preflight created another destination" - (not supportExists) - -writesPreparedBytes :: Assertion -writesPreparedBytes = - withTemporaryDirectory "felix-html-output-bytes" \temp -> do - let outputRoot = temp </> "html" - pageText = "∀ café" - supportText = "const π = 3;" - expectedPageBytes = - ByteString.pack - [ 0xe2, 0x88, 0x80 - , 0x20 - , 0x63, 0x61, 0x66 - , 0xc3, 0xa9 - ] - artifacts <- - makeArtifacts - [ ( "nested/über.html" - , TextEncoding.encodeUtf8 pageText - ) - , ( "_static/naproche-html.js" - , TextEncoding.encodeUtf8 supportText - ) - ] - publishArtifacts outputRoot artifacts - pageBytes <- - ByteString.readFile - (outputRoot </> "nested" </> "über.html") - supportBytes <- - ByteString.readFile - (outputRoot - </> "_static" - </> "naproche-html.js") - assertEqual - "exact page UTF-8 bytes" - expectedPageBytes - pageBytes - assertEqual - "exact support bytes" - (TextEncoding.encodeUtf8 supportText) - supportBytes - -attachesBytesToReservedRoutes :: Assertion -attachesBytesToReservedRoutes = - withTemporaryDirectory "felix-html-output-routes" \temp -> do - let outputRoot = temp </> "html" - reserved <- expectRight - (traverse safeRelativePath - ["page.html", "_static/naproche-html.js"]) - routes <- requireRoutePlan =<< - planHtmlRoutes outputRoot reserved - matching <- makeArtifacts - [ ("page.html", "page") - , ("_static/naproche-html.js", "support") - ] - case planHtmlOutputAgainst routes matching of - Right _ -> - pure () - Left failure -> - assertFailure (show failure) - mismatched <- makeArtifacts - [ ("other.html", "other") - , ("_static/naproche-html.js", "support") - ] - case planHtmlOutputAgainst routes mismatched of - Left HtmlOutputRouteMismatch{} -> - pure () - Left failure -> - assertFailure - ("unexpected route mismatch: " <> show failure) - Right _ -> - assertFailure "unreserved HTML route was accepted" - -rejectsFinalSymlink :: Assertion -rejectsFinalSymlink = - withTemporaryDirectory "felix-html-output-final-link" \temp -> do - let outputRoot = temp </> "html" - supportDirectory = outputRoot </> "_static" - page = outputRoot </> "page.html" - support = - supportDirectory </> "naproche-html.js" - outsideAsset = temp </> "outside.js" - Directory.createDirectory outputRoot - Directory.createDirectory supportDirectory - ByteString.writeFile page "old page" - ByteString.writeFile outsideAsset "outside asset" - Directory.createFileLink outsideAsset support - artifacts <- - makeArtifacts - [ ("page.html", "new page") - , ("_static/naproche-html.js", "new support") - ] - result <- planHtmlOutput outputRoot artifacts - case result of - Left (HtmlOutputTargetIsSymbolicLink target) -> - assertEqual "rejected target" support target - other -> - assertFailure - ("expected final symlink rejection, got " - <> showPlanResult other) - pageBytes <- ByteString.readFile page - outsideBytes <- ByteString.readFile outsideAsset - supportIsLink <- - Directory.pathIsSymbolicLink support - assertEqual - "page changed before complete preflight" - "old page" - pageBytes - assertEqual - "symlink referent changed" - "outside asset" - outsideBytes - assertBool "final symlink was replaced" supportIsLink - -replacesHardLinkedTarget :: Assertion -replacesHardLinkedTarget = - withTemporaryDirectory "felix-html-output-hard-link" \temp -> do - let outputRoot = temp </> "html" - page = outputRoot </> "page.html" - outsidePage = temp </> "outside.html" - Directory.createDirectory outputRoot - ByteString.writeFile outsidePage "outside page" - PosixFiles.createLink outsidePage page - artifacts <- - makeArtifacts [("page.html", "new page")] - publishArtifacts outputRoot artifacts - outsideBytes <- ByteString.readFile outsidePage - pageBytes <- ByteString.readFile page - assertEqual - "outside hard-link peer changed" - "outside page" - outsideBytes - assertEqual "page was not replaced" "new page" pageBytes - -rejectsFifo :: Assertion -rejectsFifo = - withTemporaryDirectory "felix-html-output-fifo" \temp -> do - let outputRoot = temp </> "html" - page = outputRoot </> "page.html" - Directory.createDirectory outputRoot - PosixFiles.createNamedPipe page PosixFiles.ownerModes - artifacts <- - makeArtifacts [("page.html", "page")] - result <- planHtmlOutput outputRoot artifacts - case result of - Left (HtmlOutputTargetNotRegularFile target) -> - assertEqual "rejected target" page target - other -> - assertFailure - ("expected FIFO rejection, got " - <> showPlanResult other) - pageStatus <- - PosixFiles.getSymbolicLinkStatus page - assertBool - "FIFO target was replaced" - (PosixFiles.isNamedPipe pageStatus) - -reportsIncompletePublication :: Assertion -reportsIncompletePublication = - withTemporaryDirectory "felix-html-output-incomplete" \temp -> do - let outputRoot = temp </> "html" - first = outputRoot </> "z.html" - blocked = outputRoot </> "b.html" - unpublished = outputRoot </> "a.html" - artifacts <- - makeArtifacts - [ ("z.html", "first") - , ("b.html", "blocked") - , ("a.html", "unpublished") - ] - plan <- - requirePlan =<< - planHtmlOutput outputRoot artifacts - Directory.createDirectory outputRoot - Directory.createDirectory blocked - result <- writeHtmlOutput plan - case result of - Left - IncompleteHtmlPublication - { committedHtmlDestinations - , failedHtmlDestination - } -> do - expectedFirst <- - expectRight - (safeRelativePath "z.html") - expectedBlocked <- - expectRight - (safeRelativePath "b.html") - assertEqual - "committed destinations" - [expectedFirst] - committedHtmlDestinations - assertEqual - "failed destination" - expectedBlocked - failedHtmlDestination - Right () -> - assertFailure - "expected incomplete publication" - firstBytes <- ByteString.readFile first - unpublishedExists <- - Directory.doesPathExist unpublished - blockedIsDirectory <- - Directory.doesDirectoryExist blocked - outputEntries <- - Directory.listDirectory outputRoot - assertEqual "first artifact" "first" firstBytes - assertBool - "later artifact was published" - (not unpublishedExists) - assertBool - "injected blocker was replaced" - blockedIsDirectory - assertBool - "unpublished temporary files remain" - (not - (any - (List.isInfixOf ".tmp") - outputEntries)) - - -publishArtifacts - :: FilePath - -> [PreparedHtmlArtifact] - -> IO () -publishArtifacts outputRoot artifacts = do - plan <- - requirePlan =<< planHtmlOutput outputRoot artifacts - requirePublication =<< writeHtmlOutput plan - -makeArtifacts - :: [(FilePath, ByteString.ByteString)] - -> IO [PreparedHtmlArtifact] -makeArtifacts artifacts = - for artifacts \(path, bytes) -> do - relative <- expectRight (safeRelativePath path) - pure (preparedHtmlArtifact relative (Right bytes)) - -requirePlan - :: Either HtmlOutputError HtmlOutputPlan - -> IO HtmlOutputPlan -requirePlan = - expectRight - -requireRoutePlan - :: Either HtmlOutputError HtmlRoutePlan - -> IO HtmlRoutePlan -requireRoutePlan = - expectRight - -requirePublication - :: Either HtmlPublicationError () - -> IO () -requirePublication = - expectRight - -showPlanResult - :: Either HtmlOutputError HtmlOutputPlan - -> String -showPlanResult = \case - Left err -> - show err - Right _plan -> - "successful output plan" - -readUtf8 :: FilePath -> IO Text -readUtf8 path = do - bytes <- ByteString.readFile path - case TextEncoding.decodeUtf8' bytes of - Left err -> - assertFailure - ("invalid UTF-8 output: " <> show err) - Right text -> - pure text - -prepareTestHtmlExport - :: [(SourceMountId, [Text])] - -> SourceMounts - -> RootRequest - -> Text - -> IO (Either HtmlExportError [PreparedHtmlArtifact]) -prepareTestHtmlExport configuration mounts request hints = do - graph <- - expectRight =<< - SourceGraph.buildResolvedSourceGraph mounts request - workspace <- - expectRight =<< Parse.parseResolvedSourceGraph graph - pure - (prepareHtmlExport - configuration - (htmlPresentationFromParsedWorkspace workspace) - hints) - -writeImportedTheory :: FilePath -> IO () -writeImportedTheory path = - writeFile path - (unlines - [ "\\begin{proposition}\\label{imported_prop}" - , " $i = i$." - , "\\end{proposition}" - ]) - -writeRootTheory :: FilePath -> IO () -writeRootTheory path = - writeFile path - (unlines - [ "\\import{shared/sets #.tex}" - , "\\begin{proposition}\\label{local_prop}" - , " $a = a$." - , "\\end{proposition}" - , "\\begin{proposition}\\label{uses_import}" - , " $b = b$." - , "\\end{proposition}" - , "\\begin{proof}" - , " Follows by \\cref{imported_prop}." - , "\\end{proof}" - ]) - -assertContains - :: String - -> Text - -> Text - -> Assertion -assertContains description needle haystack = - assertBool - (description <> ": missing " <> show needle) - (needle `Text.isInfixOf` haystack) - -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 |