diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,6 +1,34 @@ Dojang changelog ================ +Version 0.2.1 +------------- + +Released on July 12, 2026. + + - Fixed a bug where `dojang reflect` crashed after deleting the intermediate + copy when a managed file had been removed at its destination. + Destination-side deletions are now reflected to the source and can also be + selected by naming the deleted destination path explicitly. [[#24]] + + - Fixed hook commands discarding the parent process environment. Hooks now + inherit variables such as `PATH` and `HOME`, while the `DOJANG_*` variables + supplied by Dojang override any existing values. This allows hook commands + and programs invoked by hook scripts to be found through `PATH` as + documented. [[#25]] + + - Fixed `writeManifest` silently dropping file route predicates that could + not be represented by a moniker or that collided after moniker resolution. + It now returns a `WriteError`, and `writeManifestFile` raises an I/O error, + instead of writing an incomplete manifest. When multiple monikers + represent the same predicate, the writer now selects the first name in a + deterministic order. [[#26]] + +[#24]: https://github.com/dahlia/dojang/issues/24 +[#25]: https://github.com/dahlia/dojang/issues/25 +[#26]: https://github.com/dahlia/dojang/issues/26 + + Version 0.2.0 ------------- diff --git a/dojang.cabal b/dojang.cabal --- a/dojang.cabal +++ b/dojang.cabal @@ -1,11 +1,11 @@ cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.39.1. +-- This file has been generated from package.yaml by hpack version 0.39.6. -- -- see: https://github.com/sol/hpack name: dojang -version: 0.2.0 +version: 0.2.1 synopsis: A cross-platform dotfiles manager description: See also the README.md file. category: Configuration @@ -147,6 +147,7 @@ Dojang.Commands.DisambiguationSpec Dojang.Commands.EditSpec Dojang.Commands.HookSpec + Dojang.Commands.ReflectSpec Dojang.Gen Dojang.MonadFileSystemSpec Dojang.Syntax.EnvironmentPredicate.ParserSpec diff --git a/src/Dojang/Commands/Hook.hs b/src/Dojang/Commands/Hook.hs --- a/src/Dojang/Commands/Hook.hs +++ b/src/Dojang/Commands/Hook.hs @@ -6,16 +6,20 @@ module Dojang.Commands.Hook ( HookEnv (..) , executeHooks + , mergeHookEnvironment , shouldRunHook ) where import Control.Monad (forM_, unless) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Reader (asks) +import System.Environment (getEnvironment) import System.Exit (ExitCode (..)) +import System.Info (os) import Prelude hiding (readFile) import Control.Monad.Logger (logDebug, logError, logInfo) +import Data.CaseInsensitive (mk) import Data.Map.Strict (lookup) import Data.Text (Text, pack, unpack) import System.Directory.OsPath (makeAbsolute) @@ -66,6 +70,27 @@ in result +-- | Overlay the variables supplied by Dojang on the parent environment. +mergeHookEnvironment + :: String + -- ^ The host platform identifier from 'System.Info.os'. + -> [(String, String)] + -- ^ The variables supplied by Dojang. + -> [(String, String)] + -- ^ The parent process environment. + -> [(String, String)] + -- ^ The combined hook environment. +mergeHookEnvironment platform envVars parentEnv = + envVars + ++ filter + (\(name, _) -> all (not . sameName name . fst) envVars) + parentEnv + where + sameName left right + | platform == "mingw32" = mk left == mk right + | otherwise = left == right + + -- | Execute all hooks of a given type. executeHooks :: (MonadFileSystem i, MonadIO i) @@ -135,11 +160,12 @@ , ("DOJANG_OS", unpack hookEnv.currentOS) , ("DOJANG_ARCH", unpack hookEnv.currentArch) ] + parentEnv <- liftIO getEnvironment let createProc = (proc cmdPath argsStr) { cwd = workDir - , env = Just envVars + , env = Just $ mergeHookEnvironment os envVars parentEnv , delegate_ctlc = True } diff --git a/src/Dojang/Commands/Init.hs b/src/Dojang/Commands/Init.hs --- a/src/Dojang/Commands/Init.hs +++ b/src/Dojang/Commands/Init.hs @@ -13,6 +13,7 @@ ) where import Control.Monad (forM_, when) +import Control.Monad.Except (MonadError (throwError)) import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.Function ((&)) import Data.List (maximumBy, sortOn) @@ -357,7 +358,9 @@ debug' <- asks (.debug) dryRun' <- asks (.dryRun) when (debug' || dryRun') $ do - let manifestText = indent $ writeManifest manifest + manifestText <- case writeManifest manifest of + Left err -> throwError $ userError $ show err + Right toml -> pure $ indent toml printStderr' Note $ "The manifest file looks like below:\n\n" <> manifestText diff --git a/src/Dojang/Commands/Reflect.hs b/src/Dojang/Commands/Reflect.hs --- a/src/Dojang/Commands/Reflect.hs +++ b/src/Dojang/Commands/Reflect.hs @@ -244,13 +244,17 @@ liftIO $ exitWith userCancelledError reflect force allFlag _includeUnregistered explicitSource paths = do ctx <- ensureContext - nonExistents <- filterM (fmap not . exists) paths pathStyle <- pathStyleFor stderr - unless (null nonExistents) $ do - dieWithErrors - fileNotFoundError - ["No such file: " <> pathStyle p <> "." | p <- nonExistents] absPaths <- liftIO $ mapM makeAbsolute paths + nonExistents <- filterM (fmap not . exists) absPaths + let rejectUntrackedMissingPath path (correspond :: FileCorrespondence) = + when + ( path `elem` nonExistents + && correspond.intermediate.stat == Missing + ) + $ die' + fileNotFoundError + ("No such file: " <> pathStyle path <> ".") $(logDebugSH) (absPaths :: [OsPath]) sourcePath' <- liftIO $ makeAbsolute ctx.repository.sourcePath let sourcePathPrefix = splitDirectories sourcePath' @@ -287,15 +291,21 @@ (state, ws) <- getRouteState ctx absPath case state of NotRouted -> do - manifestFile' <- asks (.manifestFile) - printWarnings ws - printStderr' - Error - ("File " <> pathStyle absPath <> " is not routed.") - printStderr' - Hint - ("Add a route for it in " <> pathStyle manifestFile' <> ".") - liftIO $ exitWith fileNotRoutedError + if absPath `elem` nonExistents + then + die' + fileNotFoundError + ("No such file: " <> pathStyle absPath <> ".") + else do + manifestFile' <- asks (.manifestFile) + printWarnings ws + printStderr' + Error + ("File " <> pathStyle absPath <> " is not routed.") + printStderr' + Hint + ("Add a route for it in " <> pathStyle manifestFile' <> ".") + liftIO $ exitWith fileNotRoutedError Routed _ -> do return ws Ignored name pattern -> do @@ -342,6 +352,7 @@ die' fileNotRoutedError ("File " <> pathStyle p <> " is not routed.") SingleMatch route -> do correspond <- makeCorrespondForRoute ctx p route + rejectUntrackedMissingPath p correspond return correspond AmbiguousMatch candidates -> do maybeRoute <- disambiguateRoutes autoSelectMode explicitSource candidates @@ -367,6 +378,7 @@ liftIO $ exitWith ambiguousRouteError Just route -> do correspond <- makeCorrespondForRoute ctx p route + rejectUntrackedMissingPath p correspond return correspond -- Combine directory files and individual file correspondences let allCorrespondences = dirFiles ++ fileCorrespondences @@ -477,10 +489,15 @@ <> " to " <> pathStyle c.source.path <> "..." - cleanup c.intermediate - copy c.destination c.intermediate - cleanup c.source - copy c.intermediate c.source + if c.destinationDelta == Removed + then do + cleanupExisting c.source + cleanupExisting c.intermediate + else do + cleanup c.intermediate + copy c.destination c.intermediate + cleanup c.source + copy c.intermediate c.source -- | Create a 'FileCorrespondence' from a route result and destination path. @@ -526,6 +543,12 @@ _ -> do $(logDebug) $ "Remove file: " <> pack path removeFile fileEntry.path + + +cleanupExisting :: (MonadFileSystem i, MonadIO i) => FileEntry -> App i () +cleanupExisting fileEntry = do + pathExists <- (||) <$> exists fileEntry.path <*> isSymlink fileEntry.path + when pathExists $ cleanup fileEntry copy :: (MonadFileSystem i, MonadIO i) => FileEntry -> FileEntry -> App i () diff --git a/src/Dojang/Syntax/Manifest/Writer.hs b/src/Dojang/Syntax/Manifest/Writer.hs --- a/src/Dojang/Syntax/Manifest/Writer.hs +++ b/src/Dojang/Syntax/Manifest/Writer.hs @@ -3,14 +3,16 @@ {-# LANGUAGE NoFieldSelectors #-} module Dojang.Syntax.Manifest.Writer - ( writeManifest + ( WriteError (..) + , writeManifest , writeManifestFile ) where -import Data.Bifunctor (Bifunctor (bimap, second)) -import Data.List (partition) +import Control.Monad.Except (MonadError (throwError)) +import Data.Bifunctor (Bifunctor (second)) +import Data.List (group, partition, sort) import Data.List.NonEmpty (NonEmpty ((:|)), length, toList) -import Data.Maybe (catMaybes, fromMaybe, listToMaybe) +import Data.Maybe (fromMaybe, listToMaybe) import GHC.IsList (IsList (fromList)) import System.IO.Unsafe (unsafePerformIO) import Prelude hiding (all, any, writeFile) @@ -24,7 +26,6 @@ import TextShow (FromStringShow (FromStringShow), TextShow (showt)) import Toml.Pretty (prettyTomlOrdered) import Toml.ToValue (ToTable (toTable)) -import Toml.Value (Table) import qualified Data.Map.Strict import Dojang.MonadFileSystem @@ -48,7 +49,7 @@ ( EnvironmentPredicate (..) , normalizePredicate ) -import Dojang.Types.FilePathExpression (toPathText) +import Dojang.Types.FilePathExpression (FilePathExpression, toPathText) import Dojang.Types.FileRoute (FileRoute (..)) import Dojang.Types.FileRouteMap (FileRouteMap) import Dojang.Types.Hook (Hook (..), HookMap, HookType (..)) @@ -61,18 +62,56 @@ schema = "https://schema.dojang.dev/2023-11/manifest.schema.json" +-- | An error that can occur while encoding a 'Manifest'. +data WriteError + = -- | A route contains an environment predicate that cannot be represented + -- by any moniker in the manifest. + UnrepresentableRoutePredicate + OsPath + -- ^ The source path of the route. + EnvironmentPredicate + -- ^ The predicate that cannot be represented. + | -- | Multiple route predicates resolve to the same moniker and therefore + -- cannot be represented as distinct entries in the manifest. + DuplicateRouteMoniker + OsPath + -- ^ The source path of the route. + MonikerName + -- ^ The moniker shared by multiple route predicates. + deriving (Eq) + + +instance Show WriteError where + show (UnrepresentableRoutePredicate path predicate) = + "Route predicate " + <> show predicate + <> " for path " + <> show (decodePath path) + <> " cannot be represented by any moniker." + show (DuplicateRouteMoniker path moniker) = + "Multiple route predicates for path " + <> show (decodePath path) + <> " resolve to moniker " + <> show moniker + <> "." + + -- | Encodes a 'Manifest' into a TOML document. -writeManifest :: Manifest -> Text -writeManifest manifest = - "#:schema " - <> schema - <> "\n\n" - <> (showt $ FromStringShow $ prettyTomlOrdered order tbl) +writeManifest + :: Manifest + -- ^ The 'Manifest' to encode. + -> Either WriteError Text + -- ^ The encoded TOML document, or an error if the manifest contains route + -- predicates that the TOML format cannot represent without data loss. +writeManifest manifest = do + manifest' <- mapManifest' manifest + let tbl = toTable manifest' + pure $ + "#:schema " + <> schema + <> "\n\n" + <> (showt $ FromStringShow $ prettyTomlOrdered order tbl) where - manifest' :: Manifest' - manifest' = mapManifest' manifest - tbl :: Table - tbl = toTable manifest' order :: [String] -> String -> Either Int String order [] field = case field of "dirs" -> Left 1 @@ -83,8 +122,8 @@ order _ field = Right field --- | Writes a 'Manifest' file to the given path. Throw an 'IOError' if the --- an occurs while writing the file. +-- | Writes a 'Manifest' file to the given path. Throws an 'IOError' if the +-- manifest cannot be encoded or an error occurs while writing the file. writeManifestFile :: (MonadFileSystem m) => Manifest @@ -93,16 +132,16 @@ -- ^ The path to write the 'Manifest' to. -> m () writeManifestFile manifest filePath = - writeFile filePath $ encodeUtf8 $ writeManifest manifest + case writeManifest manifest of + Left err -> throwError $ userError $ show err + Right toml -> writeFile filePath $ encodeUtf8 toml -mapManifest' :: Manifest -> Manifest' -mapManifest' manifest = - Manifest' monikers' dirs files ignores hooks' +mapManifest' :: Manifest -> Either WriteError Manifest' +mapManifest' manifest = do + (dirs, files) <- mapFiles manifest.fileRoutes manifest.monikers + pure $ Manifest' monikers' dirs files ignores hooks' where - dirs :: FileRouteMap' - files :: FileRouteMap' - (dirs, files) = mapFiles manifest.fileRoutes manifest.monikers monikers' :: MonikerMap' monikers' = mapMonikers' manifest.monikers ignores :: IgnoreMap' @@ -118,12 +157,19 @@ else Just $ mapHooks' manifest.hooks -mapFiles :: FileRouteMap -> MonikerMap -> (FileRouteMap', FileRouteMap') -mapFiles fileRouteMap monikers = - ( fromList (bimap decodePath (`mapFileRoute'` monikers) <$> dirs) - , fromList (bimap decodePath (`mapFileRoute'` monikers) <$> files) - ) +mapFiles + :: FileRouteMap + -> MonikerMap + -> Either WriteError (FileRouteMap', FileRouteMap') +mapFiles fileRouteMap monikers = do + dirs' <- traverse mapRoute dirs + files' <- traverse mapRoute files + pure (fromList dirs', fromList files') where + mapRoute :: (OsPath, FileRoute) -> Either WriteError (FilePath, FileRoute') + mapRoute (path, route) = do + route' <- mapFileRoute' path route monikers + pure (decodePath path, route') dirs :: [(OsPath, FileRoute)] files :: [(OsPath, FileRoute)] (dirs, files) = @@ -136,25 +182,42 @@ decodePath = unsafePerformIO . decodeFS -mapFileRoute' :: FileRoute -> MonikerMap -> FileRoute' -mapFileRoute' fileRoute monikers = - (fromList . catMaybes) - [ case (normalizePredicate pred', maybe "" toPathText filePath) of - (Moniker n, path) -> Just (n, path) - (pred'', path) -> case lookBack monikers pred'' of - Just n -> Just (n, path) - Nothing -> Nothing - | (pred', filePath) <- fileRoute.predicates - ] +mapFileRoute' + :: OsPath -> FileRoute -> MonikerMap -> Either WriteError FileRoute' +mapFileRoute' routePath fileRoute monikers = do + mappedPredicates <- traverse mapPredicate fileRoute.predicates + case duplicateMoniker mappedPredicates of + Nothing -> Right $ fromList mappedPredicates + Just moniker -> Left $ DuplicateRouteMoniker routePath moniker + where + duplicateMoniker :: [(MonikerName, Text)] -> Maybe MonikerName + duplicateMoniker entries = + listToMaybe + [ moniker + | moniker : _ : _ <- group $ sort $ fst <$> entries + ] + mapPredicate + :: (EnvironmentPredicate, Maybe FilePathExpression) + -> Either WriteError (MonikerName, Text) + mapPredicate (predicate, filePath) = + case normalizePredicate predicate of + Moniker name -> Right (name, path) + normalizedPredicate -> case lookBack monikers normalizedPredicate of + Just name -> Right (name, path) + Nothing -> + Left $ UnrepresentableRoutePredicate routePath normalizedPredicate + where + path = maybe "" toPathText filePath lookBack :: MonikerMap -> EnvironmentPredicate -> Maybe MonikerName lookBack monikers predicate = - listToMaybe - [ n - | (n, p) <- Data.HashMap.Strict.toList monikers - , normalizePredicate p == normalizedPred - ] + listToMaybe $ + sort + [ n + | (n, p) <- Data.HashMap.Strict.toList monikers + , normalizePredicate p == normalizedPred + ] where normalizedPred :: EnvironmentPredicate normalizedPred = normalizePredicate predicate diff --git a/test/Dojang/Commands/HookSpec.hs b/test/Dojang/Commands/HookSpec.hs --- a/test/Dojang/Commands/HookSpec.hs +++ b/test/Dojang/Commands/HookSpec.hs @@ -3,18 +3,39 @@ module Dojang.Commands.HookSpec (spec) where +import Control.Exception (bracket_) +import Control.Monad (when) import System.IO.Unsafe (unsafePerformIO) import Data.HashMap.Strict (empty) -import System.OsPath (OsPath, encodeFS) -import Test.Hspec (Spec, describe, it, shouldBe) +import qualified Data.Map.Strict as Map +import Data.Text (Text, pack) +import System.Environment + ( getArgs + , getExecutablePath + , lookupEnv + , setEnv + , unsetEnv + ) +import System.OsPath (OsPath, encodeFS, ()) +import Test.Hspec (Spec, describe, it, sequential, shouldBe) -import Dojang.Commands.Hook (shouldRunHook) +import Dojang.App (AppEnv (..), runAppWithoutLogging) +import Dojang.Commands.Hook + ( HookEnv (..) + , executeHooks + , mergeHookEnvironment + , shouldRunHook + ) +import Dojang.TestUtils (withTempDir) +import Dojang.Types.Context (Context (..)) import Dojang.Types.Environment (Environment (..), Kernel (..)) import Dojang.Types.EnvironmentPredicate (EnvironmentPredicate (..)) -import Dojang.Types.Hook (Hook (..)) +import Dojang.Types.Hook (Hook (..), HookType (PreApply)) +import Dojang.Types.Manifest (Manifest (..)) import Dojang.Types.MonikerMap (MonikerMap) import Dojang.Types.MonikerName (parseMonikerName) +import Dojang.Types.Repository (Repository (..)) encodePath :: String -> OsPath @@ -22,7 +43,19 @@ spec :: Spec -spec = do +spec = sequential $ do + describe "mergeHookEnvironment" $ do + let dojangEnv = [("DOJANG_OS", "linux")] + let parentEnv = [("Dojang_OS", "stale"), ("PATH", "/bin")] + + it "replaces differently cased variable names on Windows" $ do + mergeHookEnvironment "mingw32" dojangEnv parentEnv + `shouldBe` [("DOJANG_OS", "linux"), ("PATH", "/bin")] + + it "preserves differently cased variable names on POSIX" $ do + mergeHookEnvironment "linux" dojangEnv parentEnv + `shouldBe` dojangEnv ++ parentEnv + describe "shouldRunHook" $ do let env = Environment "linux" "x86_64" $ Kernel "Linux" "6.0.0" @@ -89,3 +122,86 @@ , ignoreFailure = False } shouldRunHook monikers env hook `shouldBe` False + + describe "executeHooks" $ do + it "inherits the parent environment and overrides Dojang variables" $ + withTempDir $ \tmpDir _ -> do + command <- hookCommand + manifestFilename <- encodeFS "dojang.toml" + intermediateDir <- encodeFS ".dojang" + envFilename <- encodeFS "dojang-env.toml" + let hook = + Hook + { command = fst command + , args = snd command + , condition = Always + , workingDirectory = Nothing + , ignoreFailure = False + } + let manifest' = + Manifest empty Map.empty Map.empty $ Map.singleton PreApply [hook] + let repository = Repository tmpDir (tmpDir intermediateDir) manifest' + let environment = Environment "linux" "x86_64" $ Kernel "Linux" "6.0.0" + let context = Context repository environment (const $ pure Nothing) + let appEnv = + AppEnv + tmpDir + intermediateDir + manifestFilename + envFilename + False + False + let hookEnv = + HookEnv + tmpDir + (tmpDir manifestFilename) + False + "hook-test-os" + "x86_64" + withEnvVars + [ ("DOJANG_TEST_PARENT", Just "inherited") + , ("DOJANG_OS", Just "stale") + ] + $ runAppWithoutLogging appEnv + $ executeHooks hookEnv context PreApply + + it "hook environment probe" $ do + arguments <- getArgs + when (probePattern `elem` arguments && probeSeed `elem` arguments) $ do + lookupEnv "DOJANG_TEST_PARENT" >>= (`shouldBe` Just "inherited") + lookupEnv "DOJANG_OS" >>= (`shouldBe` Just "hook-test-os") + + +hookCommand :: IO (OsPath, [Text]) +hookCommand = do + command <- getExecutablePath >>= encodeFS + pure + ( command + , + [ "--match" + , pack probePattern + , "--seed" + , pack probeSeed + ] + ) + + +probePattern :: String +probePattern = "/Dojang.Commands.Hook/executeHooks/hook environment probe/" + + +probeSeed :: String +probeSeed = "250025" + + +withEnvVars :: [(String, Maybe String)] -> IO a -> IO a +withEnvVars [] action = action +withEnvVars ((name, value) : rest) action = do + oldValue <- lookupEnv name + bracket_ + (setOrUnset value) + (setOrUnset oldValue) + (withEnvVars rest action) + where + setOrUnset (Just value') = setEnv name value' + setOrUnset Nothing = unsetEnv name diff --git a/test/Dojang/Commands/ReflectSpec.hs b/test/Dojang/Commands/ReflectSpec.hs new file mode 100644 --- /dev/null +++ b/test/Dojang/Commands/ReflectSpec.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} + +module Dojang.Commands.ReflectSpec (spec) where + +import Control.Exception (bracket_) +import Data.HashMap.Strict (singleton) +import qualified Data.Map.Strict as Map +import System.Environment (lookupEnv, setEnv, unsetEnv) +import System.Exit (ExitCode (ExitSuccess)) +import System.OsPath (OsPath, encodeFS, ()) +import Test.Hspec (Spec, describe, it, sequential) +import Test.Hspec.Expectations.Pretty (shouldReturn) +import Prelude hiding (writeFile) + +import Dojang.App (AppEnv (..), runAppWithoutLogging) +import Dojang.Commands.Reflect (reflect) +import Dojang.MonadFileSystem (MonadFileSystem (..)) +import Dojang.Syntax.Manifest.Writer (writeManifestFile) +import Dojang.TestUtils (withTempDir) +import Dojang.Types.EnvironmentPredicate (EnvironmentPredicate (Always)) +import Dojang.Types.FilePathExpression (FilePathExpression (Substitution)) +import Dojang.Types.Manifest (manifest) +import Dojang.Types.MonikerName (parseMonikerName) + + +spec :: Spec +spec = sequential $ do + describe "reflect" $ do + it "reflects a destination-side deletion" $ + withDeletedDestination $ + \appEnv source intermediate _ -> do + runAppWithoutLogging appEnv (reflect False True False Nothing []) + `shouldReturn` ExitSuccess + exists source `shouldReturn` False + exists intermediate `shouldReturn` False + + it "reflects an explicitly named deleted destination" $ + withDeletedDestination $ \appEnv source intermediate destination -> do + runAppWithoutLogging + appEnv + (reflect False True False Nothing [destination]) + `shouldReturn` ExitSuccess + exists source `shouldReturn` False + exists intermediate `shouldReturn` False + + +withDeletedDestination :: (AppEnv -> OsPath -> OsPath -> OsPath -> IO a) -> IO a +withDeletedDestination action = withTempDir $ \tmpDir _ -> do + sourceDir <- encodeFS "source" + intermediateDir <- encodeFS ".dojang" + manifestFilename <- encodeFS "dojang.toml" + envFilename <- encodeFS "dojang-env.toml" + routeName <- encodeFS "managed-file" + destination <- encodeFS "destination" + let repository = tmpDir sourceDir + let intermediate = repository intermediateDir routeName + let source = repository routeName + let destinationPath = tmpDir destination + let Right always = parseMonikerName "always" + let manifest' = + manifest + (singleton always Always) + (Map.singleton routeName [(always, Just $ Substitution "DEST")]) + mempty + mempty + mempty + let appEnv = + AppEnv + repository + intermediateDir + manifestFilename + envFilename + False + False + + createDirectories $ repository intermediateDir + writeManifestFile manifest' $ repository manifestFilename + writeFile source "managed contents" + writeFile intermediate "managed contents" + + withEnvVar "DEST" (Just destinationPath) $ + action appEnv source intermediate destinationPath + + +withEnvVar :: String -> Maybe OsPath -> IO a -> IO a +withEnvVar name value action = do + oldValue <- lookupEnv name + bracket_ + (setOrUnset value) + (maybe (unsetEnv name) (setEnv name) oldValue) + action + where + setOrUnset Nothing = unsetEnv name + setOrUnset (Just value') = decodePath value' >>= setEnv name diff --git a/test/Dojang/Syntax/Manifest/WriterSpec.hs b/test/Dojang/Syntax/Manifest/WriterSpec.hs --- a/test/Dojang/Syntax/Manifest/WriterSpec.hs +++ b/test/Dojang/Syntax/Manifest/WriterSpec.hs @@ -1,20 +1,112 @@ +{-# LANGUAGE OverloadedStrings #-} + module Dojang.Syntax.Manifest.WriterSpec (spec) where -import Data.Text (unpack) -import Test.Hspec (Spec, specify) -import Test.Hspec.Hedgehog (annotate, annotateShow, forAll, hedgehog, (===)) +import qualified Data.HashMap.Strict as HashMap +import Data.List (sort) +import qualified Data.Map.Strict as Map +import Data.Maybe (listToMaybe) +import Data.Text (isInfixOf, unpack) +import System.OsPath (encodeFS) +import Test.Hspec (Spec, runIO, specify) +import Test.Hspec.Expectations.Pretty (shouldBe, shouldSatisfy) +import Test.Hspec.Hedgehog + ( annotate + , annotateShow + , assert + , forAll + , hedgehog + , (===) + ) +import Dojang.MonadFileSystem (FileType (File)) import Dojang.Syntax.Manifest.Parser (readManifest) -import Dojang.Syntax.Manifest.Writer (writeManifest) -import Dojang.Types.Gen as Gen (manifest) +import Dojang.Syntax.Manifest.Writer (WriteError (..), writeManifest) +import Dojang.Types.EnvironmentPredicate + ( EnvironmentPredicate (Moniker, OperatingSystem) + , normalizePredicate + ) +import Dojang.Types.FileRoute (FileRoute (FileRoute), fileRoute') +import Dojang.Types.Gen as Gen (arbitraryManifest, manifest) +import Dojang.Types.Manifest (Manifest (Manifest)) +import Dojang.Types.MonikerName (parseMonikerName) spec :: Spec spec = do + path <- runIO $ encodeFS "foo" + let Right alpha = parseMonikerName "alpha" + Right zeta = parseMonikerName "zeta" + linux = OperatingSystem "linux" + specify "writeManifest" $ hedgehog $ do manifest' <- forAll Gen.manifest - let toml = writeManifest manifest' + let Right toml = writeManifest manifest' annotate $ unpack toml let Right (parsed, _) = readManifest toml annotateShow parsed parsed === manifest' + + specify "rejects route predicates that cannot be represented" $ do + let route = fileRoute' (const Nothing) [(linux, Nothing)] File + manifest' = Manifest HashMap.empty (Map.singleton path route) Map.empty Map.empty + writeManifest manifest' + `shouldBe` Left (UnrepresentableRoutePredicate path linux) + + specify "rejects route predicates that map to the same moniker" $ do + let monikers = HashMap.singleton alpha linux + route = + fileRoute' + (`HashMap.lookup` monikers) + [(Moniker alpha, Nothing), (linux, Nothing)] + File + manifest' = Manifest monikers (Map.singleton path route) Map.empty Map.empty + writeManifest manifest' + `shouldBe` Left (DuplicateRouteMoniker path alpha) + + specify "never drops arbitrary route predicates" $ hedgehog $ do + manifest'@(Manifest monikers routes ignores hooks) <- + forAll Gen.arbitraryManifest + case writeManifest manifest' of + Left (UnrepresentableRoutePredicate routePath predicate) -> do + let Just (FileRoute _ predicates _) = Map.lookup routePath routes + assert $ + predicate `elem` (normalizePredicate . fst <$> predicates) + assert $ + all + ((/= predicate) . normalizePredicate) + (HashMap.elems monikers) + Left (DuplicateRouteMoniker routePath moniker) -> do + let Just (FileRoute _ predicates _) = Map.lookup routePath routes + resolve predicate = case normalizePredicate predicate of + Moniker name -> Just name + normalizedPredicate -> + listToMaybe $ + sort + [ name + | (name, definition) <- HashMap.toList monikers + , normalizePredicate definition == normalizedPredicate + ] + matches = + [ () + | (predicate, _) <- predicates + , resolve predicate == Just moniker + ] + assert $ length matches > 1 + Right toml -> do + annotate $ unpack toml + let Right (Manifest monikers' routes' ignores' hooks', _) = + readManifest toml + routeShape (FileRoute _ predicates fileType) = + (sort $ show . snd <$> predicates, fileType) + monikers' === monikers + Map.map routeShape routes' === Map.map routeShape routes + ignores' === ignores + hooks' === hooks + + specify "selects deterministically between equivalent monikers" $ do + let monikers = HashMap.fromList [(zeta, linux), (alpha, linux)] + route = fileRoute' (`HashMap.lookup` monikers) [(linux, Nothing)] File + manifest' = Manifest monikers (Map.singleton path route) Map.empty Map.empty + Right toml = writeManifest manifest' + toml `shouldSatisfy` isInfixOf "alpha = \"\"" diff --git a/test/Dojang/Types/Environment/CurrentSpec.hs b/test/Dojang/Types/Environment/CurrentSpec.hs --- a/test/Dojang/Types/Environment/CurrentSpec.hs +++ b/test/Dojang/Types/Environment/CurrentSpec.hs @@ -99,7 +99,7 @@ expectLinuxKernel kernel = do original kernel.name `shouldBe` "Linux" original kernel.release - `shouldSatisfy` (=~ ("^[0-9]+\\.[0-9]+\\.?[0-9]+[.-][0-9]+(-|$)" :: Text)) + `shouldSatisfy` (=~ ("^[0-9]+\\.[0-9]+\\.?[0-9]+[.-][0-9]+([-.]|$)" :: Text)) expectWindowsKernel :: Kernel -> IO () diff --git a/test/Dojang/Types/Gen.hs b/test/Dojang/Types/Gen.hs --- a/test/Dojang/Types/Gen.hs +++ b/test/Dojang/Types/Gen.hs @@ -3,7 +3,8 @@ {-# LANGUAGE ScopedTypeVariables #-} module Dojang.Types.Gen - ( architecture + ( arbitraryManifest + , architecture , ciText , fileRoute , fileRoute' @@ -40,7 +41,6 @@ import Data.CaseInsensitive (CI, mk) import Data.HashMap.Strict (HashMap, fromList, keys, lookup) -import Data.Map.Strict (empty) import Data.Text (Text, cons, length, pack) import Hedgehog.Gen qualified as Gen import Hedgehog.Range (Range, constant, constantFrom, singleton) @@ -390,29 +390,57 @@ fileRouteMap range monikers = Gen.map range $ do key <- osPath (singleton 1) - value <- - fileRoute' (constant 0 5) monikers $ - Gen.choice $ - map return $ - fmap Moniker $ - case keys monikers of - [] -> - let Right undefined' = parseMonikerName $ pack "undefined" - in [undefined'] - names -> names + value <- representableRoute return (key, value) + where + monikerPredicates :: [EnvironmentPredicate] + monikerPredicates = + fmap Moniker $ case keys monikers of + [] -> + let Right undefined' = parseMonikerName $ pack "undefined" + in [undefined'] + names -> names + representableRoute :: (MonadGen m) => m FileRoute.FileRoute + representableRoute = + fileRoute' (constant 0 5) monikers $ Gen.element monikerPredicates +arbitraryFileRouteMap + :: (MonadGen m) => Range Int -> MonikerMap -> m FileRouteMap +arbitraryFileRouteMap range monikers = + Gen.map range $ do + key <- osPath (singleton 1) + value <- fileRoute' (constant 0 5) monikers environmentPredicate + return (key, value) + + +ignoreMap :: (MonadGen m) => m (Map.Map OsPath [String]) +ignoreMap = Gen.map (constantFrom 0 0 5) $ do + path <- osPath (singleton 1) + patterns <- Gen.list (constantFrom 1 1 5) $ Gen.string (constant 0 20) osChar + pure (path, patterns) + + manifest' :: forall m. (MonadGen m) => Range Int -> Range Int -> m Manifest manifest' monikerMapRange fileRouteMapRange = do monikers <- monikerMap' monikerMapRange fileRoutes <- fileRouteMap fileRouteMapRange monikers + ignorePatterns <- ignoreMap hooks <- hookMap (constant 0 3) - return $ Manifest monikers fileRoutes Data.Map.Strict.empty hooks + return $ Manifest monikers fileRoutes ignorePatterns hooks manifest :: (MonadGen m) => m Manifest manifest = manifest' (constantFrom 0 0 5) (constantFrom 0 0 5) + + +arbitraryManifest :: (MonadGen m) => m Manifest +arbitraryManifest = do + monikers <- monikerMap' (constantFrom 0 0 5) + fileRoutes <- arbitraryFileRouteMap (constantFrom 0 0 5) monikers + ignorePatterns <- ignoreMap + hooks <- hookMap (constant 0 3) + return $ Manifest monikers fileRoutes ignorePatterns hooks hook :: (MonadGen m) => m Hook