diff options
| -rw-r--r-- | Messages.hs | 26 | ||||
| -rw-r--r-- | Seek.hs | 12 | ||||
| -rw-r--r-- | Types/Messages.hs | 6 | ||||
| -rw-r--r-- | Utility/Path.hs | 32 | ||||
| -rw-r--r-- | debian/changelog | 1 | ||||
| -rw-r--r-- | doc/bugs/unlock_fails_silently_with_directory_symlinks.mdwn | 2 |
6 files changed, 52 insertions, 27 deletions
diff --git a/Messages.hs b/Messages.hs index 822458143..d75fe6769 100644 --- a/Messages.hs +++ b/Messages.hs @@ -23,6 +23,7 @@ module Messages ( showEndResult, showErr, warning, + fileNotFound, indent, maybeShowJSON, showFullJSON, @@ -44,6 +45,7 @@ import Types.Messages import Types.Key import qualified Annex import qualified Messages.JSON as JSON +import qualified Data.Set as S showStart :: String -> String -> Annex () showStart command file = handle (JSON.start command $ Just file) $ @@ -89,11 +91,13 @@ meteredBytes combinemeterupdate size a = withOutputType go showSideAction :: String -> Annex () showSideAction m = Annex.getState Annex.output >>= go where - go (MessageState v StartBlock) = do - p - Annex.changeState $ \s -> s { Annex.output = MessageState v InBlock } - go (MessageState _ InBlock) = return () - go _ = p + go st + | sideActionBlock st == StartBlock = do + p + let st' = st { sideActionBlock = InBlock } + Annex.changeState $ \s -> s { Annex.output = st' } + | sideActionBlock st == InBlock = return () + | otherwise = p p = handle q $ putStrLn $ "(" ++ m ++ "...)" showStoringStateAction :: Annex () @@ -150,6 +154,18 @@ warning' w = do hFlush stdout hPutStrLn stderr w +{- Displays a warning one time about a file the user specified not existing. -} +fileNotFound :: FilePath -> Annex () +fileNotFound file = do + st <- Annex.getState Annex.output + let shown = fileNotFoundShown st + when (S.notMember file shown) $ do + let shown' = S.insert file shown + let st' = st { fileNotFoundShown = shown' } + Annex.changeState $ \s -> s { Annex.output = st' } + liftIO $ hPutStrLn stderr $ unwords + [ "git-annex:", file, "not found" ] + indent :: String -> String indent = join "\n" . map (\l -> " " ++ l) . lines @@ -22,8 +22,14 @@ import qualified Limit import qualified Option seekHelper :: ([FilePath] -> Git.Repo -> IO ([FilePath], IO Bool)) -> [FilePath] -> Annex [FilePath] -seekHelper a params = inRepo $ \g -> - runPreserveOrder (\fs -> Git.Command.leaveZombie <$> a fs g) params +seekHelper a params = do + ll <- inRepo $ \g -> + runSegmentPaths (\fs -> Git.Command.leaveZombie <$> a fs g) params + {- Show warnings only for files/directories that do not exist. -} + forM_ (map fst $ filter (null . snd) $ zip params ll) $ \p -> + unlessM (liftIO $ doesFileExist p <||> doesDirectoryExist p) $ + fileNotFound p + return $ concat ll withFilesInGit :: (FilePath -> CommandStart) -> CommandSeek withFilesInGit a params = prepFiltered a $ seekHelper LsFiles.inRepo params @@ -34,7 +40,7 @@ withFilesNotInGit a params = do files <- filter (not . dotfile) <$> seekunless (null ps && not (null params)) ps dotfiles <- seekunless (null dotps) dotps - prepFiltered a $ return $ preserveOrder params (files++dotfiles) + prepFiltered a $ return $ concat $ segmentPaths params (files++dotfiles) where (dotps, ps) = partition dotfile params seekunless True _ = return [] diff --git a/Types/Messages.hs b/Types/Messages.hs index 75653d574..4fcce79f8 100644 --- a/Types/Messages.hs +++ b/Types/Messages.hs @@ -7,14 +7,18 @@ module Types.Messages where +import qualified Data.Set as S + data OutputType = NormalOutput | QuietOutput | JSONOutput data SideActionBlock = NoBlock | StartBlock | InBlock + deriving (Eq) data MessageState = MessageState { outputType :: OutputType , sideActionBlock :: SideActionBlock + , fileNotFoundShown :: S.Set FilePath } defaultMessageState :: MessageState -defaultMessageState = MessageState NormalOutput NoBlock +defaultMessageState = MessageState NormalOutput NoBlock S.empty diff --git a/Utility/Path.hs b/Utility/Path.hs index f4c2843fc..272d2e85b 100644 --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -104,29 +104,25 @@ prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference same_dir_shortcurcuits_at_difference = relPathDirToFile "/tmp/r/lll/xxx/yyy/18" "/tmp/r/.git/annex/objects/18/gk/SHA256-foo/SHA256-foo" == "../../../../.git/annex/objects/18/gk/SHA256-foo/SHA256-foo" -{- Given an original list of files, and an expanded list derived from it, - - ensures that the original list's ordering is preserved. - - - - The input list may contain a directory, like "dir" or "dir/". Any - - items in the expanded list that are contained in that directory will - - appear at the same position as it did in the input list. +{- Given an original list of paths, and an expanded list derived from it, + - generates a list of lists, where each sublist corresponds to one of the + - original paths. When the original path is a direcotry, any items + - in the expanded list that are contained in that directory will appear in + - its segment. -} -preserveOrder :: [FilePath] -> [FilePath] -> [FilePath] -preserveOrder [] new = new -preserveOrder [_] new = new -- optimisation -preserveOrder (l:ls) new = found ++ preserveOrder ls rest +segmentPaths :: [FilePath] -> [FilePath] -> [[FilePath]] +segmentPaths [] new = [new] +segmentPaths [_] new = [new] -- optimisation +segmentPaths (l:ls) new = [found] ++ segmentPaths ls rest where (found, rest)=partition (l `dirContains`) new -{- Runs an action that takes a list of FilePaths, and ensures that - - its return list preserves order. - - - - This assumes that it's cheaper to call preserveOrder on the result, - - than it would be to run the action separately with each param. In the case - - of git file list commands, that assumption tends to hold. +{- This assumes that it's cheaper to call segmentPaths on the result, + - than it would be to run the action separately with each path. In + - the case of git file list commands, that assumption tends to hold. -} -runPreserveOrder :: ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [FilePath] -runPreserveOrder a files = preserveOrder files <$> a files +runSegmentPaths :: ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [[FilePath]] +runSegmentPaths a paths = segmentPaths paths <$> a paths {- Converts paths in the home directory to use ~/ -} relHome :: FilePath -> IO String diff --git a/debian/changelog b/debian/changelog index 21bba4230..02e89e14d 100644 --- a/debian/changelog +++ b/debian/changelog @@ -22,6 +22,7 @@ git-annex (3.20121113) UNRELEASED; urgency=low client repository group. * assistant: Apply preferred content settings when a new symlink is created, or a symlink gets renamed. Made archive directories work. + * Display a warning when a non-existing file or directory is specified. -- Joey Hess <joeyh@debian.org> Tue, 13 Nov 2012 13:17:07 -0400 diff --git a/doc/bugs/unlock_fails_silently_with_directory_symlinks.mdwn b/doc/bugs/unlock_fails_silently_with_directory_symlinks.mdwn index 4f6c82300..9b9bb6342 100644 --- a/doc/bugs/unlock_fails_silently_with_directory_symlinks.mdwn +++ b/doc/bugs/unlock_fails_silently_with_directory_symlinks.mdwn @@ -49,3 +49,5 @@ jason@jasonwoof.com > have multiple seek stages that act on different types of files, so > any warning printed by an earlier stage may be premature if a later > stage comes along and deals with a file. --[[Joey]] + +>> Figured out a non-invasive way to add that warning. [[done]] --[[Joey]] |