diff options
Diffstat (limited to 'source/Felix/Test/Unit/OutputPlan.hs')
| -rw-r--r-- | source/Felix/Test/Unit/OutputPlan.hs | 236 |
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 |