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

{-# LANGUAGE OverloadedStrings #-}

module Test.Unit.HtmlOutput (unitTests) where

import Base
import Felix.Source (RelativePathError(..))
import Render.Html.Output

import Control.Exception (bracket)
import Data.ByteString qualified as ByteString
import Data.Text.Encoding qualified as Text
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
            "rejects non-child input routes before creating output"
            rejectsNonChildRoutes
        , testCase
            "writes the page and support asset as confined bytes"
            writesConfinedUtf8Output
        , testCase
            "rejects a parent symlink escaping the output root"
            rejectsEscapingParentSymlink
        , testCase
            "rejects a final symlink before changing either output"
            rejectsFinalSymlinkWithoutPartialWrite
        , testCase
            "replaces hard-linked targets without changing their peers"
            replacesHardLinkedTarget
        , testCase
            "rejects a FIFO before changing either output"
            rejectsFifoWithoutPartialWrite
        ]


rejectsNonChildRoutes :: Assertion
rejectsNonChildRoutes =
    withTemporaryDirectory "felix-html-output-route" \temp -> do
        let outputRoot = temp </> "html"
            cases =
                [ ("/absolute.tex", AbsoluteRelativePath)
                , ("../escape.tex", ParentDirectoryComponent)
                , ("nested/../escape.tex", ParentDirectoryComponent)
                , ("./entry.tex", CurrentDirectoryComponent)
                ]
        for_ cases \(input, expectedError) -> do
            result <- planHtmlOutput outputRoot input
            case result of
                Left (InvalidHtmlInputRoute actualInput actualError) -> do
                    assertEqual "input spelling" input actualInput
                    assertEqual "route error" expectedError actualError
                Left err ->
                    assertFailure
                        ("unexpected HTML output error: " <> show err)
                Right _plan ->
                    assertFailure
                        ("accepted unsafe HTML input route: " <> input)
        outputExists <- Directory.doesPathExist outputRoot
        assertBool "planning created the output root" (not outputExists)

writesConfinedUtf8Output :: Assertion
writesConfinedUtf8Output =
    withTemporaryDirectory "felix-html-output-utf8" \temp -> do
        let outputRoot = temp </> "html"
            input = "nested/über.tex"
            pageText = "∀ café"
            supportText = "const π = 3;"
            expectedPageBytes =
                ByteString.pack
                    [ 0xe2, 0x88, 0x80
                    , 0x20
                    , 0x63, 0x61, 0x66
                    , 0xc3, 0xa9
                    ]
        plan <- requirePlan =<< planHtmlOutput outputRoot input
        writeHtmlOutput
            plan
            (preparedHtmlOutput
                (Text.encodeUtf8 pageText)
                (Text.encodeUtf8 supportText))
        pageBytes <-
            ByteString.readFile (outputRoot </> "nested" </> "über.html")
        supportBytes <-
            ByteString.readFile
                (outputRoot </> "_static" </> "naproche-html.js")
        assertEqual "exact page UTF-8 bytes" expectedPageBytes pageBytes
        assertEqual
            "support asset bytes"
            (Text.encodeUtf8 supportText)
            supportBytes

rejectsEscapingParentSymlink :: Assertion
rejectsEscapingParentSymlink =
    withTemporaryDirectory "felix-html-output-parent-link" \temp -> do
        let outputRoot = temp </> "html"
            outsideRoot = temp </> "outside"
            outsidePage = outsideRoot </> "page.html"
            supportAsset =
                outputRoot </> "_static" </> "naproche-html.js"
        Directory.createDirectory outputRoot
        Directory.createDirectory outsideRoot
        ByteString.writeFile outsidePage "outside page"
        Directory.createDirectoryLink
            outsideRoot
            (outputRoot </> "nested")

        result <- planHtmlOutput outputRoot "nested/page.tex"
        case result of
            Left (HtmlOutputParentEscapesRoot _parent canonicalParent) -> do
                expectedOutside <- Directory.canonicalizePath outsideRoot
                assertEqual
                    "escaping parent target"
                    expectedOutside
                    canonicalParent
            Left err ->
                assertFailure
                    ("unexpected HTML output error: " <> show err)
            Right _plan ->
                assertFailure "accepted an escaping output parent symlink"

        outsideBytes <- ByteString.readFile outsidePage
        supportExists <- Directory.doesPathExist supportAsset
        assertEqual "outside page was changed" "outside page" outsideBytes
        assertBool "support asset was written after rejection" (not supportExists)

rejectsFinalSymlinkWithoutPartialWrite :: Assertion
rejectsFinalSymlinkWithoutPartialWrite =
    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

        result <- planHtmlOutput outputRoot "page.tex"
        case result of
            Left (HtmlOutputTargetIsSymbolicLink target) ->
                assertEqual "rejected target" support target
            Left err ->
                assertFailure
                    ("unexpected HTML output error: " <> show err)
            Right _plan ->
                assertFailure "accepted a final output symlink"

        pageBytes <- ByteString.readFile page
        outsideBytes <- ByteString.readFile outsideAsset
        supportIsLink <- Directory.pathIsSymbolicLink support
        assertEqual "page changed before complete preflight" "old page" pageBytes
        assertEqual "symlink referent was 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"
            support =
                outputRoot </> "_static" </> "naproche-html.js"
            outsidePage = temp </> "outside.html"
        Directory.createDirectory outputRoot
        ByteString.writeFile outsidePage "outside page"
        PosixFiles.createLink outsidePage page
        plan <- requirePlan =<< planHtmlOutput outputRoot "page.tex"
        writeHtmlOutput
            plan
            (preparedHtmlOutput "new page" "new support")
        outsideBytes <- ByteString.readFile outsidePage
        pageBytes <- ByteString.readFile page
        supportBytes <- ByteString.readFile support
        assertEqual "outside hard-link peer changed"
            "outside page"
            outsideBytes
        assertEqual "page was not replaced" "new page" pageBytes
        assertEqual "support asset was not written" "new support" supportBytes

rejectsFifoWithoutPartialWrite :: Assertion
rejectsFifoWithoutPartialWrite =
    withTemporaryDirectory "felix-html-output-fifo" \temp -> do
        let outputRoot = temp </> "html"
            supportDirectory = outputRoot </> "_static"
            page = outputRoot </> "page.html"
            support = supportDirectory </> "naproche-html.js"
        Directory.createDirectory outputRoot
        Directory.createDirectory supportDirectory
        PosixFiles.createNamedPipe support PosixFiles.ownerModes

        result <- planHtmlOutput outputRoot "page.tex"
        case result of
            Left (HtmlOutputTargetNotRegularFile target) ->
                assertEqual "rejected target" support target
            Left err ->
                assertFailure
                    ("unexpected HTML output error: " <> show err)
            Right _plan ->
                assertFailure "accepted a FIFO output target"

        pageExists <- Directory.doesPathExist page
        supportStatus <- PosixFiles.getSymbolicLinkStatus support
        assertBool "page changed before complete preflight" (not pageExists)
        assertBool "FIFO target was replaced"
            (PosixFiles.isNamedPipe supportStatus)


requirePlan
    :: Either HtmlOutputError HtmlOutputPlan
    -> IO HtmlOutputPlan
requirePlan = \case
    Right plan ->
        pure plan
    Left err -> do
        assertFailure ("HTML output planning failed: " <> show err)
        pure (impossible "requirePlan: assertFailure returned")

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