diff options
Diffstat (limited to 'source/Test/Unit/OutputPlan.hs')
| -rw-r--r-- | source/Test/Unit/OutputPlan.hs | 236 |
1 files changed, 0 insertions, 236 deletions
diff --git a/source/Test/Unit/OutputPlan.hs b/source/Test/Unit/OutputPlan.hs deleted file mode 100644 index 45658bf..0000000 --- a/source/Test/Unit/OutputPlan.hs +++ /dev/null @@ -1,236 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -module 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 |