diff --git a/Annex/Content.hs b/Annex/Content.hs --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -54,6 +54,7 @@ import Annex.Common import Logs.Location +import Types.Transfer import Logs.Transfer import qualified Git import qualified Annex diff --git a/Annex/Drop.hs b/Annex/Drop.hs --- a/Annex/Drop.hs +++ b/Annex/Drop.hs @@ -117,10 +117,10 @@ ) dropl fs n = checkdrop fs n Nothing $ \numcopies -> - Command.Drop.startLocal afile numcopies key preverified + Command.Drop.startLocal afile (mkActionItem afile) numcopies key preverified dropr fs r n = checkdrop fs n (Just $ Remote.uuid r) $ \numcopies -> - Command.Drop.startRemote afile numcopies key r + Command.Drop.startRemote afile (mkActionItem afile) numcopies key r slocs = S.fromList locs diff --git a/Annex/MetaData.hs b/Annex/MetaData.hs --- a/Annex/MetaData.hs +++ b/Annex/MetaData.hs @@ -63,7 +63,7 @@ Just '+' -> AddMeta <$> mkMetaField f' <*> v Just '-' -> DelMeta <$> mkMetaField f' <*> (Just <$> v) Just '?' -> MaybeSetMeta <$> mkMetaField f' <*> v - _ -> SetMeta <$> mkMetaField f <*> v + _ -> SetMeta <$> mkMetaField f <*> (S.singleton <$> v) where (f, sv) = separate (== '=') p f' = beginning f diff --git a/Annex/Notification.hs b/Annex/Notification.hs --- a/Annex/Notification.hs +++ b/Annex/Notification.hs @@ -10,7 +10,7 @@ module Annex.Notification (NotifyWitness, notifyTransfer, notifyDrop) where import Annex.Common -import Logs.Transfer +import Types.Transfer #ifdef WITH_DBUS_NOTIFICATIONS import qualified Annex import Types.DesktopNotify diff --git a/Annex/Transfer.hs b/Annex/Transfer.hs --- a/Annex/Transfer.hs +++ b/Annex/Transfer.hs @@ -9,7 +9,6 @@ module Annex.Transfer ( module X, - noObserver, upload, download, runTransfer, @@ -20,6 +19,7 @@ import Annex.Common import Logs.Transfer as X +import Types.Transfer as X import Annex.Notification as X import Annex.Perms import Utility.Metered @@ -28,8 +28,6 @@ import Control.Concurrent -type TransferObserver = Bool -> Transfer -> TransferInfo -> Annex () - class Observable a where observeBool :: a -> Bool observeFailure :: a @@ -42,16 +40,13 @@ observeBool = fst observeFailure = (False, UnVerified) -noObserver :: TransferObserver -noObserver _ _ _ = noop - -upload :: Observable v => UUID -> Key -> AssociatedFile -> RetryDecider -> TransferObserver -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v -upload u key f d o a _witness = guardHaveUUID u $ - runTransfer (Transfer Upload u key) f d o a +upload :: Observable v => UUID -> Key -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v +upload u key f d a _witness = guardHaveUUID u $ + runTransfer (Transfer Upload u key) f d a -download :: Observable v => UUID -> Key -> AssociatedFile -> RetryDecider -> TransferObserver -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v -download u key f d o a _witness = guardHaveUUID u $ - runTransfer (Transfer Download u key) f d o a +download :: Observable v => UUID -> Key -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v +download u key f d a _witness = guardHaveUUID u $ + runTransfer (Transfer Download u key) f d a guardHaveUUID :: Observable v => UUID -> Annex v -> Annex v guardHaveUUID u a @@ -70,7 +65,7 @@ - An upload can be run from a read-only filesystem, and in this case - no transfer information or lock file is used. -} -runTransfer :: Observable v => Transfer -> Maybe FilePath -> RetryDecider -> TransferObserver -> (MeterUpdate -> Annex v) -> Annex v +runTransfer :: Observable v => Transfer -> Maybe FilePath -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v runTransfer = runTransfer' False {- Like runTransfer, but ignores any existing transfer lock file for the @@ -78,11 +73,11 @@ - - Note that this may result in confusing progress meter display in the - webapp, if multiple processes are writing to the transfer info file. -} -alwaysRunTransfer :: Observable v => Transfer -> Maybe FilePath -> RetryDecider -> TransferObserver -> (MeterUpdate -> Annex v) -> Annex v +alwaysRunTransfer :: Observable v => Transfer -> Maybe FilePath -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v alwaysRunTransfer = runTransfer' True -runTransfer' :: Observable v => Bool -> Transfer -> Maybe FilePath -> RetryDecider -> TransferObserver -> (MeterUpdate -> Annex v) -> Annex v -runTransfer' ignorelock t file shouldretry transferobserver transferaction = do +runTransfer' :: Observable v => Bool -> Transfer -> Maybe FilePath -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v +runTransfer' ignorelock t file shouldretry transferaction = do info <- liftIO $ startTransferInfo file (meter, tfile, metervar) <- mkProgressUpdater t info mode <- annexFileMode @@ -94,7 +89,9 @@ else do v <- retry info metervar $ transferaction meter liftIO $ cleanup tfile lck - transferobserver (observeBool v) t info + if observeBool v + then removeFailedTransfer t + else recordFailedTransfer t info return v where #ifndef mingw32_HOST_OS diff --git a/Annex/UUID.hs b/Annex/UUID.hs --- a/Annex/UUID.hs +++ b/Annex/UUID.hs @@ -35,8 +35,8 @@ import Config import qualified Data.UUID as U +import qualified Data.UUID.V4 as U4 import qualified Data.UUID.V5 as U5 -import System.Random import Data.Bits.Utils configkey :: ConfigKey @@ -44,7 +44,7 @@ {- Generates a random UUID, that does not include the MAC address. -} genUUID :: IO UUID -genUUID = UUID . show <$> (randomIO :: IO U.UUID) +genUUID = UUID . show <$> U4.nextRandom {- Generates a UUID from a given string, using a namespace. - Given the same namespace, the same string will always result diff --git a/Assistant/Alert.hs b/Assistant/Alert.hs --- a/Assistant/Alert.hs +++ b/Assistant/Alert.hs @@ -14,7 +14,7 @@ import Assistant.Alert.Utility import qualified Remote import Utility.Tense -import Logs.Transfer +import Types.Transfer import Types.Distribution import Git.Types (RemoteName) diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs --- a/Assistant/DaemonStatus.hs +++ b/Assistant/DaemonStatus.hs @@ -14,6 +14,7 @@ import Utility.Tmp import Assistant.Types.NetMessager import Utility.NotificationBroadcaster +import Types.Transfer import Logs.Transfer import Logs.Trust import Logs.TimeStamp diff --git a/Assistant/DeleteRemote.hs b/Assistant/DeleteRemote.hs --- a/Assistant/DeleteRemote.hs +++ b/Assistant/DeleteRemote.hs @@ -12,7 +12,7 @@ import Assistant.Common import Assistant.Types.UrlRenderer import Assistant.TransferQueue -import Logs.Transfer +import Types.Transfer import Logs.Location import Assistant.DaemonStatus import qualified Remote diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs --- a/Assistant/Sync.hs +++ b/Assistant/Sync.hs @@ -36,7 +36,7 @@ import Assistant.TransferSlots import Assistant.TransferQueue import Assistant.RepoProblem -import Logs.Transfer +import Types.Transfer import Data.Time.Clock import qualified Data.Map as M diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs --- a/Assistant/Threads/Committer.hs +++ b/Assistant/Threads/Committer.hs @@ -17,7 +17,7 @@ import Assistant.DaemonStatus import Assistant.TransferQueue import Assistant.Drop -import Logs.Transfer +import Types.Transfer import Logs.Location import qualified Annex.Queue import qualified Git.LsFiles diff --git a/Assistant/Threads/Cronner.hs b/Assistant/Threads/Cronner.hs --- a/Assistant/Threads/Cronner.hs +++ b/Assistant/Threads/Cronner.hs @@ -24,7 +24,7 @@ import Utility.Batch import Assistant.TransferQueue import Annex.Content -import Logs.Transfer +import Types.Transfer import Assistant.Types.UrlRenderer import Assistant.Alert import Remote diff --git a/Assistant/Threads/Glacier.hs b/Assistant/Threads/Glacier.hs --- a/Assistant/Threads/Glacier.hs +++ b/Assistant/Threads/Glacier.hs @@ -14,6 +14,7 @@ import Utility.ThreadScheduler import qualified Types.Remote as Remote import qualified Remote.Glacier as Glacier +import Types.Transfer import Logs.Transfer import Assistant.DaemonStatus import Assistant.TransferQueue diff --git a/Assistant/Threads/SanityChecker.hs b/Assistant/Threads/SanityChecker.hs --- a/Assistant/Threads/SanityChecker.hs +++ b/Assistant/Threads/SanityChecker.hs @@ -38,7 +38,7 @@ import Git.Index import Assistant.Unused import Logs.Unused -import Logs.Transfer +import Types.Transfer import Annex.Path import qualified Annex #ifdef WITH_WEBAPP diff --git a/Assistant/Threads/TransferPoller.hs b/Assistant/Threads/TransferPoller.hs --- a/Assistant/Threads/TransferPoller.hs +++ b/Assistant/Threads/TransferPoller.hs @@ -9,6 +9,7 @@ import Assistant.Common import Assistant.DaemonStatus +import Types.Transfer import Logs.Transfer import Utility.NotificationBroadcaster import qualified Assistant.Threads.TransferWatcher as TransferWatcher diff --git a/Assistant/Threads/TransferScanner.hs b/Assistant/Threads/TransferScanner.hs --- a/Assistant/Threads/TransferScanner.hs +++ b/Assistant/Threads/TransferScanner.hs @@ -16,6 +16,7 @@ import Assistant.Sync import Assistant.DeleteRemote import Assistant.Types.UrlRenderer +import Types.Transfer import Logs.Transfer import Logs.Location import Logs.Group diff --git a/Assistant/Threads/TransferWatcher.hs b/Assistant/Threads/TransferWatcher.hs --- a/Assistant/Threads/TransferWatcher.hs +++ b/Assistant/Threads/TransferWatcher.hs @@ -10,6 +10,7 @@ import Assistant.Common import Assistant.DaemonStatus import Assistant.TransferSlots +import Types.Transfer import Logs.Transfer import Utility.DirWatcher import Utility.DirWatcher.Types diff --git a/Assistant/Threads/Transferrer.hs b/Assistant/Threads/Transferrer.hs --- a/Assistant/Threads/Transferrer.hs +++ b/Assistant/Threads/Transferrer.hs @@ -10,7 +10,7 @@ import Assistant.Common import Assistant.TransferQueue import Assistant.TransferSlots -import Logs.Transfer +import Types.Transfer import Annex.Path import Utility.Batch diff --git a/Assistant/TransferQueue.hs b/Assistant/TransferQueue.hs --- a/Assistant/TransferQueue.hs +++ b/Assistant/TransferQueue.hs @@ -26,6 +26,7 @@ import Assistant.Common import Assistant.DaemonStatus import Assistant.Types.TransferQueue +import Types.Transfer import Logs.Transfer import Types.Remote import qualified Remote diff --git a/Assistant/TransferSlots.hs b/Assistant/TransferSlots.hs --- a/Assistant/TransferSlots.hs +++ b/Assistant/TransferSlots.hs @@ -21,6 +21,7 @@ import Assistant.Alert.Utility import Assistant.Commits import Assistant.Drop +import Types.Transfer import Logs.Transfer import Logs.Location import qualified Git diff --git a/Assistant/TransferrerPool.hs b/Assistant/TransferrerPool.hs --- a/Assistant/TransferrerPool.hs +++ b/Assistant/TransferrerPool.hs @@ -9,7 +9,7 @@ import Assistant.Common import Assistant.Types.TransferrerPool -import Logs.Transfer +import Types.Transfer import Utility.Batch import qualified Command.TransferKeys as T diff --git a/Assistant/Types/DaemonStatus.hs b/Assistant/Types/DaemonStatus.hs --- a/Assistant/Types/DaemonStatus.hs +++ b/Assistant/Types/DaemonStatus.hs @@ -10,7 +10,7 @@ import Annex.Common import Assistant.Pairing import Utility.NotificationBroadcaster -import Logs.Transfer +import Types.Transfer import Assistant.Types.ThreadName import Assistant.Types.NetMessager import Assistant.Types.Alert diff --git a/Assistant/Types/TransferQueue.hs b/Assistant/Types/TransferQueue.hs --- a/Assistant/Types/TransferQueue.hs +++ b/Assistant/Types/TransferQueue.hs @@ -8,7 +8,7 @@ module Assistant.Types.TransferQueue where import Annex.Common -import Logs.Transfer +import Types.Transfer import Control.Concurrent.STM import Utility.TList diff --git a/Assistant/Upgrade.hs b/Assistant/Upgrade.hs --- a/Assistant/Upgrade.hs +++ b/Assistant/Upgrade.hs @@ -16,7 +16,7 @@ import Assistant.DaemonStatus import Utility.Env import Types.Distribution -import Logs.Transfer +import Types.Transfer import Logs.Web import Logs.Presence import Logs.Location diff --git a/Assistant/WebApp/DashBoard.hs b/Assistant/WebApp/DashBoard.hs --- a/Assistant/WebApp/DashBoard.hs +++ b/Assistant/WebApp/DashBoard.hs @@ -16,6 +16,7 @@ import Assistant.TransferSlots import Assistant.DaemonStatus import Utility.NotificationBroadcaster +import Types.Transfer import Logs.Transfer import Utility.Percentage import Utility.DataUnits diff --git a/Assistant/WebApp/Types.hs b/Assistant/WebApp/Types.hs --- a/Assistant/WebApp/Types.hs +++ b/Assistant/WebApp/Types.hs @@ -19,7 +19,7 @@ import Utility.NotificationBroadcaster import Utility.WebApp import Utility.Yesod -import Logs.Transfer +import Types.Transfer import Utility.Gpg (KeyId) import Build.SysConfig (packageversion) import Types.ScheduledActivity diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,33 @@ +git-annex (6.20160808) unstable; urgency=medium + + * metadata --json output format has changed, adding a inner json object + named "fields" which contains only the fields and their values. + This should be easier to parse than the old format, which mixed up + metadata fields with other keys in the json object. + Any consumers of the old format will need to be updated. + * Added metadata --batch option, which allows getting, setting, deleting, + and modifying metadata for multiple files/keys. + * Added --branch option to copy, drop, fsck, get, metadata, mirror, move, + and whereis commands. This option makes git-annex operate on files that + are included in a specified branch (or other treeish). + * git-annex.cabal: Temporarily limit to http-conduit <2.2.0 + since aws 0.14.0 is not compatible with the newer version. + * git-annex.cabal: Temporarily limit to persistent <2.5 + since esqueleto 2.4.3 is not compatible with the newer version. + * Removed dependency on json library; all JSON is now handled by aeson. + * When built with uuid-1.3.12, generate more random UUIDs than before. + (However, this did not impact git-annex much, so a hard depedency has + not been added on uuid-1.3.12.) + * info: When run on a file now includes an indication of whether + the content is present locally. + * get, move, copy, mirror: Added --failed switch which retries + failed copies/moves. + * Re-enable accumulating transfer failure log files for command-line + actions (disabled in 5.20150522), and remove the log files after + successful transfers. + + -- Joey Hess Mon, 08 Aug 2016 11:42:17 -0400 + git-annex (6.20160619) unstable; urgency=medium * get, drop: Add --batch and --json options. diff --git a/CmdLine/Action.hs b/CmdLine/Action.hs --- a/CmdLine/Action.hs +++ b/CmdLine/Action.hs @@ -14,7 +14,6 @@ import Annex.Concurrent import Types.Command import Messages.Concurrent -import Messages.Internal import Types.Messages import Control.Concurrent.Async diff --git a/CmdLine/GitAnnex/Options.hs b/CmdLine/GitAnnex/Options.hs --- a/CmdLine/GitAnnex/Options.hs +++ b/CmdLine/GitAnnex/Options.hs @@ -139,27 +139,37 @@ data KeyOptions = WantAllKeys | WantUnusedKeys + | WantFailedTransfers | WantSpecificKey Key | WantIncompleteKeys + | WantBranchKeys [Branch] -parseKeyOptions :: Bool -> Parser KeyOptions -parseKeyOptions allowincomplete = if allowincomplete - then base - <|> flag' WantIncompleteKeys - ( long "incomplete" - <> help "resume previous downloads" - ) - else base - where - base = parseAllOption - <|> flag' WantUnusedKeys - ( long "unused" <> short 'U' - <> help "operate on files found by last run of git-annex unused" - ) - <|> (WantSpecificKey <$> option (str >>= parseKey) - ( long "key" <> metavar paramKey - <> help "operate on specified key" - )) +parseKeyOptions :: Parser KeyOptions +parseKeyOptions = parseAllOption + <|> WantBranchKeys <$> some (option (str >>= pure . Ref) + ( long "branch" <> metavar paramRef + <> help "operate on files in the specified branch or treeish" + )) + <|> flag' WantUnusedKeys + ( long "unused" <> short 'U' + <> help "operate on files found by last run of git-annex unused" + ) + <|> (WantSpecificKey <$> option (str >>= parseKey) + ( long "key" <> metavar paramKey + <> help "operate on specified key" + )) + +parseFailedTransfersOption :: Parser KeyOptions +parseFailedTransfersOption = flag' WantFailedTransfers + ( long "failed" + <> help "operate on files that recently failed to be transferred" + ) + +parseIncompleteOption :: Parser KeyOptions +parseIncompleteOption = flag' WantIncompleteKeys + ( long "incomplete" + <> help "resume previous downloads" + ) parseAllOption :: Parser KeyOptions parseAllOption = flag' WantAllKeys diff --git a/CmdLine/Seek.hs b/CmdLine/Seek.hs --- a/CmdLine/Seek.hs +++ b/CmdLine/Seek.hs @@ -4,7 +4,7 @@ - the values a user passes to a command, and prepare actions operating - on them. - - - Copyright 2010-2015 Joey Hess + - Copyright 2010-2016 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -25,6 +25,10 @@ import CmdLine.Action import Logs.Location import Logs.Unused +import Types.Transfer +import Logs.Transfer +import Remote.List +import qualified Remote import Annex.CatFile import Annex.Content @@ -154,42 +158,77 @@ withNothing a [] = seekActions $ return [a] withNothing _ _ = error "This command takes no parameters." -{- Handles the --all, --unused, --key, and --incomplete options, - - which specify particular keys to run an action on. +{- Handles the --all, --branch, --unused, --failed, --key, and + - --incomplete options, which specify particular keys to run an + - action on. - - In a bare repo, --all is the default. - - Otherwise falls back to a regular CommandSeek action on - whatever params were passed. -} -withKeyOptions :: Maybe KeyOptions -> Bool -> (Key -> CommandStart) -> (CmdParams -> CommandSeek) -> CmdParams -> CommandSeek -withKeyOptions ko auto keyaction = withKeyOptions' ko auto $ \getkeys -> do - matcher <- Limit.getMatcher - seekActions $ map (process matcher) <$> getkeys +withKeyOptions + :: Maybe KeyOptions + -> Bool + -> (Key -> ActionItem -> CommandStart) + -> (CmdParams -> CommandSeek) + -> CmdParams + -> CommandSeek +withKeyOptions ko auto keyaction = withKeyOptions' ko auto mkkeyaction where - process matcher k = ifM (matcher $ MatchingKey k) - ( keyaction k - , return Nothing - ) + mkkeyaction = do + matcher <- Limit.getMatcher + return $ \k i -> + whenM (matcher $ MatchingKey k) $ + commandAction $ keyaction k i -withKeyOptions' :: Maybe KeyOptions -> Bool -> (Annex [Key] -> Annex ()) -> (CmdParams -> CommandSeek) -> CmdParams -> CommandSeek -withKeyOptions' ko auto keyaction fallbackaction params = do +withKeyOptions' + :: Maybe KeyOptions + -> Bool + -> Annex (Key -> ActionItem -> Annex ()) + -> (CmdParams -> CommandSeek) + -> CmdParams + -> CommandSeek +withKeyOptions' ko auto mkkeyaction fallbackaction params = do bare <- fromRepo Git.repoIsLocalBare when (auto && bare) $ error "Cannot use --auto in a bare repository" case (null params, ko) of (True, Nothing) - | bare -> go auto loggedKeys + | bare -> noauto $ runkeyaction loggedKeys | otherwise -> fallbackaction params (False, Nothing) -> fallbackaction params - (True, Just WantAllKeys) -> go auto loggedKeys - (True, Just WantUnusedKeys) -> go auto unusedKeys' - (True, Just (WantSpecificKey k)) -> go auto $ return [k] - (True, Just WantIncompleteKeys) -> go auto incompletekeys - (False, Just _) -> error "Can only specify one of file names, --all, --unused, --key, or --incomplete" + (True, Just WantAllKeys) -> noauto $ runkeyaction loggedKeys + (True, Just WantUnusedKeys) -> noauto $ runkeyaction unusedKeys' + (True, Just WantFailedTransfers) -> noauto runfailedtransfers + (True, Just (WantSpecificKey k)) -> noauto $ runkeyaction (return [k]) + (True, Just WantIncompleteKeys) -> noauto $ runkeyaction incompletekeys + (True, Just (WantBranchKeys bs)) -> noauto $ runbranchkeys bs + (False, Just _) -> error "Can only specify one of file names, --all, --branch, --unused, --failed, --key, or --incomplete" where - go True _ = error "Cannot use --auto with --all or --unused or --key or --incomplete" - go False getkeys = keyaction getkeys + noauto a + | auto = error "Cannot use --auto with --all or --branch or --unused or --key or --incomplete" + | otherwise = a incompletekeys = staleKeysPrune gitAnnexTmpObjectDir True + runkeyaction getks = do + keyaction <- mkkeyaction + ks <- getks + forM_ ks $ \k -> keyaction k (mkActionItem k) + runbranchkeys bs = do + keyaction <- mkkeyaction + forM_ bs $ \b -> do + (l, cleanup) <- inRepo $ LsTree.lsTree b + forM_ l $ \i -> do + let bfp = mkActionItem $ BranchFilePath b (LsTree.file i) + maybe noop (\k -> keyaction k bfp) + =<< catKey (LsTree.sha i) + unlessM (liftIO cleanup) $ + error ("git ls-tree " ++ Git.fromRef b ++ " failed") + runfailedtransfers = do + keyaction <- mkkeyaction + rs <- remoteList + ts <- concat <$> mapM (getFailedTransfers . Remote.uuid) rs + forM_ ts $ \(t, i) -> + keyaction (transferKey t) (mkActionItem (t, i)) prepFiltered :: (FilePath -> CommandStart) -> Annex [FilePath] -> Annex [CommandStart] prepFiltered a fs = do @@ -200,9 +239,7 @@ ( a f , return Nothing ) seekActions :: Annex [CommandStart] -> Annex () -seekActions gen = do - as <- gen - mapM_ commandAction as +seekActions gen = mapM_ commandAction =<< gen seekHelper :: ([FilePath] -> Git.Repo -> IO ([FilePath], IO Bool)) -> [FilePath] -> Annex [FilePath] seekHelper a params = do diff --git a/Command.hs b/Command.hs --- a/Command.hs +++ b/Command.hs @@ -1,6 +1,6 @@ {- git-annex command infrastructure - - - Copyright 2010-2015 Joey Hess + - Copyright 2010-2016 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -26,6 +26,8 @@ import Annex.Init import Config import Utility.Daemon +import Types.Transfer +import Types.ActionItem {- Generates a normal Command -} command :: String -> CommandSection -> String -> CmdParamsDesc -> (CmdParamsDesc -> CommandParser) -> Command @@ -90,6 +92,15 @@ {- Stops unless a condition is met. -} stopUnless :: Annex Bool -> Annex (Maybe a) -> Annex (Maybe a) stopUnless c a = ifM c ( a , stop ) + +{- When acting on a failed transfer, stops unless it was in the specified + - direction. -} +checkFailedTransferDirection :: ActionItem -> Direction -> Annex (Maybe a) -> Annex (Maybe a) +checkFailedTransferDirection ai d = stopUnless (pure check) + where + check = case actionItemTransferDirection ai of + Nothing -> True + Just d' -> d' == d commonChecks :: [CommandCheck] commonChecks = [repoExists] diff --git a/Command/Add.hs b/Command/Add.hs --- a/Command/Add.hs +++ b/Command/Add.hs @@ -146,7 +146,7 @@ cleanup :: Key -> Bool -> CommandCleanup cleanup key hascontent = do - maybeShowJSON [("key", key2file key)] + maybeShowJSON $ JSONChunk [("key", key2file key)] when hascontent $ logStatus key InfoPresent return True diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -254,7 +254,7 @@ tmp <- fromRepo $ gitAnnexTmpObjectLocation key showOutput ok <- Transfer.notifyTransfer Transfer.Download (Just file) $ - Transfer.download webUUID key (Just file) Transfer.forwardRetry Transfer.noObserver $ \p -> do + Transfer.download webUUID key (Just file) Transfer.forwardRetry $ \p -> do liftIO $ createDirectoryIfMissing True (parentDir tmp) downloadUrl key p [videourl] tmp if ok @@ -335,7 +335,7 @@ ) where runtransfer tmp = Transfer.notifyTransfer Transfer.Download (Just file) $ - Transfer.download u dummykey (Just file) Transfer.forwardRetry Transfer.noObserver $ \p -> do + Transfer.download u dummykey (Just file) Transfer.forwardRetry $ \p -> do liftIO $ createDirectoryIfMissing True (parentDir tmp) downloader tmp p @@ -356,7 +356,7 @@ ) where go = do - maybeShowJSON [("key", key2file key)] + maybeShowJSON $ JSONChunk [("key", key2file key)] when (isJust mtmp) $ logStatus key InfoPresent setUrlPresent u key url diff --git a/Command/Drop.hs b/Command/Drop.hs --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -41,7 +41,7 @@ <$> cmdParams desc <*> optional parseDropFromOption <*> parseAutoOption - <*> optional (parseKeyOptions False) + <*> optional parseKeyOptions <*> parseBatchOption parseDropFromOption :: Parser (DeferredParse Remote) @@ -63,36 +63,38 @@ go = whenAnnexed $ start o start :: DropOptions -> FilePath -> Key -> CommandStart -start o file key = start' o key (Just file) +start o file key = start' o key afile (mkActionItem afile) + where + afile = Just file -start' :: DropOptions -> Key -> AssociatedFile -> CommandStart -start' o key afile = do +start' :: DropOptions -> Key -> AssociatedFile -> ActionItem -> CommandStart +start' o key afile ai = do from <- maybe (pure Nothing) (Just <$$> getParsed) (dropFrom o) checkDropAuto (autoMode o) from afile key $ \numcopies -> stopUnless (want from) $ case from of - Nothing -> startLocal afile numcopies key [] + Nothing -> startLocal afile ai numcopies key [] Just remote -> do u <- getUUID if Remote.uuid remote == u - then startLocal afile numcopies key [] - else startRemote afile numcopies key remote + then startLocal afile ai numcopies key [] + else startRemote afile ai numcopies key remote where want from | autoMode o = wantDrop False (Remote.uuid <$> from) (Just key) afile | otherwise = return True -startKeys :: DropOptions -> Key -> CommandStart +startKeys :: DropOptions -> Key -> ActionItem -> CommandStart startKeys o key = start' o key Nothing -startLocal :: AssociatedFile -> NumCopies -> Key -> [VerifiedCopy] -> CommandStart -startLocal afile numcopies key preverified = stopUnless (inAnnex key) $ do - showStart' "drop" key afile +startLocal :: AssociatedFile -> ActionItem -> NumCopies -> Key -> [VerifiedCopy] -> CommandStart +startLocal afile ai numcopies key preverified = stopUnless (inAnnex key) $ do + showStart' "drop" key ai next $ performLocal key afile numcopies preverified -startRemote :: AssociatedFile -> NumCopies -> Key -> Remote -> CommandStart -startRemote afile numcopies key remote = do - showStart' ("drop " ++ Remote.name remote) key afile +startRemote :: AssociatedFile -> ActionItem -> NumCopies -> Key -> Remote -> CommandStart +startRemote afile ai numcopies key remote = do + showStart' ("drop " ++ Remote.name remote) key ai next $ performRemote key afile numcopies remote performLocal :: Key -> AssociatedFile -> NumCopies -> [VerifiedCopy] -> CommandPerform diff --git a/Command/DropKey.hs b/Command/DropKey.hs --- a/Command/DropKey.hs +++ b/Command/DropKey.hs @@ -42,7 +42,7 @@ start :: Key -> CommandStart start key = do - showStart' "dropkey" key Nothing + showStart' "dropkey" key (mkActionItem key) next $ perform key perform :: Key -> CommandPerform diff --git a/Command/Find.hs b/Command/Find.hs --- a/Command/Find.hs +++ b/Command/Find.hs @@ -66,7 +66,7 @@ showFormatted :: Maybe Utility.Format.Format -> String -> [(String, String)] -> Annex () showFormatted format unformatted vars = - unlessM (showFullJSON vars) $ + unlessM (showFullJSON $ JSONChunk vars) $ case format of Nothing -> liftIO $ putStrLn unformatted Just formatter -> liftIO $ putStr $ diff --git a/Command/Fsck.hs b/Command/Fsck.hs --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -66,7 +66,7 @@ <> completeRemotes )) <*> optional parseincremental - <*> optional (parseKeyOptions False) + <*> optional parseKeyOptions where parseincremental = flag' StartIncrementalO @@ -89,7 +89,7 @@ checkDeadRepo u i <- prepIncremental u (incrementalOpt o) withKeyOptions (keyOptions o) False - (\k -> startKey i k =<< getNumCopies) + (\k ai -> startKey i k ai =<< getNumCopies) (withFilesInGit $ whenAnnexed $ start from i) (fsckFiles o) cleanupIncremental i @@ -111,7 +111,7 @@ Nothing -> go $ perform key file backend numcopies Just r -> go $ performRemote key file backend numcopies r where - go = runFsck inc file key + go = runFsck inc (mkActionItem (Just file)) key perform :: Key -> FilePath -> Backend -> NumCopies -> Annex Bool perform key file backend numcopies = do @@ -173,11 +173,11 @@ ) dummymeter _ = noop -startKey :: Incremental -> Key -> NumCopies -> CommandStart -startKey inc key numcopies = +startKey :: Incremental -> Key -> ActionItem -> NumCopies -> CommandStart +startKey inc key ai numcopies = case Backend.maybeLookupBackendName (keyBackendName key) of Nothing -> stop - Just backend -> runFsck inc (key2file key) key $ + Just backend -> runFsck inc ai key $ performKey key backend numcopies performKey :: Key -> Backend -> NumCopies -> Annex Bool @@ -504,10 +504,10 @@ (False, True) -> "dropped from " ++ Remote.name remote (_, False) -> "failed to drop from" ++ Remote.name remote -runFsck :: Incremental -> FilePath -> Key -> Annex Bool -> CommandStart -runFsck inc file key a = ifM (needFsck inc key) +runFsck :: Incremental -> ActionItem -> Key -> Annex Bool -> CommandStart +runFsck inc ai key a = ifM (needFsck inc key) ( do - showStart "fsck" file + showStart' "fsck" key ai next $ do ok <- a when ok $ diff --git a/Command/Get.hs b/Command/Get.hs --- a/Command/Get.hs +++ b/Command/Get.hs @@ -34,7 +34,7 @@ <$> cmdParams desc <*> optional parseFromOption <*> parseAutoOption - <*> optional (parseKeyOptions True) + <*> optional (parseIncompleteOption <|> parseKeyOptions <|> parseFailedTransfersOption) <*> parseBatchOption seek :: GetOptions -> CommandSeek @@ -49,17 +49,19 @@ (getFiles o) start :: GetOptions -> Maybe Remote -> FilePath -> Key -> CommandStart -start o from file key = start' expensivecheck from key (Just file) +start o from file key = start' expensivecheck from key afile (mkActionItem afile) where + afile = Just file expensivecheck | autoMode o = numCopiesCheck file key (<) <||> wantGet False (Just key) (Just file) | otherwise = return True -startKeys :: Maybe Remote -> Key -> CommandStart -startKeys from key = start' (return True) from key Nothing +startKeys :: Maybe Remote -> Key -> ActionItem -> CommandStart +startKeys from key ai = checkFailedTransferDirection ai Download $ + start' (return True) from key Nothing ai -start' :: Annex Bool -> Maybe Remote -> Key -> AssociatedFile -> CommandStart -start' expensivecheck from key afile = stopUnless (not <$> inAnnex key) $ +start' :: Annex Bool -> Maybe Remote -> Key -> AssociatedFile -> ActionItem -> CommandStart +start' expensivecheck from key afile ai = stopUnless (not <$> inAnnex key) $ stopUnless expensivecheck $ case from of Nothing -> go $ perform key afile @@ -68,7 +70,7 @@ go $ Command.Move.fromPerform src False key afile where go a = do - showStart' "get" key afile + showStart' "get" key ai next a perform :: Key -> AssociatedFile -> CommandPerform @@ -106,7 +108,7 @@ either (const False) id <$> Remote.hasKey r key | otherwise = return True docopy r witness = getViaTmp (RemoteVerify r) key $ \dest -> - download (Remote.uuid r) key afile noRetry noObserver + download (Remote.uuid r) key afile noRetry (\p -> do showAction $ "from " ++ Remote.name r Remote.retrieveKeyFile r key afile dest p diff --git a/Command/Info.hs b/Command/Info.hs --- a/Command/Info.hs +++ b/Command/Info.hs @@ -11,8 +11,9 @@ import "mtl" Control.Monad.State.Strict import qualified Data.Map.Strict as M -import Text.JSON +import qualified Data.Text as T import Data.Ord +import Data.Aeson hiding (json) import Command import qualified Git @@ -29,12 +30,14 @@ import Annex.NumCopies import Remote import Config +import Git.Config (boolConfig) import Utility.Percentage +import Types.Transfer import Logs.Transfer import Types.TrustLevel import Types.FileMatcher import qualified Limit -import Messages.JSON (DualDisp(..)) +import Messages.JSON (DualDisp(..), ObjectMap(..)) import Annex.BloomFilter import qualified Command.Unused @@ -219,6 +222,7 @@ [ file_name f , key_size k , key_name k + , content_present k ] remote_fast_stats :: Remote -> [Stat] @@ -247,10 +251,10 @@ nostat :: Stat nostat = return Nothing -json :: JSON j => (j -> String) -> StatState j -> String -> StatState String +json :: ToJSON j => (j -> String) -> StatState j -> String -> StatState String json fmt a desc = do j <- a - lift $ maybeShowJSON [(desc, j)] + lift $ maybeShowJSON $ JSONChunk [(desc, j)] return $ fmt j nojson :: StatState String -> String -> StatState String @@ -353,6 +357,9 @@ key_name :: Key -> Stat key_name k = simpleStat "key" $ pure $ key2file k +content_present :: Key -> Stat +content_present k = stat "present" $ json boolConfig $ lift $ inAnnex k + bloom_info :: Stat bloom_info = simpleStat "bloom filter size" $ do localkeys <- countKeys <$> cachedPresentData @@ -374,7 +381,7 @@ transfer_list = stat desc $ nojson $ lift $ do uuidmap <- Remote.remoteMap id ts <- getTransfers - maybeShowJSON [(desc, map (uncurry jsonify) ts)] + maybeShowJSON $ JSONChunk [(desc, map (uncurry jsonify) ts)] return $ if null ts then "none" else multiLine $ @@ -388,11 +395,11 @@ , maybe (fromUUID $ transferUUID t) Remote.name $ M.lookup (transferUUID t) uuidmap ] - jsonify t i = toJSObject - [ ("transfer", showLcDirection (transferDirection t)) - , ("key", key2file (transferKey t)) - , ("file", fromMaybe "" (associatedFile i)) - , ("remote", fromUUID (transferUUID t)) + jsonify t i = object $ map (\(k, v) -> (T.pack k, v)) $ + [ ("transfer", toJSON (showLcDirection (transferDirection t))) + , ("key", toJSON (key2file (transferKey t))) + , ("file", toJSON (associatedFile i)) + , ("remote", toJSON (fromUUID (transferUUID t))) ] disk_size :: Stat @@ -415,9 +422,9 @@ backend_usage :: Stat backend_usage = stat "backend usage" $ json fmt $ - toJSObject . sort . M.toList . backendsKeys <$> cachedReferencedData + ObjectMap . backendsKeys <$> cachedReferencedData where - fmt = multiLine . map (\(b, n) -> b ++ ": " ++ show n) . fromJSObject + fmt = multiLine . map (\(b, n) -> b ++ ": " ++ show n) . sort . M.toList . fromObjectMap numcopies_stats :: Stat numcopies_stats = stat "numcopies stats" $ json fmt $ diff --git a/Command/MetaData.hs b/Command/MetaData.hs --- a/Command/MetaData.hs +++ b/Command/MetaData.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2014 Joey Hess + - Copyright 2014-2016 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -10,9 +10,16 @@ import Command import Annex.MetaData import Logs.MetaData +import Annex.WorkTree +import Messages.JSON (JSONActionItem(..)) +import Types.Messages import qualified Data.Set as S +import qualified Data.Map as M +import qualified Data.Text as T +import qualified Data.ByteString.Lazy.UTF8 as BU import Data.Time.Clock.POSIX +import Data.Aeson cmd :: Command cmd = withGlobalOptions ([jsonOption] ++ annexedMatchingOptions) $ @@ -24,6 +31,7 @@ { forFiles :: CmdParams , getSet :: GetSet , keyOptions :: Maybe KeyOptions + , batchOption :: BatchMode } data GetSet = Get MetaField | GetAll | Set [ModMeta] @@ -32,7 +40,8 @@ optParser desc = MetaDataOptions <$> cmdParams desc <*> ((Get <$> getopt) <|> (Set <$> some modopts) <|> pure GetAll) - <*> optional (parseKeyOptions False) + <*> optional parseKeyOptions + <*> parseBatchOption where getopt = option (eitherReader mkMetaField) ( long "get" <> short 'g' <> metavar paramField @@ -58,31 +67,36 @@ seek :: MetaDataOptions -> CommandSeek seek o = do now <- liftIO getPOSIXTime - let seeker = case getSet o of - Get _ -> withFilesInGit - GetAll -> withFilesInGit - Set _ -> withFilesInGitNonRecursive - "Not recursively setting metadata. Use --force to do that." - withKeyOptions (keyOptions o) False - (startKeys now o) - (seeker $ whenAnnexed $ start now o) - (forFiles o) + case batchOption o of + NoBatch -> do + let seeker = case getSet o of + Get _ -> withFilesInGit + GetAll -> withFilesInGit + Set _ -> withFilesInGitNonRecursive + "Not recursively setting metadata. Use --force to do that." + withKeyOptions (keyOptions o) False + (startKeys now o) + (seeker $ whenAnnexed $ start now o) + (forFiles o) + Batch -> withOutputType $ \ot -> case ot of + JSONOutput -> batchInput parseJSONInput $ + commandAction . startBatch now + _ -> error "--batch is currently only supported in --json mode" start :: POSIXTime -> MetaDataOptions -> FilePath -> Key -> CommandStart -start now o file = start' (Just file) now o - -startKeys :: POSIXTime -> MetaDataOptions -> Key -> CommandStart -startKeys = start' Nothing +start now o file k = startKeys now o k (mkActionItem afile) + where + afile = Just file -start' :: AssociatedFile -> POSIXTime -> MetaDataOptions -> Key -> CommandStart -start' afile now o k = case getSet o of +startKeys :: POSIXTime -> MetaDataOptions -> Key -> ActionItem -> CommandStart +startKeys now o k ai = case getSet o of Get f -> do l <- S.toList . currentMetaDataValues f <$> getCurrentMetaData k liftIO $ forM_ l $ putStrLn . fromMetaValue stop _ -> do - showStart' "metadata" k afile + showStart' "metadata" k ai next $ perform now o k perform :: POSIXTime -> MetaDataOptions -> Key -> CommandPerform @@ -96,10 +110,66 @@ cleanup :: Key -> CommandCleanup cleanup k = do - l <- map unwrapmeta . fromMetaData <$> getCurrentMetaData k - maybeShowJSON l - showLongNote $ unlines $ concatMap showmeta l + m <- getCurrentMetaData k + let Object o = toJSON (MetaDataFields m) + maybeShowJSON $ AesonObject o + showLongNote $ unlines $ concatMap showmeta $ + map unwrapmeta (fromMetaData m) return True where unwrapmeta (f, v) = (fromMetaField f, map fromMetaValue (S.toList v)) showmeta (f, vs) = map ((f ++ "=") ++) vs + +-- Metadata serialized to JSON in the field named "fields" of +-- a larger object. +newtype MetaDataFields = MetaDataFields MetaData + deriving (Show) + +instance ToJSON MetaDataFields where + toJSON (MetaDataFields m) = object [ (fieldsField, toJSON m) ] + +instance FromJSON MetaDataFields where + parseJSON (Object v) = do + f <- v .: fieldsField + case f of + Nothing -> return (MetaDataFields emptyMetaData) + Just v' -> MetaDataFields <$> parseJSON v' + parseJSON _ = fail "expected an object" + +fieldsField :: T.Text +fieldsField = T.pack "fields" + +parseJSONInput :: String -> Either String (Either FilePath Key, MetaData) +parseJSONInput i = do + v <- eitherDecode (BU.fromString i) + let m = case itemAdded v of + Nothing -> emptyMetaData + Just (MetaDataFields m') -> m' + case (itemKey v, itemFile v) of + (Just k, _) -> Right (Right k, m) + (Nothing, Just f) -> Right (Left f, m) + (Nothing, Nothing) -> Left "JSON input is missing either file or key" + +startBatch :: POSIXTime -> (Either FilePath Key, MetaData) -> CommandStart +startBatch now (i, (MetaData m)) = case i of + Left f -> do + mk <- lookupFile f + case mk of + Just k -> go k (mkActionItem (Just f)) + Nothing -> error $ "not an annexed file: " ++ f + Right k -> go k (mkActionItem k) + where + go k ai = do + showStart' "metadata" k ai + let o = MetaDataOptions + { forFiles = [] + , getSet = if MetaData m == emptyMetaData + then GetAll + else Set $ map mkModMeta (M.toList m) + , keyOptions = Nothing + , batchOption = NoBatch + } + next $ perform now o k + mkModMeta (f, s) + | S.null s = DelMeta f Nothing + | otherwise = SetMeta f s diff --git a/Command/Mirror.hs b/Command/Mirror.hs --- a/Command/Mirror.hs +++ b/Command/Mirror.hs @@ -14,6 +14,7 @@ import qualified Remote import Annex.Content import Annex.NumCopies +import Types.Transfer cmd :: Command cmd = withGlobalOptions ([jobsOption] ++ annexedMatchingOptions) $ @@ -31,7 +32,7 @@ optParser desc = MirrorOptions <$> cmdParams desc <*> parseFromToOptions - <*> optional (parseKeyOptions False) + <*> optional (parseKeyOptions <|> parseFailedTransfersOption) instance DeferredParseClass MirrorOptions where finishParse v = MirrorOptions @@ -47,25 +48,27 @@ (mirrorFiles o) start :: MirrorOptions -> FilePath -> Key -> CommandStart -start o file = startKey o (Just file) +start o file k = startKey o afile k (mkActionItem afile) + where + afile = Just file -startKey :: MirrorOptions -> Maybe FilePath -> Key -> CommandStart -startKey o afile key = case fromToOptions o of - ToRemote r -> ifM (inAnnex key) - ( Command.Move.toStart False afile key =<< getParsed r +startKey :: MirrorOptions -> Maybe FilePath -> Key -> ActionItem -> CommandStart +startKey o afile key ai = case fromToOptions o of + ToRemote r -> checkFailedTransferDirection ai Upload $ ifM (inAnnex key) + ( Command.Move.toStart False afile key ai =<< getParsed r , do numcopies <- getnumcopies - Command.Drop.startRemote afile numcopies key =<< getParsed r + Command.Drop.startRemote afile ai numcopies key =<< getParsed r ) - FromRemote r -> do + FromRemote r -> checkFailedTransferDirection ai Download $ do haskey <- flip Remote.hasKey key =<< getParsed r case haskey of Left _ -> stop - Right True -> Command.Get.start' (return True) Nothing key afile + Right True -> Command.Get.start' (return True) Nothing key afile ai Right False -> ifM (inAnnex key) ( do numcopies <- getnumcopies - Command.Drop.startLocal afile numcopies key [] + Command.Drop.startLocal afile ai numcopies key [] , stop ) where diff --git a/Command/Move.hs b/Command/Move.hs --- a/Command/Move.hs +++ b/Command/Move.hs @@ -35,7 +35,7 @@ optParser desc = MoveOptions <$> cmdParams desc <*> parseFromToOptions - <*> optional (parseKeyOptions False) + <*> optional (parseKeyOptions <|> parseFailedTransfersOption) instance DeferredParseClass MoveOptions where finishParse v = MoveOptions @@ -51,18 +51,22 @@ (moveFiles o) start :: MoveOptions -> Bool -> FilePath -> Key -> CommandStart -start o move = start' o move . Just +start o move f k = start' o move afile k (mkActionItem afile) + where + afile = Just f -startKey :: MoveOptions -> Bool -> Key -> CommandStart +startKey :: MoveOptions -> Bool -> Key -> ActionItem -> CommandStart startKey o move = start' o move Nothing -start' :: MoveOptions -> Bool -> AssociatedFile -> Key -> CommandStart -start' o move afile key = +start' :: MoveOptions -> Bool -> AssociatedFile -> Key -> ActionItem -> CommandStart +start' o move afile key ai = case fromToOptions o of - FromRemote src -> fromStart move afile key =<< getParsed src - ToRemote dest -> toStart move afile key =<< getParsed dest + FromRemote src -> checkFailedTransferDirection ai Download $ + fromStart move afile key ai =<< getParsed src + ToRemote dest -> checkFailedTransferDirection ai Upload $ + toStart move afile key ai =<< getParsed dest -showMoveAction :: Bool -> Key -> AssociatedFile -> Annex () +showMoveAction :: Bool -> Key -> ActionItem -> Annex () showMoveAction move = showStart' (if move then "move" else "copy") {- Moves (or copies) the content of an annexed file to a remote. @@ -74,16 +78,16 @@ - A file's content can be moved even if there are insufficient copies to - allow it to be dropped. -} -toStart :: Bool -> AssociatedFile -> Key -> Remote -> CommandStart -toStart move afile key dest = do +toStart :: Bool -> AssociatedFile -> Key -> ActionItem -> Remote -> CommandStart +toStart move afile key ai dest = do u <- getUUID ishere <- inAnnex key if not ishere || u == Remote.uuid dest then stop -- not here, so nothing to do - else toStart' dest move afile key + else toStart' dest move afile key ai -toStart' :: Remote -> Bool -> AssociatedFile -> Key -> CommandStart -toStart' dest move afile key = do +toStart' :: Remote -> Bool -> AssociatedFile -> Key -> ActionItem -> CommandStart +toStart' dest move afile key ai = do fast <- Annex.getState Annex.fast if fast && not move && not (Remote.hasKeyCheap dest) then ifM (expectedPresent dest key) @@ -93,7 +97,7 @@ else go False (Remote.hasKey dest key) where go fastcheck isthere = do - showMoveAction move key afile + showMoveAction move key ai next $ toPerform dest move key afile fastcheck =<< isthere expectedPresent :: Remote -> Key -> Annex Bool @@ -110,7 +114,7 @@ Right False -> do showAction $ "to " ++ Remote.name dest ok <- notifyTransfer Upload afile $ - upload (Remote.uuid dest) key afile noRetry noObserver $ + upload (Remote.uuid dest) key afile noRetry $ Remote.storeKey dest key afile if ok then finish $ @@ -143,13 +147,13 @@ - If the current repository already has the content, it is still removed - from the remote. -} -fromStart :: Bool -> AssociatedFile -> Key -> Remote -> CommandStart -fromStart move afile key src +fromStart :: Bool -> AssociatedFile -> Key -> ActionItem -> Remote -> CommandStart +fromStart move afile key ai src | move = go | otherwise = stopUnless (not <$> inAnnex key) go where go = stopUnless (fromOk src key) $ do - showMoveAction move key afile + showMoveAction move key ai next $ fromPerform src move key afile fromOk :: Remote -> Key -> Annex Bool @@ -173,7 +177,7 @@ ) where go = notifyTransfer Download afile $ - download (Remote.uuid src) key afile noRetry noObserver $ \p -> do + download (Remote.uuid src) key afile noRetry $ \p -> do showAction $ "from " ++ Remote.name src getViaTmp (RemoteVerify src) key $ \t -> Remote.retrieveKeyFile src key afile t p diff --git a/Command/RecvKey.hs b/Command/RecvKey.hs --- a/Command/RecvKey.hs +++ b/Command/RecvKey.hs @@ -12,7 +12,7 @@ import Annex.Action import Annex import Utility.Rsync -import Logs.Transfer +import Types.Transfer import Command.SendKey (fieldTransfer) import qualified CmdLine.GitAnnexShell.Fields as Fields diff --git a/Command/SendKey.hs b/Command/SendKey.hs --- a/Command/SendKey.hs +++ b/Command/SendKey.hs @@ -48,7 +48,7 @@ liftIO $ debugM "fieldTransfer" "transfer start" afile <- Fields.getField Fields.associatedFile ok <- maybe (a $ const noop) - (\u -> runner (Transfer direction (toUUID u) key) afile noRetry noObserver a) + (\u -> runner (Transfer direction (toUUID u) key) afile noRetry a) =<< Fields.getField Fields.remoteUUID liftIO $ debugM "fieldTransfer" "transfer done" liftIO $ exitBool ok diff --git a/Command/SetPresentKey.hs b/Command/SetPresentKey.hs --- a/Command/SetPresentKey.hs +++ b/Command/SetPresentKey.hs @@ -23,7 +23,7 @@ start :: [String] -> CommandStart start (ks:us:vs:[]) = do - showStart' "setpresentkey" k Nothing + showStart' "setpresentkey" k (mkActionItem k) next $ perform k (toUUID us) s where k = fromMaybe (error "bad key") (file2key ks) diff --git a/Command/Status.hs b/Command/Status.hs --- a/Command/Status.hs +++ b/Command/Status.hs @@ -43,7 +43,7 @@ let c = statusChar s absf <- fromRepo $ fromTopFilePath (statusFile s) f <- liftIO $ relPathCwdToFile absf - unlessM (showFullJSON [("status", [c]), ("file", f)]) $ + unlessM (showFullJSON $ JSONChunk [("status", [c]), ("file", f)]) $ liftIO $ putStrLn $ [c] ++ " " ++ f -- Git thinks that present direct mode files are typechanged. diff --git a/Command/Sync.hs b/Command/Sync.hs --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -441,7 +441,7 @@ Just WantAllKeys -> Just <$> genBloomFilter (seekworktree mvar []) _ -> seekworktree mvar [] (const noop) >> pure Nothing withKeyOptions' (keyOptions o) False - (seekkeys mvar bloom) + (return (seekkeys mvar bloom)) (const noop) [] finishCommandActions @@ -449,8 +449,7 @@ where seekworktree mvar l bloomfeeder = seekHelper LsFiles.inRepo l >>= mapM_ (\f -> ifAnnexed f (go (Right bloomfeeder) mvar (Just f)) noop) - seekkeys mvar bloom getkeys = - mapM_ (go (Left bloom) mvar Nothing) =<< getkeys + seekkeys mvar bloom k _ = go (Left bloom) mvar Nothing k go ebloom mvar af k = commandAction $ do whenM (syncFile ebloom rs af k) $ void $ liftIO $ tryPutMVar mvar () @@ -512,7 +511,7 @@ , return [] ) get have = includeCommandAction $ do - showStart' "get" k af + showStart' "get" k (mkActionItem af) next $ next $ getKey' k af have wantput r @@ -527,4 +526,4 @@ , return [] ) put dest = includeCommandAction $ - Command.Move.toStart' dest False af k + Command.Move.toStart' dest False af k (mkActionItem af) diff --git a/Command/TransferInfo.hs b/Command/TransferInfo.hs --- a/Command/TransferInfo.hs +++ b/Command/TransferInfo.hs @@ -9,6 +9,7 @@ import Command import Annex.Content +import Types.Transfer import Logs.Transfer import qualified CmdLine.GitAnnexShell.Fields as Fields import Utility.Metered diff --git a/Command/TransferKey.hs b/Command/TransferKey.hs --- a/Command/TransferKey.hs +++ b/Command/TransferKey.hs @@ -51,7 +51,7 @@ toPerform :: Key -> AssociatedFile -> Remote -> CommandPerform toPerform key file remote = go Upload file $ - upload (uuid remote) key file forwardRetry noObserver $ \p -> do + upload (uuid remote) key file forwardRetry $ \p -> do ok <- Remote.storeKey remote key file p when ok $ Remote.logStatus remote key InfoPresent @@ -59,7 +59,7 @@ fromPerform :: Key -> AssociatedFile -> Remote -> CommandPerform fromPerform key file remote = go Upload file $ - download (uuid remote) key file forwardRetry noObserver $ \p -> + download (uuid remote) key file forwardRetry $ \p -> getViaTmp (RemoteVerify remote) key $ \t -> Remote.retrieveKeyFile remote key file t p diff --git a/Command/TransferKeys.hs b/Command/TransferKeys.hs --- a/Command/TransferKeys.hs +++ b/Command/TransferKeys.hs @@ -35,13 +35,13 @@ where runner (TransferRequest direction remote key file) | direction == Upload = notifyTransfer direction file $ - upload (Remote.uuid remote) key file forwardRetry observer $ \p -> do + upload (Remote.uuid remote) key file forwardRetry $ \p -> do ok <- Remote.storeKey remote key file p when ok $ Remote.logStatus remote key InfoPresent return ok | otherwise = notifyTransfer direction file $ - download (Remote.uuid remote) key file forwardRetry observer $ \p -> + download (Remote.uuid remote) key file forwardRetry $ \p -> getViaTmp (RemoteVerify remote) key $ \t -> do r <- Remote.retrieveKeyFile remote key file t p -- Make sure we get the current @@ -49,9 +49,6 @@ -- not old cached data. Database.Keys.closeDb return r - - observer False t tinfo = recordFailedTransfer t tinfo - observer True _ _ = noop runRequests :: Handle diff --git a/Command/Whereis.hs b/Command/Whereis.hs --- a/Command/Whereis.hs +++ b/Command/Whereis.hs @@ -31,7 +31,7 @@ optParser :: CmdParamsDesc -> Parser WhereisOptions optParser desc = WhereisOptions <$> cmdParams desc - <*> optional (parseKeyOptions False) + <*> optional parseKeyOptions <*> parseBatchOption seek :: WhereisOptions -> CommandSeek @@ -47,14 +47,13 @@ (whereisFiles o) start :: M.Map UUID Remote -> FilePath -> Key -> CommandStart -start remotemap file key = start' remotemap key (Just file) - -startKeys :: M.Map UUID Remote -> Key -> CommandStart -startKeys remotemap key = start' remotemap key Nothing +start remotemap file key = startKeys remotemap key (mkActionItem afile) + where + afile = Just file -start' :: M.Map UUID Remote -> Key -> AssociatedFile -> CommandStart -start' remotemap key afile = do - showStart' "whereis" key afile +startKeys :: M.Map UUID Remote -> Key -> ActionItem -> CommandStart +startKeys remotemap key ai = do + showStart' "whereis" key ai next $ perform remotemap key perform :: M.Map UUID Remote -> Key -> CommandPerform diff --git a/Git/FilePath.hs b/Git/FilePath.hs --- a/Git/FilePath.hs +++ b/Git/FilePath.hs @@ -14,6 +14,8 @@ module Git.FilePath ( TopFilePath, + BranchFilePath(..), + descBranchFilePath, getTopFilePath, fromTopFilePath, toTopFilePath, @@ -32,6 +34,13 @@ {- A FilePath, relative to the top of the git repository. -} newtype TopFilePath = TopFilePath { getTopFilePath :: FilePath } deriving (Show, Eq, Ord) + +{- A file in a branch or other treeish. -} +data BranchFilePath = BranchFilePath Ref TopFilePath + +{- Git uses the branch:file form to refer to a BranchFilePath -} +descBranchFilePath :: BranchFilePath -> String +descBranchFilePath (BranchFilePath b f) = fromRef b ++ ':' : getTopFilePath f {- Path to a TopFilePath, within the provided git repo. -} fromTopFilePath :: TopFilePath -> Git.Repo -> FilePath diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs --- a/Logs/Transfer.hs +++ b/Logs/Transfer.hs @@ -9,6 +9,7 @@ module Logs.Transfer where +import Types.Transfer import Annex.Common import Annex.Perms import qualified Git @@ -22,38 +23,6 @@ import Data.Time.Clock import Data.Time.Clock.POSIX import Control.Concurrent - -{- Enough information to uniquely identify a transfer, used as the filename - - of the transfer information file. -} -data Transfer = Transfer - { transferDirection :: Direction - , transferUUID :: UUID - , transferKey :: Key - } - deriving (Eq, Ord, Read, Show) - -{- Information about a Transfer, stored in the transfer information file. - - - - Note that the associatedFile may not correspond to a file in the local - - git repository. It's some file, possibly relative to some directory, - - of some repository, that was acted on to initiate the transfer. - -} -data TransferInfo = TransferInfo - { startedTime :: Maybe POSIXTime - , transferPid :: Maybe PID - , transferTid :: Maybe ThreadId - , transferRemote :: Maybe Remote - , bytesComplete :: Maybe Integer - , associatedFile :: Maybe FilePath - , transferPaused :: Bool - } - deriving (Show, Eq, Ord) - -stubTransferInfo :: TransferInfo -stubTransferInfo = TransferInfo Nothing Nothing Nothing Nothing Nothing Nothing False - -data Direction = Upload | Download - deriving (Eq, Ord, Read, Show) showLcDirection :: Direction -> String showLcDirection Upload = "upload" diff --git a/Messages.hs b/Messages.hs --- a/Messages.hs +++ b/Messages.hs @@ -1,12 +1,14 @@ {- git-annex output messages - - - Copyright 2010-2014 Joey Hess + - Copyright 2010-2016 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} module Messages ( showStart, + ActionItem, + mkActionItem, showStart', showNote, showAction, @@ -25,6 +27,7 @@ earlyWarning, warningIO, indent, + JSONChunk(..), maybeShowJSON, showFullJSON, showCustom, @@ -37,9 +40,9 @@ commandProgressDisabled, outputMessage, implicitMessage, + withOutputType, ) where -import Text.JSON import System.Log.Logger import System.Log.Formatter import System.Log.Handler (setFormatter) @@ -48,18 +51,23 @@ import Common import Types import Types.Messages +import Types.ActionItem import Messages.Internal import qualified Messages.JSON as JSON -import Types.Key +import Utility.JSONStream (JSONChunk(..)) import qualified Annex showStart :: String -> FilePath -> Annex () -showStart command file = outputMessage (JSON.start command (Just file) Nothing) $ +showStart command file = outputMessage json $ command ++ " " ++ file ++ " " + where + json = JSON.start command (Just file) Nothing -showStart' :: String -> Key -> Maybe FilePath -> Annex () -showStart' command key afile = outputMessage (JSON.start command afile (Just key)) $ - command ++ " " ++ fromMaybe (key2file key) afile ++ " " +showStart' :: String -> Key -> ActionItem -> Annex () +showStart' command key i = outputMessage json $ + command ++ " " ++ actionItemDesc i key ++ " " + where + json = JSON.start command (actionItemWorkTreeFile i) (Just key) showNote :: String -> Annex () showNote s = outputMessage (JSON.note s) $ "(" ++ s ++ ") " @@ -145,15 +153,15 @@ indent :: String -> String indent = intercalate "\n" . map (\l -> " " ++ l) . lines -{- Shows a JSON fragment only when in json mode. -} -maybeShowJSON :: JSON a => [(String, a)] -> Annex () +{- Shows a JSON chunk only when in json mode. -} +maybeShowJSON :: JSONChunk v -> Annex () maybeShowJSON v = withOutputType $ liftIO . go where go JSONOutput = JSON.add v go _ = return () {- Shows a complete JSON value, only when in json mode. -} -showFullJSON :: JSON a => [(String, a)] -> Annex Bool +showFullJSON :: JSONChunk v -> Annex Bool showFullJSON v = withOutputType $ liftIO . go where go JSONOutput = JSON.complete v >> return True diff --git a/Messages/JSON.hs b/Messages/JSON.hs --- a/Messages/JSON.hs +++ b/Messages/JSON.hs @@ -1,10 +1,12 @@ -{- git-annex JSON output +{- git-annex command-line JSON output and input - - - Copyright 2011 Joey Hess + - Copyright 2011-2016 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Messages.JSON ( start, end, @@ -12,35 +14,43 @@ add, complete, DualDisp(..), + ObjectMap(..), + JSONActionItem(..), ) where -import Text.JSON +import Data.Aeson +import Control.Applicative +import qualified Data.Map as M +import qualified Data.Text as T +import qualified Data.ByteString.Lazy as B +import System.IO +import Data.Monoid +import Prelude import qualified Utility.JSONStream as Stream import Types.Key -import Data.Maybe start :: String -> Maybe FilePath -> Maybe Key -> IO () -start command file key = putStr $ Stream.start $ catMaybes - [ part "command" (Just command) - , part "file" file - , part "key" (fmap key2file key) - ] +start command file key = B.hPut stdout $ Stream.start $ Stream.AesonObject o where - part _ Nothing = Nothing - part l (Just v) = Just (l, v) + Object o = toJSON $ JSONActionItem + { itemCommand = Just command + , itemKey = key + , itemFile = file + , itemAdded = Nothing + } end :: Bool -> IO () -end b = putStr $ Stream.add [("success", b)] ++ Stream.end +end b = B.hPut stdout $ Stream.add (Stream.JSONChunk [("success", b)]) `B.append` Stream.end note :: String -> IO () -note s = add [("note", s)] +note s = add (Stream.JSONChunk [("note", s)]) -add :: JSON a => [(String, a)] -> IO () -add v = putStr $ Stream.add v +add :: Stream.JSONChunk a -> IO () +add = B.hPut stdout . Stream.add -complete :: JSON a => [(String, a)] -> IO () -complete v = putStr $ Stream.start v ++ Stream.end +complete :: Stream.JSONChunk a -> IO () +complete v = B.hPut stdout $ Stream.start v `B.append` Stream.end -- A value that can be displayed either normally, or as JSON. data DualDisp = DualDisp @@ -48,9 +58,45 @@ , dispJson :: String } -instance JSON DualDisp where - showJSON = JSString . toJSString . dispJson - readJSON _ = Error "stub" +instance ToJSON DualDisp where + toJSON = toJSON . dispJson instance Show DualDisp where show = dispNormal + +-- A Map that is serialized to JSON as an object, with each key being a +-- field of the object. This is different from Aeson's normal +-- serialization of Map, which uses "[key, value]". +data ObjectMap a = ObjectMap { fromObjectMap :: M.Map String a } + +instance ToJSON a => ToJSON (ObjectMap a) where + toJSON (ObjectMap m) = object $ map go $ M.toList m + where + go (k, v) = (T.pack k, toJSON v) + +-- An item that a git-annex command acts on, and displays a JSON object about. +data JSONActionItem a = JSONActionItem + { itemCommand :: Maybe String + , itemKey :: Maybe Key + , itemFile :: Maybe FilePath + , itemAdded :: Maybe a -- for additional fields added by `add` + } + deriving (Show) + +instance ToJSON (JSONActionItem a) where + toJSON i = object + [ "command" .= itemCommand i + , "key" .= (toJSON (itemKey i)) + , "file" .= itemFile i + -- itemAdded is not included; must be added later by 'add' + ] + +instance FromJSON a => FromJSON (JSONActionItem a) where + parseJSON (Object v) = JSONActionItem + <$> (v .:? "command") + <*> (maybe (return Nothing) parseJSON =<< (v .:? "key")) + <*> (v .:? "file") + <*> parseadded + where + parseadded = (Just <$> parseJSON (Object v)) <|> return Nothing + parseJSON _ = mempty diff --git a/Remote.hs b/Remote.hs --- a/Remote.hs +++ b/Remote.hs @@ -55,10 +55,10 @@ claimingUrl, ) where -import qualified Data.Map as M -import Text.JSON -import Text.JSON.Generic import Data.Ord +import Data.Aeson +import qualified Data.Map as M +import qualified Data.Text as T import Annex.Common import Types.Remote @@ -194,7 +194,7 @@ {- An optional field can be included in the list of UUIDs. -} prettyPrintUUIDsWith - :: JSON v + :: ToJSON v => Maybe String -> String -> M.Map UUID RemoteName @@ -203,7 +203,7 @@ -> Annex String prettyPrintUUIDsWith optfield header descm showval uuidvals = do hereu <- getUUID - maybeShowJSON [(header, map (jsonify hereu) uuidvals)] + maybeShowJSON $ JSONChunk [(header, map (jsonify hereu) uuidvals)] return $ unwords $ map (\u -> "\t" ++ prettify hereu u ++ "\n") uuidvals where finddescription u = M.findWithDefault "" u descm @@ -220,12 +220,12 @@ addoptval s = case showval =<< optval of Nothing -> s Just val -> val ++ ": " ++ s - jsonify hereu (u, optval) = toJSObject $ catMaybes - [ Just ("uuid", toJSON $ fromUUID u) - , Just ("description", toJSON $ finddescription u) - , Just ("here", toJSON $ hereu == u) + jsonify hereu (u, optval) = object $ catMaybes + [ Just (T.pack "uuid", toJSON $ fromUUID u) + , Just (T.pack "description", toJSON $ finddescription u) + , Just (T.pack "here", toJSON $ hereu == u) , case (optfield, optval) of - (Just field, Just val) -> Just (field, showJSON val) + (Just field, Just val) -> Just (T.pack field, toJSON val) _ -> Nothing ] diff --git a/Remote/External.hs b/Remote/External.hs --- a/Remote/External.hs +++ b/Remote/External.hs @@ -22,7 +22,7 @@ import Remote.Helper.Messages import Utility.Metered import Messages.Progress -import Logs.Transfer +import Types.Transfer import Logs.PreferredContent.Raw import Logs.RemoteState import Logs.Web diff --git a/Remote/External/Types.hs b/Remote/External/Types.hs --- a/Remote/External/Types.hs +++ b/Remote/External/Types.hs @@ -34,7 +34,7 @@ import Annex.Common import Types.StandardGroups (PreferredContentExpression) import Utility.Metered (BytesProcessed(..)) -import Logs.Transfer (Direction(..)) +import Types.Transfer (Direction(..)) import Config.Cost (Cost) import Types.Remote (RemoteConfig) import Types.Availability (Availability(..)) diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -25,6 +25,7 @@ import Types.GitConfig import Types.Crypto import Types.Creds +import Types.Transfer import qualified Git import qualified Git.Command import qualified Git.Config @@ -47,7 +48,6 @@ import Utility.Rsync import Utility.Tmp import Logs.Remote -import Logs.Transfer import Utility.Gpg remote :: RemoteType diff --git a/Remote/Git.hs b/Remote/Git.hs --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -439,7 +439,7 @@ Just (object, checksuccess) -> do copier <- mkCopier hardlink params runTransfer (Transfer Download u key) - file noRetry noObserver + file noRetry (\p -> copier object dest (combineMeterUpdate p meterupdate) checksuccess) | Git.repoIsSsh (repo r) = unVerified $ feedprogressback $ \p -> do Ssh.rsyncHelper (Just (combineMeterUpdate meterupdate p)) @@ -565,7 +565,7 @@ ensureInitialized copier <- mkCopier hardlink params let verify = Annex.Content.RemoteVerify r - runTransfer (Transfer Download u key) file noRetry noObserver $ \p -> + runTransfer (Transfer Download u key) file noRetry $ \p -> let p' = combineMeterUpdate meterupdate p in Annex.Content.saveState True `after` Annex.Content.getViaTmp verify key diff --git a/Remote/Helper/Ssh.hs b/Remote/Helper/Ssh.hs --- a/Remote/Helper/Ssh.hs +++ b/Remote/Helper/Ssh.hs @@ -20,7 +20,7 @@ import Utility.Metered import Utility.Rsync import Types.Remote -import Logs.Transfer +import Types.Transfer import Config {- Generates parameters to ssh to a repository's host and run a command. diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -34,7 +34,7 @@ import Utility.CopyFile import Messages.Progress import Utility.Metered -import Logs.Transfer +import Types.Transfer import Types.Creds import Annex.DirHashes import Utility.Tmp diff --git a/Test.hs b/Test.hs --- a/Test.hs +++ b/Test.hs @@ -32,7 +32,8 @@ import Options.Applicative (switch, long, help) import qualified Data.Map as M -import qualified Text.JSON +import qualified Data.Aeson +import qualified Data.ByteString.Lazy.UTF8 as BU8 import Common @@ -924,10 +925,10 @@ test_info :: Assertion test_info = intmpclonerepo $ do - json <- git_annex_output "info" ["--json"] - case Text.JSON.decodeStrict json :: Text.JSON.Result (Text.JSON.JSObject Text.JSON.JSValue) of - Text.JSON.Ok _ -> return () - Text.JSON.Error e -> assertFailure e + json <- BU8.fromString <$> git_annex_output "info" ["--json"] + case Data.Aeson.eitherDecode json :: Either String Data.Aeson.Value of + Right _ -> return () + Left e -> assertFailure e test_version :: Assertion test_version = intmpclonerepo $ diff --git a/Types/ActionItem.hs b/Types/ActionItem.hs new file mode 100644 --- /dev/null +++ b/Types/ActionItem.hs @@ -0,0 +1,54 @@ +{- items that a command can act on + - + - Copyright 2016 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} + +module Types.ActionItem where + +import Types.Key +import Types.Transfer +import Git.FilePath + +import Data.Maybe + +data ActionItem + = ActionItemAssociatedFile AssociatedFile + | ActionItemKey + | ActionItemBranchFilePath BranchFilePath + | ActionItemFailedTransfer Transfer TransferInfo + +class MkActionItem t where + mkActionItem :: t -> ActionItem + +instance MkActionItem AssociatedFile where + mkActionItem = ActionItemAssociatedFile + +instance MkActionItem Key where + mkActionItem _ = ActionItemKey + +instance MkActionItem BranchFilePath where + mkActionItem = ActionItemBranchFilePath + +instance MkActionItem (Transfer, TransferInfo) where + mkActionItem = uncurry ActionItemFailedTransfer + +actionItemDesc :: ActionItem -> Key -> String +actionItemDesc (ActionItemAssociatedFile (Just f)) _ = f +actionItemDesc (ActionItemAssociatedFile Nothing) k = key2file k +actionItemDesc ActionItemKey k = key2file k +actionItemDesc (ActionItemBranchFilePath bfp) _ = descBranchFilePath bfp +actionItemDesc (ActionItemFailedTransfer _ i) k = + fromMaybe (key2file k) (associatedFile i) + +actionItemWorkTreeFile :: ActionItem -> Maybe FilePath +actionItemWorkTreeFile (ActionItemAssociatedFile af) = af +actionItemWorkTreeFile _ = Nothing + +actionItemTransferDirection :: ActionItem -> Maybe Direction +actionItemTransferDirection (ActionItemFailedTransfer t _) = Just $ + transferDirection t +actionItemTransferDirection _ = Nothing diff --git a/Types/Key.hs b/Types/Key.hs --- a/Types/Key.hs +++ b/Types/Key.hs @@ -1,6 +1,6 @@ {- git-annex Key data type - - - Copyright 2011-2014 Joey Hess + - Copyright 2011-2016 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -21,6 +21,8 @@ ) where import System.Posix.Types +import Data.Aeson +import qualified Data.Text as T import Common import Utility.QuickCheck @@ -119,6 +121,13 @@ return $ k { keyChunkNum = Just chunknum } _ -> return k addfield _ _ _ = Nothing + +instance ToJSON Key where + toJSON = toJSON . key2file + +instance FromJSON Key where + parseJSON (String t) = maybe mempty pure $ file2key $ T.unpack t + parseJSON _ = mempty instance Arbitrary Key where arbitrary = Key diff --git a/Types/MetaData.hs b/Types/MetaData.hs --- a/Types/MetaData.hs +++ b/Types/MetaData.hs @@ -44,14 +44,32 @@ import Utility.Base64 import Utility.QuickCheck +import qualified Data.Text as T import qualified Data.Set as S import qualified Data.Map as M +import qualified Data.HashMap.Strict as HM import Data.Char import qualified Data.CaseInsensitive as CI +import Data.Aeson newtype MetaData = MetaData (M.Map MetaField (S.Set MetaValue)) deriving (Show, Eq, Ord) +instance ToJSON MetaData where + toJSON (MetaData m) = object $ map go (M.toList m) + where + go (MetaField f, s) = (T.pack (CI.original f), toJSON s) + +instance FromJSON MetaData where + parseJSON (Object o) = do + l <- HM.toList <$> parseJSON (Object o) + MetaData . M.fromList <$> mapM go l + where + go (t, l) = case mkMetaField (T.unpack t) of + Left e -> fail e + Right f -> (,) <$> pure f <*> parseJSON l + parseJSON _ = fail "expected an object" + {- A metadata value can be currently be set (True), or may have been - set before and we're remembering it no longer is (False). -} newtype CurrentlySet = CurrentlySet Bool @@ -64,6 +82,13 @@ data MetaValue = MetaValue CurrentlySet String deriving (Read, Show) +instance ToJSON MetaValue where + toJSON (MetaValue _ v) = toJSON v + +instance FromJSON MetaValue where + parseJSON (String v) = return $ MetaValue (CurrentlySet True) (T.unpack v) + parseJSON _ = fail "expected a string" + {- Metadata values compare and order the same whether currently set or not. -} instance Eq MetaValue where MetaValue _ a == MetaValue _ b = a == b @@ -179,9 +204,12 @@ {- Can be used to set a value, or to unset it, depending on whether - the MetaValue has CurrentlySet or not. -} updateMetaData :: MetaField -> MetaValue -> MetaData -> MetaData -updateMetaData f v (MetaData m) = MetaData $ - M.insertWith' S.union f (S.singleton v) m +updateMetaData f v = updateMetaData' f (S.singleton v) +updateMetaData' :: MetaField -> S.Set MetaValue -> MetaData -> MetaData +updateMetaData' f s (MetaData m) = MetaData $ + M.insertWith' S.union f s m + {- New metadata overrides old._-} unionMetaData :: MetaData -> MetaData -> MetaData unionMetaData (MetaData old) (MetaData new) = MetaData $ @@ -222,7 +250,7 @@ | DelMeta MetaField (Maybe MetaValue) -- ^ delete value of a field. With Just, only that specific value -- is deleted; with Nothing, all current values are deleted. - | SetMeta MetaField MetaValue + | SetMeta MetaField (S.Set MetaValue) -- ^ removes any existing values | MaybeSetMeta MetaField MetaValue -- ^ set when field has no existing value @@ -237,7 +265,7 @@ updateMetaData f (unsetMetaValue oldv) emptyMetaData modMeta m (DelMeta f Nothing) = MetaData $ M.singleton f $ S.fromList $ map unsetMetaValue $ S.toList $ currentMetaDataValues f m -modMeta m (SetMeta f v) = updateMetaData f v $ +modMeta m (SetMeta f s) = updateMetaData' f s $ foldr (updateMetaData f) emptyMetaData $ map unsetMetaValue $ S.toList $ currentMetaDataValues f m modMeta m (MaybeSetMeta f v) diff --git a/Types/Transfer.hs b/Types/Transfer.hs new file mode 100644 --- /dev/null +++ b/Types/Transfer.hs @@ -0,0 +1,47 @@ +{- git-annex transfer types + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Types.Transfer where + +import Types +import Utility.PID + +import Data.Time.Clock.POSIX +import Control.Concurrent + +{- Enough information to uniquely identify a transfer, used as the filename + - of the transfer information file. -} +data Transfer = Transfer + { transferDirection :: Direction + , transferUUID :: UUID + , transferKey :: Key + } + deriving (Eq, Ord, Read, Show) + +{- Information about a Transfer, stored in the transfer information file. + - + - Note that the associatedFile may not correspond to a file in the local + - git repository. It's some file, possibly relative to some directory, + - of some repository, that was acted on to initiate the transfer. + -} +data TransferInfo = TransferInfo + { startedTime :: Maybe POSIXTime + , transferPid :: Maybe PID + , transferTid :: Maybe ThreadId + , transferRemote :: Maybe Remote + , bytesComplete :: Maybe Integer + , associatedFile :: Maybe FilePath + , transferPaused :: Bool + } + deriving (Show, Eq, Ord) + +stubTransferInfo :: TransferInfo +stubTransferInfo = TransferInfo Nothing Nothing Nothing Nothing Nothing Nothing False + +data Direction = Upload | Download + deriving (Eq, Ord, Read, Show) + diff --git a/Utility/JSONStream.hs b/Utility/JSONStream.hs --- a/Utility/JSONStream.hs +++ b/Utility/JSONStream.hs @@ -1,44 +1,68 @@ {- Streaming JSON output. - - - Copyright 2011 Joey Hess + - Copyright 2011, 2016 Joey Hess - - License: BSD-2-clause -} +{-# LANGUAGE GADTs #-} + module Utility.JSONStream ( + JSONChunk(..), start, add, end ) where -import Text.JSON +import Data.Aeson +import qualified Data.Text as T +import qualified Data.ByteString.Lazy as B +import Data.Char +import Data.Word -{- Text.JSON does not support building up a larger JSON document piece by - - piece as a stream. To support streaming, a hack. The JSObject is converted - - to a string with its final "}" is left off, allowing it to be added to - - later. -} -start :: JSON a => [(String, a)] -> String -start l - | last s == endchar = init s - | otherwise = bad s +data JSONChunk v where + JSONChunk :: ToJSON v => [(String, v)] -> JSONChunk [(String, v)] + AesonObject :: Object -> JSONChunk Object + +encodeJSONChunk :: JSONChunk v -> B.ByteString +encodeJSONChunk (JSONChunk l) = encode $ object $ map mkPair l where - s = encodeStrict $ toJSObject l + mkPair (s, v) = (T.pack s, toJSON v) +encodeJSONChunk (AesonObject o) = encode o -add :: JSON a => [(String, a)] -> String -add l - | head s == startchar = ',' : drop 1 s - | otherwise = bad s +{- Aeson does not support building up a larger JSON object piece by piece + - with streaming output. To support streaming, a hack: + - The final "}" is left off the JSON, allowing more chunks to be added + - to later. -} +start :: JSONChunk a -> B.ByteString +start a + | not (B.null b) && B.last b == endchar = B.init b + | otherwise = bad b where - s = start l + b = encodeJSONChunk a -end :: String -end = [endchar, '\n'] +add :: JSONChunk a -> B.ByteString +add a + | not (B.null b) && B.head b == startchar = B.cons addchar (B.drop 1 b) + | otherwise = bad b + where + b = start a -startchar :: Char -startchar = '{' +end :: B.ByteString +end = endchar `B.cons` sepchar `B.cons` B.empty -endchar :: Char -endchar = '}' +startchar :: Word8 +startchar = fromIntegral (ord '{') -bad :: String -> a -bad s = error $ "Text.JSON returned unexpected string: " ++ s +endchar :: Word8 +endchar = fromIntegral (ord '}') + +addchar :: Word8 +addchar = fromIntegral (ord ',') + +sepchar :: Word8 +sepchar = fromIntegral (ord '\n') + +bad :: B.ByteString -> a +bad b = error $ "JSON encoder generated unexpected value: " ++ show b + diff --git a/doc/git-annex-copy.mdwn b/doc/git-annex-copy.mdwn --- a/doc/git-annex-copy.mdwn +++ b/doc/git-annex-copy.mdwn @@ -51,9 +51,17 @@ This is the default behavior when running git-annex in a bare repository. +* `--branch=ref` + + Operate on files in the specified branch or treeish. + * `--unused` Operate on files found by last run of git-annex unused. + +* `--failed` + + Operate on files that have recently failed to be transferred. * `--key=keyname` diff --git a/doc/git-annex-drop.mdwn b/doc/git-annex-drop.mdwn --- a/doc/git-annex-drop.mdwn +++ b/doc/git-annex-drop.mdwn @@ -42,13 +42,29 @@ This is the default behavior when running git-annex drop in a bare repository. + Note that this bypasses checking the .gitattributes annex.numcopies + setting. + +* `--branch=ref` + + Drop files in the specified branch or treeish. + + Note that this bypasses checking the .gitattributes annex.numcopies + setting. + * `--unused` Drop files found by last run of git-annex unused. + Note that this bypasses checking the .gitattributes annex.numcopies + setting. + * `--key=keyname` Use this option to drop a specified key. + + Note that this bypasses checking the .gitattributes annex.numcopies + setting. * file matching options diff --git a/doc/git-annex-fsck.mdwn b/doc/git-annex-fsck.mdwn --- a/doc/git-annex-fsck.mdwn +++ b/doc/git-annex-fsck.mdwn @@ -72,6 +72,10 @@ This is the default behavior when running git-annex in a bare repository. +* `--branch=ref` + + Operate on files in the specified branch or treeish. + * `--unused` Operate on files found by last run of git-annex unused. diff --git a/doc/git-annex-get.mdwn b/doc/git-annex-get.mdwn --- a/doc/git-annex-get.mdwn +++ b/doc/git-annex-get.mdwn @@ -32,6 +32,11 @@ Enables parallel download with up to the specified number of jobs running at once. For example: `-J10` +* file matching options + + The [[git-annex-matching-options]](1) + can be used to specify files to get. + * `--incomplete` Resume any incomplete downloads of files that were started and @@ -45,11 +50,6 @@ as git-annex does not know the associated file, and the associated file may not even be in the current git working directory. -* file matching options - - The [[git-annex-matching-options]](1) - can be used to specify files to get. - * `--all` Rather than specifying a filename or path to get, this option can be @@ -57,9 +57,20 @@ This is the default behavior when running git-annex in a bare repository. +* `--branch=ref` + + Operate on files in the specified branch or treeish. + * `--unused` Operate on files found by last run of git-annex unused. + +* `--failed` + + Operate on files that have recently failed to be transferred. + + Not to be confused with `--incomplete` which resumes only downloads + that managed to transfer part of the content of a file. * `--key=keyname` diff --git a/doc/git-annex-metadata.mdwn b/doc/git-annex-metadata.mdwn --- a/doc/git-annex-metadata.mdwn +++ b/doc/git-annex-metadata.mdwn @@ -17,6 +17,11 @@ When run without any -s or -t parameters, displays the current metadata. +Each metadata field has its own "field-lastchanged" metadata, which +contains the date the field was last changed. Unlike other metadata, +this cannot be directly modified by this command. It is updated +automatically. + # OPTIONS * `-g field` / `--get field` @@ -66,15 +71,15 @@ The [[git-annex-matching-options]](1) can be used to specify files to act on. -* `--json` - - Enable JSON output. This is intended to be parsed by programs that use - git-annex. Each line of output is a JSON object. - * `--all` Specify instead of a file to get/set metadata on all known keys. +* `--branch=ref` + + Specify instead of a file to get/set metadata on all files in the + specified branch or treeish. + * `--unused` Specify instead of a file to get/set metadata on @@ -83,6 +88,55 @@ * `--key=keyname` Specify instead of a file to get/set metadata of the specified key. + +* `--json` + + Enable JSON output (and input). Each line is a JSON object. + + The format of the JSON objects changed in git-annex version 6.20160726. + + Example of the new format: + + {"command":"metadata","file":"foo","key":"...","fields":{"author":["bar"],...},"note":"...","success":true} + + Example of the old format, which lacks the inner fields object: + + {"command":"metadata","file":"foo","key":"...","author":["bar"],...,"note":"...","success":true} + +* `--batch` + + Enables batch mode, which can be used to both get, store, and unset + metadata for multiple files or keys. + + Batch currently only supports JSON input. So, you must + enable `--json` along with `--batch`. + + In batch mode, git-annex reads lines from stdin, which contain + JSON objects. It replies to each input with an output JSON object. + + The format of the JSON sent to git-annex can be the same as the JSON that + it outputs. Or, a simplified version. Only the "file" (or "key") field + is actually necessary. + + For example, to get the current metadata of file foo: + + {"file":"foo"} + + To get the current metadata of the key k: + + {"key":"k"} + + Any metadata fields included in the JSON object will be stored, + replacing whatever values the fields had before. + To unset a field, include it with an empty list of values. + + To change the author of file foo to bar: + + {"file":"foo","fields":{"author":["bar"]}} + + To remove the author of file foo: + + {"file":"foo","fields":{"author":[]}} # EXAMPLES diff --git a/doc/git-annex-mirror.mdwn b/doc/git-annex-mirror.mdwn --- a/doc/git-annex-mirror.mdwn +++ b/doc/git-annex-mirror.mdwn @@ -46,6 +46,21 @@ This is the default behavior when running git-annex in a bare repository. +* `--branch=ref` + + Operate on files in the specified branch or treeish. + + Like --all, this bypasses checking the .gitattributes annex.numcopies + setting when dropping files. + +* `--unused` + + Operate on files found by last run of git-annex unused. + +* `--failed` + + Operate on files that have recently failed to be transferred. + * file matching options The [[git-annex-matching-options]](1) diff --git a/doc/git-annex-move.mdwn b/doc/git-annex-move.mdwn --- a/doc/git-annex-move.mdwn +++ b/doc/git-annex-move.mdwn @@ -34,9 +34,17 @@ This is the default behavior when running git-annex in a bare repository. +* `--branch=ref` + + Operate on files in the specified branch or treeish. + * `--unused` Operate on files found by last run of git-annex unused. + +* `--failed` + + Operate on files that have recently failed to be transferred. * `--key=keyname` diff --git a/doc/git-annex-whereis.mdwn b/doc/git-annex-whereis.mdwn --- a/doc/git-annex-whereis.mdwn +++ b/doc/git-annex-whereis.mdwn @@ -35,6 +35,10 @@ Show whereis information for all known keys. +* `--branch=ref` + + Show whereis information for files in the specified branch or treeish. + * `--unused` Show whereis information for files found by last run of git-annex unused. diff --git a/git-annex.cabal b/git-annex.cabal --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1,5 +1,5 @@ Name: git-annex -Version: 6.20160619 +Version: 6.20160808 Cabal-Version: >= 1.8 License: GPL-3 Maintainer: Joey Hess @@ -323,21 +323,23 @@ Build-Depends: base (>= 4.5 && < 5.0), optparse-applicative (>= 0.11.0), - containers (>= 0.5.0.0), + containers (>= 0.5.0.0), exceptions (>= 0.6), QuickCheck (>= 2.1), stm (>= 2.3), mtl (>= 2), - process, data-default, case-insensitive, uuid, random, dlist, + uuid (>= 1.2.6), + process, data-default, case-insensitive, random, dlist, unix-compat, SafeSemaphore, async, directory, filepath, IfElse, MissingH, hslogger, monad-logger, - utf8-string, bytestring, text, sandi, json, + utf8-string, bytestring, text, sandi, monad-control, transformers, bloomfilter, edit-distance, - resourcet, http-conduit, http-client, http-types, + resourcet, http-conduit (<2.2.0), http-client, http-types, time, old-locale, - esqueleto, persistent-sqlite, persistent, persistent-template, + esqueleto, persistent-sqlite, persistent (<2.5), persistent-template, aeson, + unordered-containers, feed, regex-tdfa CC-Options: -Wall @@ -911,6 +913,7 @@ RemoteDaemon.Types Test Types + Types.ActionItem Types.Availability Types.Backend Types.BranchState @@ -937,6 +940,7 @@ Types.StandardGroups Types.StoreRetrieve Types.Test + Types.Transfer Types.TrustLevel Types.UUID Types.UrlContents