diff options
Diffstat (limited to 'source/Felix/Test/Unit/HtmlOutput.hs')
| -rw-r--r-- | source/Felix/Test/Unit/HtmlOutput.hs | 560 |
1 files changed, 560 insertions, 0 deletions
diff --git a/source/Felix/Test/Unit/HtmlOutput.hs b/source/Felix/Test/Unit/HtmlOutput.hs new file mode 100644 index 0000000..34fe2e7 --- /dev/null +++ b/source/Felix/Test/Unit/HtmlOutput.hs @@ -0,0 +1,560 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Felix.Test.Unit.HtmlOutput (unitTests) where + +import Base +import Felix.Parse qualified as Parse +import Felix.Source +import Felix.Source.Graph qualified as SourceGraph +import Felix.Render.Html qualified as Html +import Felix.Render.Html.Export +import Felix.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 |