path: root/source/Test/Unit/HtmlOutput.hs

{-# 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