Migrate to `Felix` namespaceHEADhotg

1 files changed, 236 insertions, 0 deletions

diff --git a/source/Felix/Test/Unit/OutputPlan.hs b/source/Felix/Test/Unit/OutputPlan.hs
new file mode 100644
index 0000000..803b7da
--- /dev/null
+++ b/source/Felix/Test/Unit/OutputPlan.hs
@@ -0,0 +1,236 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Felix.Test.Unit.OutputPlan (unitTests) where
+
+import Base
+import Felix.OutputPlan qualified as Output
+import Felix.Source
+import Felix.Store qualified as Store
+
+import Control.Exception qualified as Exception
+import System.Directory qualified as Directory
+import System.Environment qualified as Environment
+import System.FilePath.Posix qualified as Posix
+import System.IO.Temp qualified as Temp
+import Test.Tasty
+import Test.Tasty.HUnit
+
+
+unitTests :: TestTree
+unitTests =
+    testGroup "Verification output preflight"
+        [ testCase "accepts absent and empty dump destinations"
+            acceptsAbsentAndEmptyDumpDestinations
+        , testCase "rejects a nonempty dump before store startup"
+            rejectsNonemptyDumpBeforeStoreStartup
+        , testCase "rejects persistent and fresh store collisions"
+            rejectsStoreCollisions
+        , testCase "reserves the store rollback journal"
+            reservesRollbackJournal
+        , testCase "rejects dump and HTML route collisions"
+            rejectsDumpHtmlCollisions
+        ]
+
+acceptsAbsentAndEmptyDumpDestinations :: Assertion
+acceptsAbsentAndEmptyDumpDestinations =
+    Temp.withSystemTempDirectory "felix-output-dump" \root -> do
+        let storeParent = root Posix.</> "store"
+            storeFile = storeParent Posix.</> "store.sqlite"
+            dump = root Posix.</> "dump"
+        Directory.createDirectory storeParent
+        plan <- expectRightIO
+            (Store.planStore
+                (Store.ExplicitStore storeFile))
+        Store.withStoreLease plan \lease -> do
+            absent <- Output.planVerificationOutputs
+                (Store.storeLeasePath lease)
+                (Just dump)
+                Nothing
+            plannedAbsent <- expectOutputRight absent
+            assertEqual "absent dump path"
+                (Just dump)
+                (Output.dumpOutputPath
+                    <$> Output.verificationDumpOutput plannedAbsent)
+
+            Directory.createDirectory dump
+            emptyResult <- Output.planVerificationOutputs
+                (Store.storeLeasePath lease)
+                (Just dump)
+                Nothing
+            void (expectOutputRight emptyResult)
+
+rejectsNonemptyDumpBeforeStoreStartup :: Assertion
+rejectsNonemptyDumpBeforeStoreStartup =
+    Temp.withSystemTempDirectory "felix-output-before-store" \root -> do
+        let cacheRoot = root Posix.</> "cache"
+            dump = root Posix.</> "dump"
+        Directory.createDirectory cacheRoot
+        Directory.createDirectory dump
+        writeFile (dump Posix.</> "old.p") "stale"
+        withEnvironment "XDG_CACHE_HOME" cacheRoot do
+            plan <- expectRightIO
+                (Store.planStore Store.DefaultStore)
+            Store.withStoreLease plan \lease -> do
+                result <- Output.planVerificationOutputs
+                    (Store.storeLeasePath lease)
+                    (Just dump)
+                    Nothing
+                case result of
+                    Left Output.DumpDestinationNotEmpty{} ->
+                        pure ()
+                    Left other ->
+                        assertFailure
+                            ("unexpected nonempty result: " <> show other)
+                    Right _ ->
+                        assertFailure "nonempty dump was accepted"
+                assertBool "preflight did not create the default store"
+                    . not
+                    =<< Directory.doesPathExist
+                        (cacheRoot Posix.</> "felix")
+
+rejectsStoreCollisions :: Assertion
+rejectsStoreCollisions =
+    Temp.withSystemTempDirectory "felix-output-store-collision" \root -> do
+        let dump = root Posix.</> "dump"
+            persistentStore = dump Posix.</> "store.sqlite"
+        Directory.createDirectory dump
+        persistentPlan <- expectRightIO
+            (Store.planStore
+                (Store.ExplicitStore persistentStore))
+        Store.withStoreLease persistentPlan \lease -> do
+            result <- Output.planVerificationOutputs
+                (Store.storeLeasePath lease)
+                (Just dump)
+                Nothing
+            expectCollision result
+
+        freshPlan <- expectRightIO
+            (Store.planStore Store.FreshTemporaryStore)
+        Store.withStoreLease freshPlan \lease -> do
+            let freshParent =
+                    Posix.takeDirectory
+                        (Store.storePathFilePath
+                            (Store.storeLeasePath lease))
+            result <- Output.planVerificationOutputs
+                (Store.storeLeasePath lease)
+                (Just freshParent)
+                Nothing
+            expectCollision result
+
+        relative <- expectRight (safeRelativePath "page.html")
+        let htmlRoot = root Posix.</> "html"
+            htmlStore = htmlRoot Posix.</> "page.html"
+        Directory.createDirectory htmlRoot
+        htmlPlan <- expectRightIO
+            (Store.planStore
+                (Store.ExplicitStore htmlStore))
+        Store.withStoreLease htmlPlan \lease -> do
+            result <- Output.planVerificationOutputs
+                (Store.storeLeasePath lease)
+                Nothing
+                (Just (htmlRoot, [relative]))
+            expectCollision result
+
+rejectsDumpHtmlCollisions :: Assertion
+rejectsDumpHtmlCollisions =
+    Temp.withSystemTempDirectory "felix-output-cross-collision" \root -> do
+        let storeParent = root Posix.</> "store"
+            storeFile = storeParent Posix.</> "store.sqlite"
+            htmlRoot = root Posix.</> "html"
+        Directory.createDirectory storeParent
+        Directory.createDirectory htmlRoot
+        relative <- expectRight (safeRelativePath "nested/page.html")
+        plan <- expectRightIO
+            (Store.planStore
+                (Store.ExplicitStore storeFile))
+        Store.withStoreLease plan \lease -> do
+            result <- Output.planVerificationOutputs
+                (Store.storeLeasePath lease)
+                (Just htmlRoot)
+                (Just (htmlRoot, [relative]))
+            expectCollision result
+
+reservesRollbackJournal :: Assertion
+reservesRollbackJournal =
+    Temp.withSystemTempDirectory "felix-output-journal" \root -> do
+        let storeParent = root Posix.</> "store"
+            storeFile = storeParent Posix.</> "store.sqlite"
+            journal = storeFile <> "-journal"
+        Directory.createDirectory storeParent
+        plan <- expectRightIO
+            (Store.planStore
+                (Store.ExplicitStore storeFile))
+        Store.withStoreLease plan \lease -> do
+            result <- Output.planVerificationOutputs
+                (Store.storeLeasePath lease)
+                (Just journal)
+                Nothing
+            case result of
+                Left
+                    (Output.CollidingOutputNamespaces
+                        (Output.OutputNamespaceCollision
+                            Output.StoreJournalOutputNamespace
+                            reserved
+                            Output.DumpOutputNamespace
+                            requested :| [])) -> do
+                                assertEqual "reserved journal" journal reserved
+                                assertEqual "requested dump" journal requested
+                Left other ->
+                    assertFailure
+                        ("unexpected journal collision: " <> show other)
+                Right _ ->
+                    assertFailure "store rollback journal was not reserved"
+
+expectCollision
+    :: Either Output.OutputPlanError Output.VerificationOutputPlan
+    -> Assertion
+expectCollision = \case
+    Left Output.CollidingOutputNamespaces{} ->
+        pure ()
+    Left other ->
+        assertFailure
+            ("unexpected output-plan result: " <> show other)
+    Right _ ->
+        assertFailure "colliding output namespaces were accepted"
+
+expectOutputRight
+    :: Either Output.OutputPlanError Output.VerificationOutputPlan
+    -> IO Output.VerificationOutputPlan
+expectOutputRight = \case
+    Left failure ->
+        assertFailure (show failure) >> fail "unreachable"
+    Right plan ->
+        pure plan
+
+expectRight :: Show failure => Either failure value -> IO value
+expectRight = \case
+    Left failure ->
+        assertFailure (show failure) >> fail "unreachable"
+    Right value ->
+        pure value
+
+expectRightIO
+    :: Show failure
+    => IO (Either failure value)
+    -> IO value
+expectRightIO action =
+    expectRight =<< action
+
+withEnvironment
+    :: String
+    -> String
+    -> IO value
+    -> IO value
+withEnvironment name value action =
+    Exception.bracket
+        (Environment.lookupEnv name)
+        restore
+        \_previous -> do
+            Environment.setEnv name value
+            action
+  where
+    restore = \case
+        Nothing ->
+            Environment.unsetEnv name
+        Just previous ->
+            Environment.setEnv name previous