From df21cbfdd2b7342c206ebd4aea32d989328374dc Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 6 Jan 2012 04:02:35 -0400 Subject: look up --to and --from remote names only once This will speed up commands like move and drop. --- Command/Copy.hs | 8 +++++--- Command/Drop.hs | 7 +++---- Command/DropUnused.hs | 5 ++--- Command/Find.hs | 2 +- Command/Get.hs | 7 +++---- Command/Move.hs | 15 ++++++--------- Command/Sync.hs | 2 +- Command/Unused.hs | 2 +- Remote.hs | 11 ++++++----- Seek.hs | 4 ++-- 10 files changed, 30 insertions(+), 33 deletions(-) diff --git a/Command/Copy.hs b/Command/Copy.hs index d789d41f6..c83c72412 100644 --- a/Command/Copy.hs +++ b/Command/Copy.hs @@ -10,17 +10,19 @@ module Command.Copy where import Common.Annex import Command import qualified Command.Move +import qualified Remote def :: [Command] def = [withOptions Command.Move.options $ command "copy" paramPaths seek "copy content of files to/from another repository"] seek :: [CommandSeek] -seek = [withField "to" id $ \to -> withField "from" id $ \from -> - withNumCopies $ \n -> whenAnnexed $ start to from n] +seek = [withField "to" Remote.byName $ \to -> + withField "from" Remote.byName $ \from -> + withNumCopies $ \n -> whenAnnexed $ start to from n] -- A copy is just a move that does not delete the source file. -- However, --auto mode avoids unnecessary copies. -start :: Maybe String -> Maybe String -> Maybe Int -> FilePath -> (Key, Backend) -> CommandStart +start :: Maybe Remote -> Maybe Remote -> Maybe Int -> FilePath -> (Key, Backend) -> CommandStart start to from numcopies file (key, backend) = autoCopies key (<) numcopies $ Command.Move.start to from False file (key, backend) diff --git a/Command/Drop.hs b/Command/Drop.hs index f76951f08..07ea50df1 100644 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -25,15 +25,14 @@ fromOption :: Option fromOption = fieldOption ['f'] "from" paramRemote "drop content from a remote" seek :: [CommandSeek] -seek = [withField "from" id $ \from -> withNumCopies $ \n -> +seek = [withField "from" Remote.byName $ \from -> withNumCopies $ \n -> whenAnnexed $ start from n] -start :: Maybe String -> Maybe Int -> FilePath -> (Key, Backend) -> CommandStart +start :: Maybe Remote -> Maybe Int -> FilePath -> (Key, Backend) -> CommandStart start from numcopies file (key, _) = autoCopies key (>) numcopies $ do case from of Nothing -> startLocal file numcopies key - Just name -> do - remote <- Remote.byName name + Just remote -> do u <- getUUID if Remote.uuid remote == u then startLocal file numcopies key diff --git a/Command/DropUnused.hs b/Command/DropUnused.hs index fd3e84fe5..1c5bf8b8c 100644 --- a/Command/DropUnused.hs +++ b/Command/DropUnused.hs @@ -51,10 +51,9 @@ start (unused, unusedbad, unusedtmp) s = search next $ a key perform :: Key -> CommandPerform -perform key = maybe droplocal dropremote =<< Annex.getField "from" +perform key = maybe droplocal dropremote =<< Remote.byName =<< Annex.getField "from" where - dropremote name = do - r <- Remote.byName name + dropremote r = do showAction $ "from " ++ Remote.name r ok <- Remote.removeKey r key next $ Command.Drop.cleanupRemote key r ok diff --git a/Command/Find.hs b/Command/Find.hs index eb0267c14..8760cc947 100644 --- a/Command/Find.hs +++ b/Command/Find.hs @@ -33,7 +33,7 @@ seek :: [CommandSeek] seek = [withField "format" formatconverter $ \f -> withFilesInGit $ whenAnnexed $ start f] where - formatconverter = maybe Nothing (Just . Utility.Format.gen) + formatconverter = return . maybe Nothing (Just . Utility.Format.gen) start :: Maybe Utility.Format.Format -> FilePath -> (Key, Backend) -> CommandStart start format file (key, _) = do diff --git a/Command/Get.hs b/Command/Get.hs index 4a50fe3fe..1a0435c36 100644 --- a/Command/Get.hs +++ b/Command/Get.hs @@ -18,17 +18,16 @@ def = [withOptions [Command.Move.fromOption] $ command "get" paramPaths seek "make content of annexed files available"] seek :: [CommandSeek] -seek = [withField "from" id $ \from -> withNumCopies $ \n -> +seek = [withField "from" Remote.byName $ \from -> withNumCopies $ \n -> whenAnnexed $ start from n] -start :: Maybe String -> Maybe Int -> FilePath -> (Key, Backend) -> CommandStart +start :: Maybe Remote -> Maybe Int -> FilePath -> (Key, Backend) -> CommandStart start from numcopies file (key, _) = stopUnless (not <$> inAnnex key) $ autoCopies key (<) numcopies $ do case from of Nothing -> go $ perform key - Just name -> do + Just src -> do -- get --from = copy --from - src <- Remote.byName name stopUnless (Command.Move.fromOk src key) $ go $ Command.Move.fromPerform src False key where diff --git a/Command/Move.hs b/Command/Move.hs index 66a0c1660..4978283bf 100644 --- a/Command/Move.hs +++ b/Command/Move.hs @@ -29,20 +29,17 @@ options :: [Option] options = [fromOption, toOption] seek :: [CommandSeek] -seek = [withField "to" id $ \to -> withField "from" id $ \from -> - withFilesInGit $ whenAnnexed $ start to from True] +seek = [withField "to" Remote.byName $ \to -> + withField "from" Remote.byName $ \from -> + withFilesInGit $ whenAnnexed $ start to from True] -start :: Maybe String -> Maybe String -> Bool -> FilePath -> (Key, Backend) -> CommandStart +start :: Maybe Remote -> Maybe Remote -> Bool -> FilePath -> (Key, Backend) -> CommandStart start to from move file (key, _) = do noAuto case (from, to) of (Nothing, Nothing) -> error "specify either --from or --to" - (Nothing, Just name) -> do - dest <- Remote.byName name - toStart dest move file key - (Just name, Nothing) -> do - src <- Remote.byName name - fromStart src move file key + (Nothing, Just dest) -> toStart dest move file key + (Just src, Nothing) -> fromStart src move file key (_ , _) -> error "only one of --from or --to can be specified" where noAuto = when move $ whenM (Annex.getState Annex.auto) $ error diff --git a/Command/Sync.hs b/Command/Sync.hs index e5884cc4a..3d541c4de 100644 --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -61,7 +61,7 @@ syncRemotes rs = do wanted | null rs = good =<< available | otherwise = listed - listed = mapM Remote.byName rs + listed = catMaybes <$> mapM (Remote.byName . Just) rs available = filter nonspecial <$> Remote.enabledRemoteList good = filterM $ Remote.Git.repoAvail . Types.Remote.repo nonspecial r = Types.Remote.remotetype r == Remote.Git.remote diff --git a/Command/Unused.hs b/Command/Unused.hs index 59efe64c8..a6883dce1 100644 --- a/Command/Unused.hs +++ b/Command/Unused.hs @@ -66,7 +66,7 @@ checkUnused = do checkRemoteUnused :: String -> CommandPerform checkRemoteUnused name = do - checkRemoteUnused' =<< Remote.byName name + checkRemoteUnused' =<< fromJust <$> Remote.byName (Just name) next $ return True checkRemoteUnused' :: Remote -> Annex () diff --git a/Remote.hs b/Remote.hs index 8046175d2..3f60ca3ac 100644 --- a/Remote.hs +++ b/Remote.hs @@ -94,14 +94,15 @@ enabledRemoteList = filterM (repoNotIgnored . repo) =<< remoteList remoteMap :: Annex (M.Map UUID String) remoteMap = M.fromList . map (\r -> (uuid r, name r)) <$> remoteList -{- Looks up a remote by name. (Or by UUID.) Only finds currently configured - - git remotes. -} -byName :: String -> Annex (Remote) -byName n = do +{- When a name is specified, looks up the remote matching that name. + - (Or it can be a UUID.) Only finds currently configured git remotes. -} +byName :: Maybe String -> Annex (Maybe Remote) +byName Nothing = return Nothing +byName (Just n) = do res <- byName' n case res of Left e -> error e - Right r -> return r + Right r -> return $ Just r byName' :: String -> Annex (Either String Remote) byName' "" = return $ Left "no remote specified" byName' n = do diff --git a/Seek.hs b/Seek.hs index af074c7c5..53101b23e 100644 --- a/Seek.hs +++ b/Seek.hs @@ -91,9 +91,9 @@ withKeys a params = return $ map (a . parse) params - a conversion function, and then is passed into the seek action. - This ensures that the conversion function only runs once. -} -withField :: String -> (Maybe String -> a) -> (a -> CommandSeek) -> CommandSeek +withField :: String -> (Maybe String -> Annex a) -> (a -> CommandSeek) -> CommandSeek withField field converter a ps = do - f <- converter <$> Annex.getField field + f <- converter =<< Annex.getField field a f ps withNothing :: CommandStart -> CommandSeek -- cgit v1.2.3 From 1f8a1058c96bd4ee11fcb353f0ede1842d79ab6a Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 6 Jan 2012 10:14:37 -0400 Subject: tweak --- Command.hs | 1 - Command/Copy.hs | 4 +-- Command/Drop.hs | 5 ++-- Command/DropUnused.hs | 4 ++- Command/Find.hs | 13 +++++---- Command/Get.hs | 4 +-- Command/Move.hs | 9 +++--- Command/Unused.hs | 5 ++-- GitAnnex.hs | 5 ++-- Option.hs | 79 +++++++++++++++++++++++++++++++++++++++++++++++++++ Options.hs | 75 ------------------------------------------------ Seek.hs | 9 +++--- Types.hs | 4 ++- Types/Command.hs | 1 - git-annex-shell.hs | 3 +- 15 files changed, 118 insertions(+), 103 deletions(-) create mode 100644 Option.hs delete mode 100644 Options.hs diff --git a/Command.hs b/Command.hs index b287629ae..82d6429bf 100644 --- a/Command.hs +++ b/Command.hs @@ -30,7 +30,6 @@ import Types.Command as ReExported import Types.Option as ReExported import Seek as ReExported import Checks as ReExported -import Options as ReExported import Usage as ReExported import Logs.Trust import Logs.Location diff --git a/Command/Copy.hs b/Command/Copy.hs index c83c72412..32b83a526 100644 --- a/Command/Copy.hs +++ b/Command/Copy.hs @@ -17,8 +17,8 @@ def = [withOptions Command.Move.options $ command "copy" paramPaths seek "copy content of files to/from another repository"] seek :: [CommandSeek] -seek = [withField "to" Remote.byName $ \to -> - withField "from" Remote.byName $ \from -> +seek = [withField Command.Move.toOption Remote.byName $ \to -> + withField Command.Move.fromOption Remote.byName $ \from -> withNumCopies $ \n -> whenAnnexed $ start to from n] -- A copy is just a move that does not delete the source file. diff --git a/Command/Drop.hs b/Command/Drop.hs index 07ea50df1..578ab62b9 100644 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -16,16 +16,17 @@ import Logs.Location import Logs.Trust import Annex.Content import Config +import qualified Option def :: [Command] def = [withOptions [fromOption] $ command "drop" paramPaths seek "indicate content of files not currently wanted"] fromOption :: Option -fromOption = fieldOption ['f'] "from" paramRemote "drop content from a remote" +fromOption = Option.field ['f'] "from" paramRemote "drop content from a remote" seek :: [CommandSeek] -seek = [withField "from" Remote.byName $ \from -> withNumCopies $ \n -> +seek = [withField fromOption Remote.byName $ \from -> withNumCopies $ \n -> whenAnnexed $ start from n] start :: Maybe Remote -> Maybe Int -> FilePath -> (Key, Backend) -> CommandStart diff --git a/Command/DropUnused.hs b/Command/DropUnused.hs index 1c5bf8b8c..0b2a60216 100644 --- a/Command/DropUnused.hs +++ b/Command/DropUnused.hs @@ -15,6 +15,7 @@ import qualified Annex import qualified Command.Drop import qualified Remote import qualified Git +import qualified Option import Types.Key type UnusedMap = M.Map String Key @@ -51,13 +52,14 @@ start (unused, unusedbad, unusedtmp) s = search next $ a key perform :: Key -> CommandPerform -perform key = maybe droplocal dropremote =<< Remote.byName =<< Annex.getField "from" +perform key = maybe droplocal dropremote =<< Remote.byName =<< from where dropremote r = do showAction $ "from " ++ Remote.name r ok <- Remote.removeKey r key next $ Command.Drop.cleanupRemote key r ok droplocal = Command.Drop.performLocal key (Just 0) -- force drop + from = Annex.getField $ Option.name Command.Drop.fromOption performOther :: (Key -> Git.Repo -> FilePath) -> Key -> CommandPerform performOther filespec key = do diff --git a/Command/Find.hs b/Command/Find.hs index 8760cc947..902f50d2e 100644 --- a/Command/Find.hs +++ b/Command/Find.hs @@ -17,20 +17,23 @@ import qualified Annex import qualified Utility.Format import Utility.DataUnits import Types.Key +import qualified Option def :: [Command] def = [withOptions [formatOption, print0Option] $ command "find" paramPaths seek "lists available files"] +formatOption :: Option +formatOption = Option.field [] "format" paramFormat "control format of output" + print0Option :: Option -print0Option = Option [] ["print0"] (NoArg $ Annex.setField "format" "${file}\0") +print0Option = Option.Option [] ["print0"] (Option.NoArg set) "terminate output with null" - -formatOption :: Option -formatOption = fieldOption [] "format" paramFormat "control format of output" + where + set = Annex.setField (Option.name formatOption) "${file}\0" seek :: [CommandSeek] -seek = [withField "format" formatconverter $ \f -> +seek = [withField formatOption formatconverter $ \f -> withFilesInGit $ whenAnnexed $ start f] where formatconverter = return . maybe Nothing (Just . Utility.Format.gen) diff --git a/Command/Get.hs b/Command/Get.hs index 1a0435c36..5d032e13c 100644 --- a/Command/Get.hs +++ b/Command/Get.hs @@ -18,8 +18,8 @@ def = [withOptions [Command.Move.fromOption] $ command "get" paramPaths seek "make content of annexed files available"] seek :: [CommandSeek] -seek = [withField "from" Remote.byName $ \from -> withNumCopies $ \n -> - whenAnnexed $ start from n] +seek = [withField Command.Move.fromOption Remote.byName $ \from -> + withNumCopies $ \n -> whenAnnexed $ start from n] start :: Maybe Remote -> Maybe Int -> FilePath -> (Key, Backend) -> CommandStart start from numcopies file (key, _) = stopUnless (not <$> inAnnex key) $ diff --git a/Command/Move.hs b/Command/Move.hs index 4978283bf..2efaebbcb 100644 --- a/Command/Move.hs +++ b/Command/Move.hs @@ -14,23 +14,24 @@ import qualified Annex import Annex.Content import qualified Remote import Annex.UUID +import qualified Option def :: [Command] def = [withOptions options $ command "move" paramPaths seek "move content of files to/from another repository"] fromOption :: Option -fromOption = fieldOption ['f'] "from" paramRemote "source remote" +fromOption = Option.field ['f'] "from" paramRemote "source remote" toOption :: Option -toOption = fieldOption ['t'] "to" paramRemote "destination remote" +toOption = Option.field ['t'] "to" paramRemote "destination remote" options :: [Option] options = [fromOption, toOption] seek :: [CommandSeek] -seek = [withField "to" Remote.byName $ \to -> - withField "from" Remote.byName $ \from -> +seek = [withField toOption Remote.byName $ \to -> + withField fromOption Remote.byName $ \from -> withFilesInGit $ whenAnnexed $ start to from True] start :: Maybe Remote -> Maybe Remote -> Bool -> FilePath -> (Key, Backend) -> CommandStart diff --git a/Command/Unused.hs b/Command/Unused.hs index a6883dce1..ffd4bef45 100644 --- a/Command/Unused.hs +++ b/Command/Unused.hs @@ -27,6 +27,7 @@ import qualified Git.LsTree as LsTree import qualified Backend import qualified Remote import qualified Annex.Branch +import qualified Option import Annex.CatFile def :: [Command] @@ -34,7 +35,7 @@ def = [withOptions [fromOption] $ command "unused" paramNothing seek "look for unused file content"] fromOption :: Option -fromOption = fieldOption ['f'] "from" paramRemote "remote to check for unused content" +fromOption = Option.field ['f'] "from" paramRemote "remote to check for unused content" seek :: [CommandSeek] seek = [withNothing $ start] @@ -42,7 +43,7 @@ seek = [withNothing $ start] {- Finds unused content in the annex. -} start :: CommandStart start = do - from <- Annex.getField "from" + from <- Annex.getField $ Option.name fromOption let (name, action) = case from of Nothing -> (".", checkUnused) Just "." -> (".", checkUnused) diff --git a/GitAnnex.hs b/GitAnnex.hs index 8af1d5d59..64020754f 100644 --- a/GitAnnex.hs +++ b/GitAnnex.hs @@ -18,6 +18,7 @@ import Types.TrustLevel import qualified Annex import qualified Remote import qualified Limit +import qualified Option import qualified Command.Add import qualified Command.Unannex @@ -93,7 +94,7 @@ cmds = concat ] options :: [Option] -options = commonOptions ++ +options = Option.common ++ [ Option ['N'] ["numcopies"] (ReqArg setnumcopies paramNumber) "override default number of copies" , Option [] ["trust"] (ReqArg (Remote.forceTrust Trusted) paramRemote) @@ -114,7 +115,7 @@ options = commonOptions ++ "skip files with fewer copies" , Option ['B'] ["inbackend"] (ReqArg Limit.addInBackend paramName) "skip files not using a key-value backend" - ] ++ matcherOptions + ] ++ Option.matcher where setnumcopies v = Annex.changeState $ \s -> s {Annex.forcenumcopies = readMaybe v } setgitconfig :: String -> Annex () diff --git a/Option.hs b/Option.hs new file mode 100644 index 000000000..d6d8b44a3 --- /dev/null +++ b/Option.hs @@ -0,0 +1,79 @@ +{- git-annex command-line options + - + - Copyright 2010-2011 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Option ( + common, + matcher, + flag, + field, + name, + ArgDescr(..), + OptDescr(..), +) where + +import System.Console.GetOpt +import System.Log.Logger + +import Common.Annex +import qualified Annex +import Limit +import Usage + +common :: [Option] +common = + [ Option [] ["force"] (NoArg (setforce True)) + "allow actions that may lose annexed data" + , Option ['F'] ["fast"] (NoArg (setfast True)) + "avoid slow operations" + , Option ['a'] ["auto"] (NoArg (setauto True)) + "automatic mode" + , Option ['q'] ["quiet"] (NoArg (setoutput Annex.QuietOutput)) + "avoid verbose output" + , Option ['v'] ["verbose"] (NoArg (setoutput Annex.NormalOutput)) + "allow verbose output (default)" + , Option ['j'] ["json"] (NoArg (setoutput Annex.JSONOutput)) + "enable JSON output" + , Option ['d'] ["debug"] (NoArg (setdebug)) + "show debug messages" + , Option ['b'] ["backend"] (ReqArg setforcebackend paramName) + "specify key-value backend to use" + ] + where + setforce v = Annex.changeState $ \s -> s { Annex.force = v } + setfast v = Annex.changeState $ \s -> s { Annex.fast = v } + setauto v = Annex.changeState $ \s -> s { Annex.auto = v } + setoutput v = Annex.changeState $ \s -> s { Annex.output = v } + setforcebackend v = Annex.changeState $ \s -> s { Annex.forcebackend = Just v } + setdebug = liftIO $ updateGlobalLogger rootLoggerName $ + setLevel DEBUG + +matcher :: [Option] +matcher = + [ longopt "not" "negate next option" + , longopt "and" "both previous and next option must match" + , longopt "or" "either previous or next option must match" + , shortopt "(" "open group of options" + , shortopt ")" "close group of options" + ] + where + longopt o = Option [] [o] $ NoArg $ addToken o + shortopt o = Option o [] $ NoArg $ addToken o + +{- An option that sets a flag. -} +flag :: String -> String -> String -> Option +flag short opt description = + Option short [opt] (NoArg (Annex.setFlag opt)) description + +{- An option that sets a field. -} +field :: String -> String -> String -> String -> Option +field short opt paramdesc description = + Option short [opt] (ReqArg (Annex.setField opt) paramdesc) description + +{- The flag or field name used for an option. -} +name :: Option -> String +name (Option _ o _ _) = Prelude.head o + diff --git a/Options.hs b/Options.hs deleted file mode 100644 index 56f0bc0ee..000000000 --- a/Options.hs +++ /dev/null @@ -1,75 +0,0 @@ -{- git-annex command-line options - - - - Copyright 2010-2011 Joey Hess - - - - Licensed under the GNU GPL version 3 or higher. - -} - -module Options ( - commonOptions, - matcherOptions, - flagOption, - fieldOption, - ArgDescr(..), - Option, - OptDescr(..), -) where - -import System.Console.GetOpt -import System.Log.Logger - -import Common.Annex -import qualified Annex -import Limit -import Types.Option -import Usage - -commonOptions :: [Option] -commonOptions = - [ Option [] ["force"] (NoArg (setforce True)) - "allow actions that may lose annexed data" - , Option ['F'] ["fast"] (NoArg (setfast True)) - "avoid slow operations" - , Option ['a'] ["auto"] (NoArg (setauto True)) - "automatic mode" - , Option ['q'] ["quiet"] (NoArg (setoutput Annex.QuietOutput)) - "avoid verbose output" - , Option ['v'] ["verbose"] (NoArg (setoutput Annex.NormalOutput)) - "allow verbose output (default)" - , Option ['j'] ["json"] (NoArg (setoutput Annex.JSONOutput)) - "enable JSON output" - , Option ['d'] ["debug"] (NoArg (setdebug)) - "show debug messages" - , Option ['b'] ["backend"] (ReqArg setforcebackend paramName) - "specify key-value backend to use" - ] - where - setforce v = Annex.changeState $ \s -> s { Annex.force = v } - setfast v = Annex.changeState $ \s -> s { Annex.fast = v } - setauto v = Annex.changeState $ \s -> s { Annex.auto = v } - setoutput v = Annex.changeState $ \s -> s { Annex.output = v } - setforcebackend v = Annex.changeState $ \s -> s { Annex.forcebackend = Just v } - setdebug = liftIO $ updateGlobalLogger rootLoggerName $ - setLevel DEBUG - -matcherOptions :: [Option] -matcherOptions = - [ longopt "not" "negate next option" - , longopt "and" "both previous and next option must match" - , longopt "or" "either previous or next option must match" - , shortopt "(" "open group of options" - , shortopt ")" "close group of options" - ] - where - longopt o = Option [] [o] $ NoArg $ addToken o - shortopt o = Option o [] $ NoArg $ addToken o - -{- An option that sets a flag. -} -flagOption :: String -> String -> String -> Option -flagOption short flag description = - Option short [flag] (NoArg (Annex.setFlag flag)) description - -{- An option that sets a field. -} -fieldOption :: String -> String -> String -> String -> Option -fieldOption short field paramdesc description = - Option short [field] (ReqArg (Annex.setField field) paramdesc) description diff --git a/Seek.hs b/Seek.hs index 53101b23e..fdb117de0 100644 --- a/Seek.hs +++ b/Seek.hs @@ -20,6 +20,7 @@ import qualified Git import qualified Git.LsFiles as LsFiles import qualified Git.CheckAttr import qualified Limit +import qualified Option seekHelper :: ([FilePath] -> Git.Repo -> IO [FilePath]) -> [FilePath] -> Annex [FilePath] seekHelper a params = do @@ -87,13 +88,13 @@ withKeys a params = return $ map (a . parse) params where parse p = fromMaybe (error "bad key") $ readKey p -{- Modifies a seek action using the value of a field, which is fed into +{- Modifies a seek action using the value of a field option, which is fed into - a conversion function, and then is passed into the seek action. - This ensures that the conversion function only runs once. -} -withField :: String -> (Maybe String -> Annex a) -> (a -> CommandSeek) -> CommandSeek -withField field converter a ps = do - f <- converter =<< Annex.getField field +withField :: Option -> (Maybe String -> Annex a) -> (a -> CommandSeek) -> CommandSeek +withField option converter a ps = do + f <- converter =<< Annex.getField (Option.name option) a f ps withNothing :: CommandStart -> CommandSeek diff --git a/Types.hs b/Types.hs index c8839b7eb..4c16fb8f4 100644 --- a/Types.hs +++ b/Types.hs @@ -11,7 +11,8 @@ module Types ( Key, UUID(..), Remote, - RemoteType + RemoteType, + Option ) where import Annex @@ -19,6 +20,7 @@ import Types.Backend import Types.Key import Types.UUID import Types.Remote +import Types.Option type Backend = BackendA Annex type Remote = RemoteA Annex diff --git a/Types/Command.hs b/Types/Command.hs index b173b61c9..1233df2cd 100644 --- a/Types/Command.hs +++ b/Types/Command.hs @@ -8,7 +8,6 @@ module Types.Command where import Types -import Types.Option {- A command runs in these stages. - diff --git a/git-annex-shell.hs b/git-annex-shell.hs index 1ff0bba44..4fdeae1a8 100644 --- a/git-annex-shell.hs +++ b/git-annex-shell.hs @@ -13,6 +13,7 @@ import qualified Git.Construct import CmdLine import Command import Annex.UUID +import qualified Option import qualified Command.ConfigList import qualified Command.InAnnex @@ -41,7 +42,7 @@ cmds = map adddirparam $ cmds_readonly ++ cmds_notreadonly } options :: [OptDescr (Annex ())] -options = commonOptions ++ +options = Option.common ++ [ Option [] ["uuid"] (ReqArg checkuuid paramUUID) "repository uuid" ] where -- cgit v1.2.3 From a3a9f87047d27306c27f4108ee58af3365f284af Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 6 Jan 2012 15:40:04 -0400 Subject: log: New command that displays the location log for file, showing each repository they were added to and removed from. This needs to run git log on the location log files to get at all past versions of the file, which tends to be a bit slow. It would be possible to make a version optimised for showing the location logs for every key. That would only need to run git log once, so would be faster, but it would need to process an enormous amount of data, so would not speed up the individual file case. In the future it would be nice to support log --format. log --json also doesn't work right yet. --- Annex/Branch.hs | 1 + Command/Log.hs | 94 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ GitAnnex.hs | 2 ++ Logs/Presence.hs | 7 +++- debian/changelog | 2 ++ debian/copyright | 2 +- doc/git-annex.mdwn | 5 +++ 7 files changed, 111 insertions(+), 2 deletions(-) create mode 100644 Command/Log.hs diff --git a/Annex/Branch.hs b/Annex/Branch.hs index d3a81d8e5..8f07b7aa2 100644 --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -6,6 +6,7 @@ -} module Annex.Branch ( + fullname, name, hasOrigin, hasSibling, diff --git a/Command/Log.hs b/Command/Log.hs new file mode 100644 index 000000000..486efdf11 --- /dev/null +++ b/Command/Log.hs @@ -0,0 +1,94 @@ +{- git-annex command + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.Log where + +import qualified Data.Set as S +import qualified Data.ByteString.Lazy.Char8 as L +import Data.Time.Clock.POSIX +import Data.Time +import System.Locale +import Data.Char + +import Common.Annex +import Command +import qualified Logs.Location +import qualified Logs.Presence +import Annex.CatFile +import qualified Annex.Branch +import qualified Git +import Git.Command +import qualified Remote + +def :: [Command] +def = [command "log" paramPaths seek "shows location log"] + +seek :: [CommandSeek] +seek = [withFilesInGit $ whenAnnexed $ start] + +start :: FilePath -> (Key, Backend) -> CommandStart +start file (key, _) = do + showStart file "" + liftIO $ putStrLn "" + showLog =<< readLog key + stop + +showLog :: [(POSIXTime, Git.Ref)] -> Annex () +showLog v = go Nothing v =<< (liftIO getCurrentTimeZone) + where + go new [] zone = diff S.empty new zone + go new ((ts, ref):ls) zone = do + cur <- S.fromList <$> get ref + diff cur new zone + go (Just (ts, cur)) ls zone + get ref = map toUUID . Logs.Presence.getLog . L.unpack <$> + catObject ref + diff _ Nothing _ = return () + diff cur (Just (ts, new)) zone = do + let time = show $ utcToLocalTime zone $ + posixSecondsToUTCTime ts + output time True added + output time False removed + where + added = S.difference new cur + removed = S.difference cur new + output time present s = do + rs <- map (dropWhile isSpace) . lines <$> + Remote.prettyPrintUUIDs "log" (S.toList s) + liftIO $ mapM_ (putStrLn . indent . format) rs + where + format r = unwords + [ time + , if present then "+" else "-" + , r + ] + +getLog :: Key -> Annex [String] +getLog key = do + top <- fromRepo Git.workTree + p <- liftIO $ relPathCwdToFile top + let logfile = p Logs.Location.logFile key + inRepo $ pipeNullSplit + [ Params "log -z --pretty=format:%ct --raw --abbrev=40" + , Param $ show Annex.Branch.fullname + , Param "--" + , Param logfile + ] + +readLog :: Key -> Annex [(POSIXTime, Git.Ref)] +readLog key = mapMaybe (parse . lines) <$> getLog key + where + parse (ts:raw:[]) = Just (parseTimeStamp ts, parseRaw raw) + parse _ = Nothing + +-- Parses something like ":100644 100644 oldsha newsha M" +parseRaw :: String -> Git.Ref +parseRaw l = Git.Ref $ words l !! 3 + +parseTimeStamp :: String -> POSIXTime +parseTimeStamp = utcTimeToPOSIXSeconds . fromMaybe (error "bad timestamp") . + parseTime defaultTimeLocale "%s" diff --git a/GitAnnex.hs b/GitAnnex.hs index 64020754f..78f20e9d1 100644 --- a/GitAnnex.hs +++ b/GitAnnex.hs @@ -41,6 +41,7 @@ import qualified Command.Lock import qualified Command.PreCommit import qualified Command.Find import qualified Command.Whereis +import qualified Command.Log import qualified Command.Merge import qualified Command.Status import qualified Command.Migrate @@ -85,6 +86,7 @@ cmds = concat , Command.DropUnused.def , Command.Find.def , Command.Whereis.def + , Command.Log.def , Command.Merge.def , Command.Status.def , Command.Migrate.def diff --git a/Logs/Presence.hs b/Logs/Presence.hs index f5e4f1ea9..372af37d5 100644 --- a/Logs/Presence.hs +++ b/Logs/Presence.hs @@ -13,14 +13,15 @@ module Logs.Presence ( LogStatus(..), + LogLine, addLog, readLog, + getLog, parseLog, showLog, logNow, compactLog, currentLog, - LogLine ) where import Data.Time.Clock.POSIX @@ -80,6 +81,10 @@ logNow s i = do currentLog :: FilePath -> Annex [String] currentLog file = map info . filterPresent <$> readLog file +{- Given a log, returns only the info that is are still in effect. -} +getLog :: String -> [String] +getLog = map info . filterPresent . parseLog + {- Returns the info from LogLines that are in effect. -} filterPresent :: [LogLine] -> [LogLine] filterPresent = filter (\l -> InfoPresent == status l) . compactLog diff --git a/debian/changelog b/debian/changelog index e5687aac1..707e804af 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,6 +1,8 @@ git-annex (3.20120106) UNRELEASED; urgency=low * Support unescaped repository urls, like git does. + * log: New command that displays the location log for file, + showing each repository they were added to and removed from. -- Joey Hess Thu, 05 Jan 2012 14:29:30 -0400 diff --git a/debian/copyright b/debian/copyright index a8a38913e..dd880f142 100644 --- a/debian/copyright +++ b/debian/copyright @@ -2,7 +2,7 @@ Format: http://dep.debian.net/deps/dep5/ Source: native package Files: * -Copyright: © 2010-2011 Joey Hess +Copyright: © 2010-2012 Joey Hess License: GPL-3+ The full text of version 3 of the GPL is distributed as doc/GPL in this package's source, or in /usr/share/common-licenses/GPL-3 on diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn index 9751560a9..87775ead9 100644 --- a/doc/git-annex.mdwn +++ b/doc/git-annex.mdwn @@ -273,6 +273,11 @@ subdirectories). Displays a list of repositories known to contain the content of the specified file or files. +* log [path ...] + + Displays the location log for the specified file or files, + showing each repository they were added to ("+") and removed from ("-"). + * status Displays some statistics and other information, including how much data -- cgit v1.2.3 From 47646d44b7a391d9439998ba34498f2fb74b4259 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 6 Jan 2012 16:24:40 -0400 Subject: use a zipper --- Command/Log.hs | 23 ++++++++++++----------- 1 file changed, 12 insertions(+), 11 deletions(-) diff --git a/Command/Log.hs b/Command/Log.hs index 486efdf11..3489c5ab0 100644 --- a/Command/Log.hs +++ b/Command/Log.hs @@ -33,29 +33,30 @@ seek = [withFilesInGit $ whenAnnexed $ start] start :: FilePath -> (Key, Backend) -> CommandStart start file (key, _) = do showStart file "" - liftIO $ putStrLn "" showLog =<< readLog key stop showLog :: [(POSIXTime, Git.Ref)] -> Annex () -showLog v = go Nothing v =<< (liftIO getCurrentTimeZone) +showLog ps = do + zone <- liftIO getCurrentTimeZone + sets <- mapM getset ps + liftIO $ putStrLn "" + mapM_ (diff zone) $ zip sets (drop 1 sets ++ genesis) where - go new [] zone = diff S.empty new zone - go new ((ts, ref):ls) zone = do - cur <- S.fromList <$> get ref - diff cur new zone - go (Just (ts, cur)) ls zone + genesis = [(0, S.empty)] + getset (ts, ref) = do + s <- S.fromList <$> get ref + return (ts, s) get ref = map toUUID . Logs.Presence.getLog . L.unpack <$> catObject ref - diff _ Nothing _ = return () - diff cur (Just (ts, new)) zone = do + diff zone ((ts, new), (_, old)) = do let time = show $ utcToLocalTime zone $ posixSecondsToUTCTime ts output time True added output time False removed where - added = S.difference new cur - removed = S.difference cur new + added = S.difference new old + removed = S.difference old new output time present s = do rs <- map (dropWhile isSpace) . lines <$> Remote.prettyPrintUUIDs "log" (S.toList s) -- cgit v1.2.3 From 9fb5f3edc7e0aec79e38cf588b66e66e4a2bdd3c Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 6 Jan 2012 17:24:03 -0400 Subject: log --after=date --- Command/Log.hs | 54 +++++++++++++++++++++++++++++++++++------------------- Git/Sha.hs | 3 +++ Git/UnionMerge.hs | 3 +-- Usage.hs | 2 ++ doc/git-annex.mdwn | 3 +++ 5 files changed, 44 insertions(+), 21 deletions(-) diff --git a/Command/Log.hs b/Command/Log.hs index 3489c5ab0..51bdbc74c 100644 --- a/Command/Log.hs +++ b/Command/Log.hs @@ -23,29 +23,39 @@ import qualified Annex.Branch import qualified Git import Git.Command import qualified Remote +import qualified Option def :: [Command] -def = [command "log" paramPaths seek "shows location log"] +def = [withOptions [afterOption] $ + command "log" paramPaths seek "shows location log"] + +afterOption :: Option +afterOption = Option.field [] "after" paramDate "show log after date" seek :: [CommandSeek] -seek = [withFilesInGit $ whenAnnexed $ start] +seek = [withField afterOption return $ \afteropt -> + withFilesInGit $ whenAnnexed $ start afteropt] -start :: FilePath -> (Key, Backend) -> CommandStart -start file (key, _) = do +start :: Maybe String -> FilePath -> (Key, Backend) -> CommandStart +start afteropt file (key, _) = do showStart file "" - showLog =<< readLog key + let ps = case afteropt of + Nothing -> [] + Just date -> [Param "--after", Param date] + showLog =<< (readLog <$> getLog key ps) stop -showLog :: [(POSIXTime, Git.Ref)] -> Annex () +showLog :: [(POSIXTime, (Git.Ref, Git.Ref))] -> Annex () showLog ps = do zone <- liftIO getCurrentTimeZone - sets <- mapM getset ps + sets <- mapM (getset snd) ps + previous <- maybe (return genesis) (getset fst) (lastMaybe ps) liftIO $ putStrLn "" - mapM_ (diff zone) $ zip sets (drop 1 sets ++ genesis) + mapM_ (diff zone) $ zip sets (drop 1 sets ++ [previous]) where - genesis = [(0, S.empty)] - getset (ts, ref) = do - s <- S.fromList <$> get ref + genesis = (0, S.empty) + getset select (ts, refs) = do + s <- S.fromList <$> get (select refs) return (ts, s) get ref = map toUUID . Logs.Presence.getLog . L.unpack <$> catObject ref @@ -68,27 +78,33 @@ showLog ps = do , r ] -getLog :: Key -> Annex [String] -getLog key = do +getLog :: Key -> [CommandParam] -> Annex [String] +getLog key ps = do top <- fromRepo Git.workTree p <- liftIO $ relPathCwdToFile top let logfile = p Logs.Location.logFile key - inRepo $ pipeNullSplit + inRepo $ pipeNullSplit $ [ Params "log -z --pretty=format:%ct --raw --abbrev=40" - , Param $ show Annex.Branch.fullname + , Param "--boundary" + ] ++ ps ++ + [ Param $ show Annex.Branch.fullname , Param "--" , Param logfile ] -readLog :: Key -> Annex [(POSIXTime, Git.Ref)] -readLog key = mapMaybe (parse . lines) <$> getLog key +readLog :: [String] -> [(POSIXTime, (Git.Ref, Git.Ref))] +readLog = mapMaybe (parse . lines) where parse (ts:raw:[]) = Just (parseTimeStamp ts, parseRaw raw) parse _ = Nothing -- Parses something like ":100644 100644 oldsha newsha M" -parseRaw :: String -> Git.Ref -parseRaw l = Git.Ref $ words l !! 3 +parseRaw :: String -> (Git.Ref, Git.Ref) +parseRaw l = (Git.Ref oldsha, Git.Ref newsha) + where + ws = words l + oldsha = ws !! 2 + newsha = ws !! 3 parseTimeStamp :: String -> POSIXTime parseTimeStamp = utcTimeToPOSIXSeconds . fromMaybe (error "bad timestamp") . diff --git a/Git/Sha.hs b/Git/Sha.hs index 9b3a34650..2a01ede83 100644 --- a/Git/Sha.hs +++ b/Git/Sha.hs @@ -34,3 +34,6 @@ extractSha s {- Size of a git sha. -} shaSize :: Int shaSize = 40 + +nullSha :: Ref +nullSha = Ref $ replicate shaSize '0' diff --git a/Git/UnionMerge.hs b/Git/UnionMerge.hs index d5323af1d..4b335e47b 100644 --- a/Git/UnionMerge.hs +++ b/Git/UnionMerge.hs @@ -103,14 +103,13 @@ calc_merge ch differ repo streamer = gendiff >>= go - a line suitable for update_index that union merges the two sides of the - diff. -} mergeFile :: String -> FilePath -> CatFileHandle -> Repo -> IO (Maybe String) -mergeFile info file h repo = case filter (/= nullsha) [Ref asha, Ref bsha] of +mergeFile info file h repo = case filter (/= nullSha) [Ref asha, Ref bsha] of [] -> return Nothing (sha:[]) -> use sha shas -> use =<< either return (hashObject repo . L.unlines) =<< calcMerge . zip shas <$> mapM getcontents shas where [_colonmode, _bmode, asha, bsha, _status] = words info - nullsha = Ref $ replicate shaSize '0' getcontents s = L.lines <$> catObject h s use sha = return $ Just $ update_index_line sha file diff --git a/Usage.hs b/Usage.hs index 308ade798..36944053f 100644 --- a/Usage.hs +++ b/Usage.hs @@ -72,6 +72,8 @@ paramUUID :: String paramUUID = "UUID" paramType :: String paramType = "TYPE" +paramDate :: String +paramDate = "Date" paramFormat :: String paramFormat = "FORMAT" paramKeyValue :: String diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn index 87775ead9..b9704f3bd 100644 --- a/doc/git-annex.mdwn +++ b/doc/git-annex.mdwn @@ -278,6 +278,9 @@ subdirectories). Displays the location log for the specified file or files, showing each repository they were added to ("+") and removed from ("-"). + To only show location changes after a date, specify --after=date. + (The "date" can be any format accepted by git log, ie "last wednesday") + * status Displays some statistics and other information, including how much data -- cgit v1.2.3 From 078788a9e755809ac050fd83eb19c4398d7366d7 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 6 Jan 2012 17:30:48 -0400 Subject: change log display Including the file in the lines behaves better when limiting with --after, since only files that changed in the time period are shown. Still not fully happy with the line layout, but putting the +/- first followed by the date seems a good change. --- Command/Log.hs | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/Command/Log.hs b/Command/Log.hs index 51bdbc74c..2651b14be 100644 --- a/Command/Log.hs +++ b/Command/Log.hs @@ -38,19 +38,17 @@ seek = [withField afterOption return $ \afteropt -> start :: Maybe String -> FilePath -> (Key, Backend) -> CommandStart start afteropt file (key, _) = do - showStart file "" let ps = case afteropt of Nothing -> [] Just date -> [Param "--after", Param date] - showLog =<< (readLog <$> getLog key ps) + showLog file =<< (readLog <$> getLog key ps) stop -showLog :: [(POSIXTime, (Git.Ref, Git.Ref))] -> Annex () -showLog ps = do +showLog :: FilePath -> [(POSIXTime, (Git.Ref, Git.Ref))] -> Annex () +showLog file ps = do zone <- liftIO getCurrentTimeZone sets <- mapM (getset snd) ps previous <- maybe (return genesis) (getset fst) (lastMaybe ps) - liftIO $ putStrLn "" mapM_ (diff zone) $ zip sets (drop 1 sets ++ [previous]) where genesis = (0, S.empty) @@ -70,11 +68,13 @@ showLog ps = do output time present s = do rs <- map (dropWhile isSpace) . lines <$> Remote.prettyPrintUUIDs "log" (S.toList s) - liftIO $ mapM_ (putStrLn . indent . format) rs + liftIO $ mapM_ (putStrLn . format) rs where format r = unwords - [ time - , if present then "+" else "-" + [ if present then "+" else "-" + , time + , file + , "|" , r ] -- cgit v1.2.3 From 3c88d573990d79a5a964567c4a16068ef5ecfa0f Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 6 Jan 2012 17:48:02 -0400 Subject: log --max-count=n --- Command/Log.hs | 20 +++++++++++++------- 1 file changed, 13 insertions(+), 7 deletions(-) diff --git a/Command/Log.hs b/Command/Log.hs index 2651b14be..ff217e573 100644 --- a/Command/Log.hs +++ b/Command/Log.hs @@ -26,23 +26,29 @@ import qualified Remote import qualified Option def :: [Command] -def = [withOptions [afterOption] $ +def = [withOptions [afterOption, maxcountOption] $ command "log" paramPaths seek "shows location log"] afterOption :: Option afterOption = Option.field [] "after" paramDate "show log after date" +maxcountOption :: Option +maxcountOption = Option.field ['n'] "max-count" paramNumber "limit number of logs displayed" + seek :: [CommandSeek] seek = [withField afterOption return $ \afteropt -> - withFilesInGit $ whenAnnexed $ start afteropt] + withField maxcountOption return $ \maxcount -> + withFilesInGit $ whenAnnexed $ start afteropt maxcount] -start :: Maybe String -> FilePath -> (Key, Backend) -> CommandStart -start afteropt file (key, _) = do - let ps = case afteropt of - Nothing -> [] - Just date -> [Param "--after", Param date] +start :: Maybe String -> Maybe String -> FilePath -> (Key, Backend) -> CommandStart +start afteropt maxcount file (key, _) = do showLog file =<< (readLog <$> getLog key ps) stop + where + ps = concatMap (\(o, p) -> maybe [] p o) + [ (afteropt, \d -> [Param "--after", Param d]) + , (maxcount, \c -> [Param "--max-count", Param c]) + ] showLog :: FilePath -> [(POSIXTime, (Git.Ref, Git.Ref))] -> Annex () showLog file ps = do -- cgit v1.2.3