diff options
Diffstat (limited to 'Command')
47 files changed, 336 insertions, 274 deletions
diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs index 866bfc463..0e937dc69 100644 --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2011-2014 Joey Hess <id@joeyh.name> + - Copyright 2011-2017 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -21,6 +21,7 @@ import Annex.Content import Annex.Ingest import Annex.CheckIgnore import Annex.UUID +import Annex.YoutubeDl import Logs.Web import Types.KeySource import Types.UrlContents @@ -28,9 +29,8 @@ import Annex.FileMatcher import Logs.Location import Utility.Metered import Utility.FileSystemEncoding +import Utility.HtmlDetect import qualified Annex.Transfer as Transfer -import Annex.Quvi -import qualified Utility.Quvi as Quvi cmd :: Command cmd = notBareRepo $ withGlobalOptions [jobsOption, jsonOption, jsonProgressOption] $ @@ -39,23 +39,23 @@ cmd = notBareRepo $ withGlobalOptions [jobsOption, jsonOption, jsonProgressOptio data AddUrlOptions = AddUrlOptions { addUrls :: CmdParams - , fileOption :: Maybe FilePath , pathdepthOption :: Maybe Int , prefixOption :: Maybe String , suffixOption :: Maybe String - , relaxedOption :: Bool - , rawOption :: Bool + , downloadOptions :: DownloadOptions , batchOption :: BatchMode , batchFilesOption :: Bool } +data DownloadOptions = DownloadOptions + { relaxedOption :: Bool + , rawOption :: Bool + , fileOption :: Maybe FilePath + } + optParser :: CmdParamsDesc -> Parser AddUrlOptions optParser desc = AddUrlOptions <$> cmdParams desc - <*> optional (strOption - ( long "file" <> metavar paramFile - <> help "specify what file the url is added to" - )) <*> optional (option auto ( long "pathdepth" <> metavar paramNumber <> help "number of url path components to use in filename" @@ -68,25 +68,29 @@ optParser desc = AddUrlOptions ( long "suffix" <> metavar paramValue <> help "add a suffix to the filename" )) - <*> parseRelaxedOption - <*> parseRawOption + <*> parseDownloadOptions True <*> parseBatchOption <*> switch ( long "with-files" <> help "parse batch mode lines of the form \"$url $file\"" ) -parseRelaxedOption :: Parser Bool -parseRelaxedOption = switch - ( long "relaxed" - <> help "skip size check" - ) - -parseRawOption :: Parser Bool -parseRawOption = switch - ( long "raw" - <> help "disable special handling for torrents, quvi, etc" - ) +parseDownloadOptions :: Bool -> Parser DownloadOptions +parseDownloadOptions withfileoption = DownloadOptions + <$> switch + ( long "relaxed" + <> help "skip size check" + ) + <*> switch + ( long "raw" + <> help "disable special handling for torrents, youtube-dl, etc" + ) + <*> if withfileoption + then optional (strOption + ( long "file" <> metavar paramFile + <> help "specify what file the url is added to" + )) + else pure Nothing seek :: AddUrlOptions -> CommandSeek seek o = allowConcurrentOutput $ do @@ -97,7 +101,7 @@ seek o = allowConcurrentOutput $ do where go (o', u) = do r <- Remote.claimingUrl u - if Remote.uuid r == webUUID || rawOption o' + if Remote.uuid r == webUUID || rawOption (downloadOptions o') then void $ commandAction $ startWeb o' u else checkUrl r o' u @@ -107,13 +111,13 @@ parseBatchInput o s let (u, f) = separate (== ' ') s in if null u || null f then Left ("parsed empty url or filename in input: " ++ s) - else Right (o { fileOption = Just f }, u) + else Right (o { downloadOptions = (downloadOptions o) { fileOption = Just f } }, u) | otherwise = Right (o, s) checkUrl :: Remote -> AddUrlOptions -> URLString -> Annex () checkUrl r o u = do pathmax <- liftIO $ fileNameLengthLimit "." - let deffile = fromMaybe (urlString2file u (pathdepthOption o) pathmax) (fileOption o) + let deffile = fromMaybe (urlString2file u (pathdepthOption o) pathmax) (fileOption (downloadOptions o)) go deffile =<< maybe (error $ "unable to checkUrl of " ++ Remote.name r) (tryNonAsync . flip id u) @@ -121,50 +125,50 @@ checkUrl r o u = do where go _ (Left e) = void $ commandAction $ do - showStart "addurl" u + showStart' "addurl" (Just u) warning (show e) next $ next $ return False go deffile (Right (UrlContents sz mf)) = do - let f = adjustFile o (fromMaybe (maybe deffile fromSafeFilePath mf) (fileOption o)) - void $ commandAction $ - startRemote r (relaxedOption o) f u sz + let f = adjustFile o (fromMaybe (maybe deffile fromSafeFilePath mf) (fileOption (downloadOptions o))) + void $ commandAction $ startRemote r o f u sz go deffile (Right (UrlMulti l)) - | isNothing (fileOption o) = + | isNothing (fileOption (downloadOptions o)) = forM_ l $ \(u', sz, f) -> do let f' = adjustFile o (deffile </> fromSafeFilePath f) void $ commandAction $ - startRemote r (relaxedOption o) f' u' sz + startRemote r o f' u' sz | otherwise = giveup $ unwords [ "That url contains multiple files according to the" , Remote.name r , " remote; cannot add it to a single file." ] -startRemote :: Remote -> Bool -> FilePath -> URLString -> Maybe Integer -> CommandStart -startRemote r relaxed file uri sz = do +startRemote :: Remote -> AddUrlOptions -> FilePath -> URLString -> Maybe Integer -> CommandStart +startRemote r o file uri sz = do pathmax <- liftIO $ fileNameLengthLimit "." let file' = joinPath $ map (truncateFilePath pathmax) $ splitDirectories file - showStart "addurl" file' + showStart' "addurl" (Just uri) showNote $ "from " ++ Remote.name r - next $ performRemote r relaxed uri file' sz + showDestinationFile file' + next $ performRemote r o uri file' sz -performRemote :: Remote -> Bool -> URLString -> FilePath -> Maybe Integer -> CommandPerform -performRemote r relaxed uri file sz = ifAnnexed file adduri geturi +performRemote :: Remote -> AddUrlOptions -> URLString -> FilePath -> Maybe Integer -> CommandPerform +performRemote r o uri file sz = ifAnnexed file adduri geturi where loguri = setDownloader uri OtherDownloader - adduri = addUrlChecked relaxed loguri (Remote.uuid r) checkexistssize + adduri = addUrlChecked o loguri file (Remote.uuid r) checkexistssize checkexistssize key = return $ case sz of - Nothing -> (True, True) - Just n -> (True, n == fromMaybe n (keySize key)) - geturi = next $ isJust <$> downloadRemoteFile r relaxed uri file sz + Nothing -> (True, True, uri) + Just n -> (True, n == fromMaybe n (keySize key), uri) + geturi = next $ isJust <$> downloadRemoteFile r (downloadOptions o) uri file sz -downloadRemoteFile :: Remote -> Bool -> URLString -> FilePath -> Maybe Integer -> Annex (Maybe Key) -downloadRemoteFile r relaxed uri file sz = checkCanAdd file $ do +downloadRemoteFile :: Remote -> DownloadOptions -> URLString -> FilePath -> Maybe Integer -> Annex (Maybe Key) +downloadRemoteFile r o uri file sz = checkCanAdd file $ do let urlkey = Backend.URL.fromUrl uri sz liftIO $ createDirectoryIfMissing True (parentDir file) - ifM (Annex.getState Annex.fast <||> pure relaxed) + ifM (Annex.getState Annex.fast <||> pure (relaxedOption o)) ( do - cleanup (Remote.uuid r) loguri file urlkey Nothing + addWorkTree (Remote.uuid r) loguri file urlkey Nothing return (Just urlkey) , do -- Set temporary url for the urlkey @@ -181,24 +185,18 @@ downloadRemoteFile r relaxed uri file sz = checkCanAdd file $ do where loguri = setDownloader uri OtherDownloader -startWeb :: AddUrlOptions -> String -> CommandStart -startWeb o s = go $ fromMaybe bad $ parseURI urlstring +startWeb :: AddUrlOptions -> URLString -> CommandStart +startWeb o urlstring = go $ fromMaybe bad $ parseURI urlstring where - (urlstring, downloader) = getDownloader s bad = fromMaybe (giveup $ "bad url " ++ urlstring) $ Url.parseURIRelaxed $ urlstring - go url = case downloader of - QuviDownloader -> usequvi - _ -> ifM (quviSupported urlstring) - ( usequvi - , regulardownload url - ) - regulardownload url = do + go url = do + showStart' "addurl" (Just urlstring) pathmax <- liftIO $ fileNameLengthLimit "." - urlinfo <- if relaxedOption o + urlinfo <- if relaxedOption (downloadOptions o) then pure Url.assumeUrlExists else Url.withUrlOptions (Url.getUrlInfo urlstring) - file <- adjustFile o <$> case fileOption o of + file <- adjustFile o <$> case fileOption (downloadOptions o) of Just f -> pure f Nothing -> case Url.urlSuggestedFile urlinfo of Nothing -> pure $ url2file url (pathdepthOption o) pathmax @@ -209,79 +207,31 @@ startWeb o s = go $ fromMaybe bad $ parseURI urlstring ( pure $ url2file url (pathdepthOption o) pathmax , pure f ) - showStart "addurl" file - next $ performWeb (relaxedOption o) urlstring file urlinfo - badquvi = giveup $ "quvi does not know how to download url " ++ urlstring - usequvi = do - page <- fromMaybe badquvi - <$> withQuviOptions Quvi.forceQuery [Quvi.quiet, Quvi.httponly] urlstring - let link = fromMaybe badquvi $ headMaybe $ Quvi.pageLinks page - pathmax <- liftIO $ fileNameLengthLimit "." - let file = adjustFile o $ flip fromMaybe (fileOption o) $ - truncateFilePath pathmax $ sanitizeFilePath $ - Quvi.pageTitle page ++ "." ++ fromMaybe "m" (Quvi.linkSuffix link) - showStart "addurl" file - next $ performQuvi (relaxedOption o) urlstring (Quvi.linkUrl link) file - -performWeb :: Bool -> URLString -> FilePath -> Url.UrlInfo -> CommandPerform -performWeb relaxed url file urlinfo = ifAnnexed file addurl geturl - where - geturl = next $ isJust <$> addUrlFile relaxed url urlinfo file - addurl = addUrlChecked relaxed url webUUID $ \k -> return $ - (Url.urlExists urlinfo, Url.urlSize urlinfo == keySize k) + next $ performWeb o urlstring file urlinfo -performQuvi :: Bool -> URLString -> URLString -> FilePath -> CommandPerform -performQuvi relaxed pageurl videourl file = ifAnnexed file addurl geturl - where - quviurl = setDownloader pageurl QuviDownloader - addurl key = next $ do - cleanup webUUID quviurl file key Nothing - return True - geturl = next $ isJust <$> addUrlFileQuvi relaxed quviurl videourl file - -addUrlFileQuvi :: Bool -> URLString -> URLString -> FilePath -> Annex (Maybe Key) -addUrlFileQuvi relaxed quviurl videourl file = checkCanAdd file $ do - let key = Backend.URL.fromUrl quviurl Nothing - ifM (pure relaxed <||> Annex.getState Annex.fast) - ( do - cleanup webUUID quviurl file key Nothing - return (Just key) - , do - {- Get the size, and use that to check - - disk space. However, the size info is not - - retained, because the size of a video stream - - might change and we want to be able to download - - it later. -} - urlinfo <- Url.withUrlOptions (Url.getUrlInfo videourl) - let sizedkey = addSizeUrlKey urlinfo key - checkDiskSpaceToGet sizedkey Nothing $ do - tmp <- fromRepo $ gitAnnexTmpObjectLocation key - showOutput - ok <- Transfer.notifyTransfer Transfer.Download afile $ - Transfer.download webUUID key afile Transfer.forwardRetry $ \p -> do - liftIO $ createDirectoryIfMissing True (parentDir tmp) - downloadUrl key p [videourl] tmp - if ok - then do - cleanup webUUID quviurl file key (Just tmp) - return (Just key) - else return Nothing - ) +performWeb :: AddUrlOptions -> URLString -> FilePath -> Url.UrlInfo -> CommandPerform +performWeb o url file urlinfo = ifAnnexed file addurl geturl where - afile = AssociatedFile (Just file) + geturl = next $ isJust <$> addUrlFile (downloadOptions o) url urlinfo file + addurl = addUrlChecked o url file webUUID $ \k -> + ifM (pure (not (rawOption (downloadOptions o))) <&&> youtubeDlSupported url) + ( return (True, True, setDownloader url YoutubeDownloader) + , return (Url.urlExists urlinfo, Url.urlSize urlinfo == keySize k, url) + ) -addUrlChecked :: Bool -> URLString -> UUID -> (Key -> Annex (Bool, Bool)) -> Key -> CommandPerform -addUrlChecked relaxed url u checkexistssize key - | relaxed = do - setUrlPresent u key url - next $ return True - | otherwise = ifM ((elem url <$> getUrls key) <&&> (elem u <$> loggedLocations key)) - ( next $ return True -- nothing to do +{- Check that the url exists, and has the same size as the key, + - and add it as an url to the key. -} +addUrlChecked :: AddUrlOptions -> URLString -> FilePath -> UUID -> (Key -> Annex (Bool, Bool, URLString)) -> Key -> CommandPerform +addUrlChecked o url file u checkexistssize key = + ifM ((elem url <$> getUrls key) <&&> (elem u <$> loggedLocations key)) + ( do + showDestinationFile file + next $ return True , do - (exists, samesize) <- checkexistssize key - if exists && samesize + (exists, samesize, url') <- checkexistssize key + if exists && (samesize || relaxedOption (downloadOptions o)) then do - setUrlPresent u key url + setUrlPresent u key url' next $ return True else do warning $ "while adding a new url to an already annexed file, " ++ if exists @@ -290,64 +240,122 @@ addUrlChecked relaxed url u checkexistssize key stop ) -addUrlFile :: Bool -> URLString -> Url.UrlInfo -> FilePath -> Annex (Maybe Key) -addUrlFile relaxed url urlinfo file = checkCanAdd file $ do - liftIO $ createDirectoryIfMissing True (parentDir file) - ifM (Annex.getState Annex.fast <||> pure relaxed) - ( nodownload url urlinfo file - , downloadWeb url urlinfo file +{- Downloads an url (except in fast or relaxed mode) and adds it to the + - repository, normally at the specified FilePath. + - But, if youtube-dl supports the url, it will be written to a + - different file, based on the title of the media. Unless the user + - specified fileOption, which then forces using the FilePath. + -} +addUrlFile :: DownloadOptions -> URLString -> Url.UrlInfo -> FilePath -> Annex (Maybe Key) +addUrlFile o url urlinfo file = + ifM (Annex.getState Annex.fast <||> pure (relaxedOption o)) + ( nodownloadWeb o url urlinfo file + , downloadWeb o url urlinfo file ) -downloadWeb :: URLString -> Url.UrlInfo -> FilePath -> Annex (Maybe Key) -downloadWeb url urlinfo file = do - let dummykey = addSizeUrlKey urlinfo $ Backend.URL.fromUrl url Nothing - let downloader f p = do +downloadWeb :: DownloadOptions -> URLString -> Url.UrlInfo -> FilePath -> Annex (Maybe Key) +downloadWeb o url urlinfo file = + go =<< downloadWith' downloader urlkey webUUID url (AssociatedFile (Just file)) + where + urlkey = addSizeUrlKey urlinfo $ Backend.URL.fromUrl url Nothing + downloader f p = do showOutput - downloadUrl dummykey p [url] f - showAction $ "downloading " ++ url ++ " " - downloadWith downloader dummykey webUUID url file + downloadUrl urlkey p [url] f + go Nothing = return Nothing + -- If we downloaded a html file, try to use youtube-dl to + -- extract embedded media. + go (Just tmp) = ifM (pure (not (rawOption o)) <&&> liftIO (isHtml <$> readFile tmp)) + ( tryyoutubedl tmp + , normalfinish tmp + ) + normalfinish tmp = checkCanAdd file $ do + showDestinationFile file + liftIO $ createDirectoryIfMissing True (parentDir file) + finishDownloadWith tmp webUUID url file + tryyoutubedl tmp = withTmpWorkDir mediakey $ \workdir -> + Transfer.notifyTransfer Transfer.Download url $ + Transfer.download webUUID mediakey (AssociatedFile Nothing) Transfer.noRetry $ \_p -> do + dl <- youtubeDl url workdir + case dl of + Right (Just mediafile) -> do + pruneTmpWorkDirBefore tmp (liftIO . nukeFile) + let dest = if isJust (fileOption o) + then file + else takeFileName mediafile + checkCanAdd dest $ do + showDestinationFile dest + addWorkTree webUUID mediaurl dest mediakey (Just mediafile) + return $ Just mediakey + Right Nothing -> normalfinish tmp + Left msg -> do + warning msg + return Nothing + where + mediaurl = setDownloader url YoutubeDownloader + mediakey = Backend.URL.fromUrl mediaurl Nothing + +showDestinationFile :: FilePath -> Annex () +showDestinationFile file = do + showNote ("to " ++ file) + maybeShowJSON $ JSONChunk [("file", file)] {- The Key should be a dummy key, based on the URL, which is used - for this download, before we can examine the file and find its real key. - For resuming downloads to work, the dummy key for a given url should be - - stable. -} + - stable. For disk space checking to work, the dummy key should have + - the size of the url already set. + - + - Downloads the url, sets up the worktree file, and returns the + - real key. + -} downloadWith :: (FilePath -> MeterUpdate -> Annex Bool) -> Key -> UUID -> URLString -> FilePath -> Annex (Maybe Key) downloadWith downloader dummykey u url file = - checkDiskSpaceToGet dummykey Nothing $ do - tmp <- fromRepo $ gitAnnexTmpObjectLocation dummykey - ifM (runtransfer tmp) - ( do - backend <- chooseBackend file - let source = KeySource - { keyFilename = file - , contentLocation = tmp - , inodeCache = Nothing - } - k <- genKey source backend - case k of - Nothing -> return Nothing - Just (key, _) -> do - cleanup u url file key (Just tmp) - return (Just key) - , return Nothing - ) + go =<< downloadWith' downloader dummykey u url afile where - runtransfer tmp = Transfer.notifyTransfer Transfer.Download afile $ - Transfer.download u dummykey afile Transfer.forwardRetry $ \p -> do - liftIO $ createDirectoryIfMissing True (parentDir tmp) - downloader tmp p afile = AssociatedFile (Just file) + go Nothing = return Nothing + go (Just tmp) = finishDownloadWith tmp u url file + +{- Like downloadWith, but leaves the dummy key content in + - the returned location. -} +downloadWith' :: (FilePath -> MeterUpdate -> Annex Bool) -> Key -> UUID -> URLString -> AssociatedFile -> Annex (Maybe FilePath) +downloadWith' downloader dummykey u url afile = + checkDiskSpaceToGet dummykey Nothing $ do + tmp <- fromRepo $ gitAnnexTmpObjectLocation dummykey + ok <- Transfer.notifyTransfer Transfer.Download url $ + Transfer.download u dummykey afile Transfer.forwardRetry $ \p -> do + liftIO $ createDirectoryIfMissing True (parentDir tmp) + downloader tmp p + if ok + then return (Just tmp) + else return Nothing + +finishDownloadWith :: FilePath -> UUID -> URLString -> FilePath -> Annex (Maybe Key) +finishDownloadWith tmp u url file = do + backend <- chooseBackend file + let source = KeySource + { keyFilename = file + , contentLocation = tmp + , inodeCache = Nothing + } + k <- genKey source backend + case k of + Nothing -> return Nothing + Just (key, _) -> do + addWorkTree u url file key (Just tmp) + return (Just key) {- Adds the url size to the Key. -} addSizeUrlKey :: Url.UrlInfo -> Key -> Key addSizeUrlKey urlinfo key = key { keySize = Url.urlSize urlinfo } -cleanup :: UUID -> URLString -> FilePath -> Key -> Maybe FilePath -> Annex () -cleanup u url file key mtmp = case mtmp of +{- Adds worktree file to the repository. -} +addWorkTree :: UUID -> URLString -> FilePath -> Key -> Maybe FilePath -> Annex () +addWorkTree u url file key mtmp = case mtmp of Nothing -> go Just tmp -> do -- Move to final location for large file check. - liftIO $ renameFile tmp file + pruneTmpWorkDirBefore tmp (\_ -> liftIO $ renameFile tmp file) largematcher <- largeFilesMatcher large <- checkFileMatcher largematcher file if large @@ -366,18 +374,36 @@ cleanup u url file key mtmp = case mtmp of ( do when (isJust mtmp) $ logStatus key InfoPresent - , liftIO $ maybe noop nukeFile mtmp + , maybe noop (\tmp -> pruneTmpWorkDirBefore tmp (liftIO . nukeFile)) mtmp ) -nodownload :: URLString -> Url.UrlInfo -> FilePath -> Annex (Maybe Key) -nodownload url urlinfo file - | Url.urlExists urlinfo = do - let key = Backend.URL.fromUrl url (Url.urlSize urlinfo) - cleanup webUUID url file key Nothing - return (Just key) +nodownloadWeb :: DownloadOptions -> URLString -> Url.UrlInfo -> FilePath -> Annex (Maybe Key) +nodownloadWeb o url urlinfo file + | Url.urlExists urlinfo = if rawOption o + then nomedia + else either (const nomedia) usemedia + =<< youtubeDlFileName url | otherwise = do warning $ "unable to access url: " ++ url return Nothing + where + nomedia = do + let key = Backend.URL.fromUrl url (Url.urlSize urlinfo) + nodownloadWeb' url key file + usemedia mediafile = do + let dest = if isJust (fileOption o) + then file + else takeFileName mediafile + let mediaurl = setDownloader url YoutubeDownloader + let mediakey = Backend.URL.fromUrl mediaurl Nothing + nodownloadWeb' mediaurl mediakey dest + +nodownloadWeb' :: URLString -> Key -> FilePath -> Annex (Maybe Key) +nodownloadWeb' url key file = checkCanAdd file $ do + showDestinationFile file + liftIO $ createDirectoryIfMissing True (parentDir file) + addWorkTree webUUID url file key Nothing + return (Just key) url2file :: URI -> Maybe Int -> Int -> FilePath url2file url pathdepth pathmax = case pathdepth of @@ -411,7 +437,7 @@ adjustFile o = addprefix . addsuffix checkCanAdd :: FilePath -> Annex (Maybe a) -> Annex (Maybe a) checkCanAdd file a = ifM (isJust <$> (liftIO $ catchMaybeIO $ getSymbolicLinkStatus file)) ( do - warning $ file ++ " already exists and is not annexed; not overwriting" + warning $ file ++ " already exists; not overwriting" return Nothing , ifM ((not <$> Annex.getState Annex.force) <&&> checkIgnored file) ( do diff --git a/Command/Adjust.hs b/Command/Adjust.hs index 204fd057a..0fef3f936 100644 --- a/Command/Adjust.hs +++ b/Command/Adjust.hs @@ -38,5 +38,5 @@ seek = commandAction . start start :: Adjustment -> CommandStart start adj = do checkVersionSupported - showStart "adjust" "" + showStart' "adjust" Nothing next $ next $ enterAdjustedBranch adj diff --git a/Command/Config.hs b/Command/Config.hs index 5da196044..47415999d 100644 --- a/Command/Config.hs +++ b/Command/Config.hs @@ -50,14 +50,14 @@ optParser _ = setconfig <|> getconfig <|> unsetconfig seek :: Action -> CommandSeek seek (SetConfig name val) = commandAction $ do allowMessages - showStart name val + showStart' name (Just val) next $ next $ do setGlobalConfig name val setConfig (ConfigKey name) val return True seek (UnsetConfig name) = commandAction $ do allowMessages - showStart name "unset" + showStart' name (Just "unset") next $ next $ do unsetGlobalConfig name unsetConfig (ConfigKey name) diff --git a/Command/Dead.hs b/Command/Dead.hs index 44cf7b7f6..385dd6fad 100644 --- a/Command/Dead.hs +++ b/Command/Dead.hs @@ -33,7 +33,7 @@ seek (DeadKeys ks) = seekActions $ pure $ map startKey ks startKey :: Key -> CommandStart startKey key = do - showStart "dead" (key2file key) + showStart' "dead" (Just $ key2file key) ls <- keyLocations key case ls of [] -> next $ performKey key diff --git a/Command/Describe.hs b/Command/Describe.hs index dc7a5d8f9..4b86a7b58 100644 --- a/Command/Describe.hs +++ b/Command/Describe.hs @@ -22,7 +22,7 @@ seek = withWords start start :: [String] -> CommandStart start (name:description) = do - showStart "describe" name + showStart' "describe" (Just name) u <- Remote.nameToUUID name next $ perform u $ unwords description start _ = giveup "Specify a repository and a description." diff --git a/Command/Direct.hs b/Command/Direct.hs index 817cedd53..20eeef726 100644 --- a/Command/Direct.hs +++ b/Command/Direct.hs @@ -31,7 +31,7 @@ start = ifM versionSupportsDirectMode perform :: CommandPerform perform = do - showStart "commit" "" + showStart' "commit" Nothing showOutput _ <- inRepo $ Git.Branch.commitCommand Git.Branch.ManualCommit [ Param "-a" @@ -65,6 +65,6 @@ perform = do cleanup :: CommandCleanup cleanup = do - showStart "direct" "" + showStart' "direct" Nothing setDirect True return True diff --git a/Command/Drop.hs b/Command/Drop.hs index b03e3e080..275714a65 100644 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -89,12 +89,12 @@ startKeys o key = start' o key (AssociatedFile Nothing) startLocal :: AssociatedFile -> ActionItem -> NumCopies -> Key -> [VerifiedCopy] -> CommandStart startLocal afile ai numcopies key preverified = stopUnless (inAnnex key) $ do - showStart' "drop" key ai + showStartKey "drop" key ai next $ performLocal key afile numcopies preverified startRemote :: AssociatedFile -> ActionItem -> NumCopies -> Key -> Remote -> CommandStart startRemote afile ai numcopies key remote = do - showStart' ("drop " ++ Remote.name remote) key ai + showStartKey ("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 index 65446ba06..f3f2333dd 100644 --- a/Command/DropKey.hs +++ b/Command/DropKey.hs @@ -42,7 +42,7 @@ seek o = do start :: Key -> CommandStart start key = do - showStart' "dropkey" key (mkActionItem key) + showStartKey "dropkey" key (mkActionItem key) next $ perform key perform :: Key -> CommandPerform diff --git a/Command/DropUnused.hs b/Command/DropUnused.hs index 840a8a472..c5a61d739 100644 --- a/Command/DropUnused.hs +++ b/Command/DropUnused.hs @@ -55,5 +55,5 @@ perform from numcopies key = case from of performOther :: (Key -> Git.Repo -> FilePath) -> Key -> CommandPerform performOther filespec key = do f <- fromRepo $ filespec key - liftIO $ nukeFile f + pruneTmpWorkDirBefore f (liftIO . nukeFile) next $ return True diff --git a/Command/EnableRemote.hs b/Command/EnableRemote.hs index fd830375a..d9993ebc9 100644 --- a/Command/EnableRemote.hs +++ b/Command/EnableRemote.hs @@ -55,7 +55,7 @@ start (name:rest) = go =<< filter matchingname <$> Annex.fromRepo Git.remotes startNormalRemote :: Git.RemoteName -> [String] -> Git.Repo -> CommandStart startNormalRemote name restparams r | null restparams = do - showStart "enableremote" name + showStart' "enableremote" (Just name) next $ next $ do setRemoteIgnore r False r' <- Remote.Git.configRead False r @@ -77,7 +77,7 @@ startSpecialRemote name config Nothing = do startSpecialRemote name config (Just (u, c)) = do let fullconfig = config `M.union` c t <- either giveup return (Annex.SpecialRemote.findType fullconfig) - showStart "enableremote" name + showStart' "enableremote" (Just name) gc <- maybe (liftIO dummyRemoteGitConfig) (return . Remote.gitconfig) =<< Remote.byUUID u diff --git a/Command/EnableTor.hs b/Command/EnableTor.hs index 7076a9a73..72fa50448 100644 --- a/Command/EnableTor.hs +++ b/Command/EnableTor.hs @@ -51,7 +51,7 @@ start os = do Nothing -> giveup "Need user-id parameter." Just userid -> go uuid userid else do - showStart "enable-tor" "" + showStart' "enable-tor" Nothing gitannex <- liftIO readProgramFile let ps = [Param (cmdname cmd), Param (show curruserid)] sucommand <- liftIO $ mkSuCommand gitannex ps diff --git a/Command/Expire.hs b/Command/Expire.hs index 551742304..28f90dfb5 100644 --- a/Command/Expire.hs +++ b/Command/Expire.hs @@ -59,12 +59,12 @@ start :: Expire -> Bool -> Log Activity -> M.Map UUID String -> UUID -> CommandS start (Expire expire) noact actlog descs u = case lastact of Just ent | notexpired ent -> checktrust (== DeadTrusted) $ do - showStart "unexpire" desc + showStart' "unexpire" (Just desc) showNote =<< whenactive unless noact $ trustSet u SemiTrusted _ -> checktrust (/= DeadTrusted) $ do - showStart "expire" desc + showStart' "expire" (Just desc) showNote =<< whenactive unless noact $ trustSet u DeadTrusted diff --git a/Command/Forget.hs b/Command/Forget.hs index d172cc693..40ac98d4b 100644 --- a/Command/Forget.hs +++ b/Command/Forget.hs @@ -34,7 +34,7 @@ seek = commandAction . start start :: ForgetOptions -> CommandStart start o = do - showStart "forget" "git-annex" + showStart' "forget" (Just "git-annex") c <- liftIO currentVectorClock let basets = addTransition c ForgetGitHistory noTransitions let ts = if dropDead o diff --git a/Command/FromKey.hs b/Command/FromKey.hs index c1e3a7965..1b276db99 100644 --- a/Command/FromKey.hs +++ b/Command/FromKey.hs @@ -41,7 +41,7 @@ start force (keyname, file) = do startMass :: CommandStart startMass = do - showStart "fromkey" "stdin" + showStart' "fromkey" (Just "stdin") next massAdd massAdd :: CommandPerform diff --git a/Command/Fsck.hs b/Command/Fsck.hs index 514421e93..bc7a29f15 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -536,7 +536,7 @@ badContentRemote remote localcopy key = do runFsck :: Incremental -> ActionItem -> Key -> Annex Bool -> CommandStart runFsck inc ai key a = ifM (needFsck inc key) ( do - showStart' "fsck" key ai + showStartKey "fsck" key ai next $ do ok <- a when ok $ diff --git a/Command/Get.hs b/Command/Get.hs index a412b2cb3..a74ca253f 100644 --- a/Command/Get.hs +++ b/Command/Get.hs @@ -71,7 +71,7 @@ start' expensivecheck from key afile ai = onlyActionOn key $ go $ Command.Move.fromPerform src False key afile where go a = do - showStart' "get" key ai + showStartKey "get" key ai next a perform :: Key -> AssociatedFile -> CommandPerform diff --git a/Command/Group.hs b/Command/Group.hs index 65e062589..52b7e688c 100644 --- a/Command/Group.hs +++ b/Command/Group.hs @@ -24,7 +24,7 @@ seek = withWords start start :: [String] -> CommandStart start (name:g:[]) = do allowMessages - showStart "group" name + showStart' "group" (Just name) u <- Remote.nameToUUID name next $ setGroup u g start (name:[]) = do diff --git a/Command/GroupWanted.hs b/Command/GroupWanted.hs index 939b3030a..8dab02933 100644 --- a/Command/GroupWanted.hs +++ b/Command/GroupWanted.hs @@ -24,6 +24,6 @@ start :: [String] -> CommandStart start (g:[]) = next $ performGet groupPreferredContentMapRaw g start (g:expr:[]) = do allowMessages - showStart "groupwanted" g + showStart' "groupwanted" (Just g) next $ performSet groupPreferredContentSet expr g start _ = giveup "Specify a group." diff --git a/Command/ImportFeed.hs b/Command/ImportFeed.hs index d2989f05b..a02d11824 100644 --- a/Command/ImportFeed.hs +++ b/Command/ImportFeed.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2013 Joey Hess <id@joeyh.name> + - Copyright 2013-2017 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -32,16 +32,16 @@ import Types.UrlContents import Logs.Web import qualified Utility.Format import Utility.Tmp -import Command.AddUrl (addUrlFile, downloadRemoteFile, parseRelaxedOption, parseRawOption) +import Command.AddUrl (addUrlFile, downloadRemoteFile, parseDownloadOptions, DownloadOptions(..)) import Annex.Perms import Annex.UUID import Backend.URL (fromUrl) -import Annex.Quvi -import qualified Utility.Quvi as Quvi -import Command.AddUrl (addUrlFileQuvi) +import Annex.Content +import Annex.YoutubeDl import Types.MetaData import Logs.MetaData import Annex.MetaData +import Command.AddUrl (addWorkTree) cmd :: Command cmd = notBareRepo $ @@ -51,8 +51,7 @@ cmd = notBareRepo $ data ImportFeedOptions = ImportFeedOptions { feedUrls :: CmdParams , templateOption :: Maybe String - , relaxedOption :: Bool - , rawOption :: Bool + , downloadOptions :: DownloadOptions } optParser :: CmdParamsDesc -> Parser ImportFeedOptions @@ -62,8 +61,7 @@ optParser desc = ImportFeedOptions ( long "template" <> metavar paramFormat <> help "template for filenames" )) - <*> parseRelaxedOption - <*> parseRawOption + <*> parseDownloadOptions False seek :: ImportFeedOptions -> CommandSeek seek o = do @@ -72,7 +70,7 @@ seek o = do start :: ImportFeedOptions -> Cache -> URLString -> CommandStart start opts cache url = do - showStart "importfeed" url + showStart' "importfeed" (Just url) next $ perform opts cache url perform :: ImportFeedOptions -> Cache -> URLString -> CommandPerform @@ -101,7 +99,7 @@ data ToDownload = ToDownload , location :: DownloadLocation } -data DownloadLocation = Enclosure URLString | QuviLink URLString +data DownloadLocation = Enclosure URLString | MediaLink URLString type ItemId = String @@ -141,14 +139,10 @@ findDownloads u = go =<< downloadFeed u Just (enclosureurl, _, _) -> return $ Just $ ToDownload f u i $ Enclosure $ fromFeed enclosureurl - Nothing -> mkquvi f i - mkquvi f i = case getItemLink i of - Just link -> ifM (quviSupported $ fromFeed link) - ( return $ Just $ ToDownload f u i $ QuviLink $ - fromFeed link - , return Nothing - ) - Nothing -> return Nothing + Nothing -> case getItemLink i of + Just link -> return $ Just $ ToDownload f u i $ + MediaLink $ fromFeed link + Nothing -> return Nothing {- Feeds change, so a feed download cannot be resumed. -} downloadFeed :: URLString -> Annex (Maybe Feed) @@ -169,12 +163,19 @@ performDownload opts cache todownload = case location todownload of Enclosure url -> checkknown url $ rundownload url (takeWhile (/= '?') $ takeExtension url) $ \f -> do r <- Remote.claimingUrl url - if Remote.uuid r == webUUID || rawOption opts + if Remote.uuid r == webUUID || rawOption (downloadOptions opts) then do - urlinfo <- if relaxedOption opts + urlinfo <- if relaxedOption (downloadOptions opts) then pure Url.assumeUrlExists else Url.withUrlOptions (Url.getUrlInfo url) - maybeToList <$> addUrlFile (relaxedOption opts) url urlinfo f + let dlopts = (downloadOptions opts) + -- force using the filename + -- chosen here + { fileOption = Just f + -- don't use youtube-dl + , rawOption = True + } + maybeToList <$> addUrlFile dlopts url urlinfo f else do res <- tryNonAsync $ maybe (error $ "unable to checkUrl of " ++ Remote.name r) @@ -184,27 +185,26 @@ performDownload opts cache todownload = case location todownload of Left _ -> return [] Right (UrlContents sz _) -> maybeToList <$> - downloadRemoteFile r (relaxedOption opts) url f sz + downloadRemoteFile r (downloadOptions opts) url f sz Right (UrlMulti l) -> do kl <- forM l $ \(url', sz, subf) -> - downloadRemoteFile r (relaxedOption opts) url' (f </> fromSafeFilePath subf) sz + downloadRemoteFile r (downloadOptions opts) url' (f </> fromSafeFilePath subf) sz return $ if all isJust kl then catMaybes kl else [] - QuviLink pageurl -> do - let quviurl = setDownloader pageurl QuviDownloader - checkknown quviurl $ do - mp <- withQuviOptions Quvi.query [Quvi.quiet, Quvi.httponly] pageurl - case mp of - Nothing -> return False - Just page -> case headMaybe $ Quvi.pageLinks page of - Nothing -> return False - Just link -> do - let videourl = Quvi.linkUrl link - checkknown videourl $ - rundownload videourl ("." ++ fromMaybe "m" (Quvi.linkSuffix link)) $ \f -> - maybeToList <$> addUrlFileQuvi (relaxedOption opts) quviurl videourl f + MediaLink linkurl -> do + let mediaurl = setDownloader linkurl YoutubeDownloader + let mediakey = Backend.URL.fromUrl mediaurl Nothing + -- Old versions of git-annex that used quvi might have + -- used the quviurl for this, so check i/f it's known + -- to avoid adding it a second time. + let quviurl = setDownloader linkurl QuviDownloader + checkknown mediaurl $ checkknown quviurl $ + ifM (Annex.getState Annex.fast <||> pure (relaxedOption (downloadOptions opts))) + ( addmediafast linkurl mediaurl mediakey + , downloadmedia linkurl mediaurl mediakey + ) where forced = Annex.getState Annex.force @@ -265,6 +265,42 @@ performDownload opts cache todownload = case location todownload of ( return Nothing , tryanother ) + + downloadmedia linkurl mediaurl mediakey + | rawOption (downloadOptions opts) = downloadlink + | otherwise = do + r <- withTmpWorkDir mediakey $ \workdir -> do + dl <- youtubeDl linkurl workdir + case dl of + Right (Just mediafile) -> do + let ext = case takeExtension mediafile of + [] -> ".m" + s -> s + ok <- rundownload linkurl ext $ \f -> do + addWorkTree webUUID mediaurl f mediakey (Just mediafile) + return [mediakey] + return (Just ok) + -- youtude-dl didn't support it, so + -- download it as if the link were + -- an enclosure. + Right Nothing -> Just <$> downloadlink + Left msg -> do + warning msg + return Nothing + return (fromMaybe False r) + where + downloadlink = performDownload opts cache todownload + { location = Enclosure linkurl } + + addmediafast linkurl mediaurl mediakey = + ifM (pure (not (rawOption (downloadOptions opts))) + <&&> youtubeDlSupported linkurl) + ( rundownload linkurl ".m" $ \f -> do + addWorkTree webUUID mediaurl f mediakey Nothing + return [mediakey] + , performDownload opts cache todownload + { location = Enclosure linkurl } + ) defaultTemplate :: String defaultTemplate = "${feedtitle}/${itemtitle}${extension}" diff --git a/Command/Indirect.hs b/Command/Indirect.hs index 862c6e00e..825b82004 100644 --- a/Command/Indirect.hs +++ b/Command/Indirect.hs @@ -42,7 +42,7 @@ start = ifM isDirect perform :: CommandPerform perform = do - showStart "commit" "" + showStart' "commit" Nothing whenM stageDirect $ do showOutput void $ inRepo $ Git.Branch.commitCommand Git.Branch.ManualCommit @@ -100,6 +100,6 @@ perform = do cleanup :: CommandCleanup cleanup = do - showStart "indirect" "" + showStart' "indirect" Nothing showEndOk return True diff --git a/Command/Init.hs b/Command/Init.hs index 3c38c0f8a..e7f57c29c 100644 --- a/Command/Init.hs +++ b/Command/Init.hs @@ -40,7 +40,7 @@ seek = commandAction . start start :: InitOptions -> CommandStart start os = do - showStart "init" (initDesc os) + showStart' "init" (Just $ initDesc os) next $ perform os perform :: InitOptions -> CommandPerform diff --git a/Command/InitRemote.hs b/Command/InitRemote.hs index d82dc366c..c52ca4c56 100644 --- a/Command/InitRemote.hs +++ b/Command/InitRemote.hs @@ -38,7 +38,7 @@ start (name:ws) = ifM (isJust <$> findExisting name) let c = newConfig name t <- either giveup return (findType config) - showStart "initremote" name + showStart' "initremote" (Just name) next $ perform t name $ M.union config c ) ) diff --git a/Command/Map.hs b/Command/Map.hs index ae568f8cc..9ae73d898 100644 --- a/Command/Map.hs +++ b/Command/Map.hs @@ -189,7 +189,7 @@ same a b {- reads the config of a remote, with progress display -} scan :: Git.Repo -> Annex Git.Repo scan r = do - showStart "map" $ Git.repoDescribe r + showStart' "map" (Just $ Git.repoDescribe r) v <- tryScan r case v of Just r' -> do diff --git a/Command/Merge.hs b/Command/Merge.hs index 4f99093ab..66b519973 100644 --- a/Command/Merge.hs +++ b/Command/Merge.hs @@ -23,7 +23,7 @@ seek _ = do mergeBranch :: CommandStart mergeBranch = do - showStart "merge" "git-annex" + showStart' "merge" (Just "git-annex") next $ do Annex.Branch.update -- commit explicitly, in case no remote branches were merged diff --git a/Command/MetaData.hs b/Command/MetaData.hs index fd5fd0838..9fba1097a 100644 --- a/Command/MetaData.hs +++ b/Command/MetaData.hs @@ -100,7 +100,7 @@ startKeys c o k ai = case getSet o of putStrLn . fromMetaValue stop _ -> do - showStart' "metadata" k ai + showStartKey "metadata" k ai next $ perform c o k perform :: VectorClock -> MetaDataOptions -> Key -> CommandPerform @@ -164,7 +164,7 @@ startBatch (i, (MetaData m)) = case i of Right k -> go k (mkActionItem k) where go k ai = do - showStart' "metadata" k ai + showStartKey "metadata" k ai let o = MetaDataOptions { forFiles = [] , getSet = if MetaData m == emptyMetaData diff --git a/Command/Move.hs b/Command/Move.hs index 04e6aa384..63b5fb8b0 100644 --- a/Command/Move.hs +++ b/Command/Move.hs @@ -87,7 +87,7 @@ start' o move afile key ai = onlyActionOn key $ toHereStart move afile key ai showMoveAction :: Bool -> Key -> ActionItem -> Annex () -showMoveAction move = showStart' (if move then "move" else "copy") +showMoveAction move = showStartKey (if move then "move" else "copy") {- Moves (or copies) the content of an annexed file to a remote. - diff --git a/Command/Multicast.hs b/Command/Multicast.hs index 7b0d54e8e..9a518a18f 100644 --- a/Command/Multicast.hs +++ b/Command/Multicast.hs @@ -78,7 +78,7 @@ seek (MultiCastOptions Receive _ _) = giveup "Cannot specify list of files with genAddress :: CommandStart genAddress = do - showStart "gen-address" "" + showStart' "gen-address" Nothing k <- uftpKey (s, ok) <- case k of KeyContainer s -> liftIO $ genkey (Param s) @@ -130,7 +130,7 @@ send ups fs = withTmpFile "send" $ \t h -> do whenM isDirect $ giveup "Sorry, multicast send cannot be done from a direct mode repository." - showStart "generating file list" "" + showStart' "generating file list" Nothing fs' <- seekHelper LsFiles.inRepo =<< workTreeItems fs matcher <- Limit.getMatcher let addlist f o = whenM (matcher $ MatchingFile $ FileInfo f f) $ @@ -143,7 +143,7 @@ send ups fs = withTmpFile "send" $ \t h -> do liftIO $ hClose h showEndOk - showStart "sending files" "" + showStart' "sending files" Nothing showOutput serverkey <- uftpKey u <- getUUID @@ -169,7 +169,7 @@ send ups fs = withTmpFile "send" $ \t h -> do receive :: [CommandParam] -> CommandStart receive ups = do - showStart "receiving multicast files" "" + showStart' "receiving multicast files" Nothing showNote "Will continue to run until stopped by ctrl-c" showOutput diff --git a/Command/NumCopies.hs b/Command/NumCopies.hs index 9e467da7a..d10f70063 100644 --- a/Command/NumCopies.hs +++ b/Command/NumCopies.hs @@ -48,7 +48,7 @@ startGet = next $ next $ do startSet :: Int -> CommandStart startSet n = do allowMessages - showStart "numcopies" (show n) + showStart' "numcopies" (Just $ show n) next $ next $ do setGlobalNumCopies $ NumCopies n return True diff --git a/Command/P2P.hs b/Command/P2P.hs index 58b5c3bd7..40a49b49f 100644 --- a/Command/P2P.hs +++ b/Command/P2P.hs @@ -97,7 +97,7 @@ genAddresses addrs = do -- Address is read from stdin, to avoid leaking it in shell history. linkRemote :: RemoteName -> CommandStart linkRemote remotename = do - showStart "p2p link" remotename + showStart' "p2p link" (Just remotename) next $ next promptaddr where promptaddr = do @@ -123,7 +123,7 @@ linkRemote remotename = do startPairing :: RemoteName -> [P2PAddress] -> CommandStart startPairing _ [] = giveup "No P2P networks are currrently available." startPairing remotename addrs = do - showStart "p2p pair" remotename + showStart' "p2p pair" (Just remotename) ifM (liftIO Wormhole.isInstalled) ( next $ performPairing remotename addrs , giveup "Magic Wormhole is not installed, and is needed for pairing. Install it from your distribution or from https://github.com/warner/magic-wormhole/" diff --git a/Command/RegisterUrl.hs b/Command/RegisterUrl.hs index 008e6436c..ef73e6728 100644 --- a/Command/RegisterUrl.hs +++ b/Command/RegisterUrl.hs @@ -27,10 +27,10 @@ seek = withWords start start :: [String] -> CommandStart start (keyname:url:[]) = do let key = mkKey keyname - showStart "registerurl" url + showStart' "registerurl" (Just url) next $ perform key url start [] = do - showStart "registerurl" "stdin" + showStart' "registerurl" (Just "stdin") next massAdd start _ = giveup "specify a key and an url" diff --git a/Command/Reinit.hs b/Command/Reinit.hs index 25001db43..6defa4e95 100644 --- a/Command/Reinit.hs +++ b/Command/Reinit.hs @@ -25,7 +25,7 @@ seek = withWords start start :: [String] -> CommandStart start ws = do - showStart "reinit" s + showStart' "reinit" (Just s) next $ perform s where s = unwords ws diff --git a/Command/ResolveMerge.hs b/Command/ResolveMerge.hs index 0ba6efb36..df72e24d4 100644 --- a/Command/ResolveMerge.hs +++ b/Command/ResolveMerge.hs @@ -23,7 +23,7 @@ seek = withNothing start start :: CommandStart start = do - showStart "resolvemerge" "" + showStart' "resolvemerge" Nothing us <- fromMaybe nobranch <$> inRepo Git.Branch.current d <- fromRepo Git.localGitDir let merge_head = d </> "MERGE_HEAD" diff --git a/Command/Schedule.hs b/Command/Schedule.hs index 5814d99f1..b39e652b2 100644 --- a/Command/Schedule.hs +++ b/Command/Schedule.hs @@ -28,7 +28,7 @@ start = parse parse (name:[]) = go name performGet parse (name:expr:[]) = go name $ \uuid -> do allowMessages - showStart "schedule" name + showStart' "schedule" (Just name) performSet expr uuid parse _ = giveup "Specify a repository." diff --git a/Command/SetPresentKey.hs b/Command/SetPresentKey.hs index da2a6fa3d..6e7075e8c 100644 --- a/Command/SetPresentKey.hs +++ b/Command/SetPresentKey.hs @@ -23,7 +23,7 @@ seek = withWords start start :: [String] -> CommandStart start (ks:us:vs:[]) = do - showStart' "setpresentkey" k (mkActionItem k) + showStartKey "setpresentkey" k (mkActionItem k) next $ perform k (toUUID us) s where k = fromMaybe (giveup "bad key") (file2key ks) diff --git a/Command/Sync.hs b/Command/Sync.hs index b2d0bd275..f63260ed4 100644 --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -299,7 +299,7 @@ syncRemotes' ps available = commit :: SyncOptions -> CommandStart commit o = stopUnless shouldcommit $ next $ next $ do commitmessage <- maybe commitMsg return (messageOption o) - showStart "commit" "" + showStart' "commit" Nothing Annex.Branch.commit "update" ifM isDirect ( do @@ -342,7 +342,7 @@ mergeLocal mergeconfig resolvemergeoverride currbranch@(Just _, _) = where go Nothing = stop go (Just syncbranch) = do - showStart "merge" $ Git.Ref.describe syncbranch + showStart' "merge" (Just $ Git.Ref.describe syncbranch) next $ next $ merge currbranch mergeconfig resolvemergeoverride Git.Branch.ManualCommit syncbranch mergeLocal _ _ (Nothing, madj) = do b <- inRepo Git.Branch.currentUnsafe @@ -401,7 +401,7 @@ updateBranch syncbranch updateto g = pullRemote :: SyncOptions -> [Git.Merge.MergeConfig] -> Remote -> CurrBranch -> CommandStart pullRemote o mergeconfig remote branch = stopUnless (pure $ pullOption o && wantpull) $ do - showStart "pull" (Remote.name remote) + showStart' "pull" (Just (Remote.name remote)) next $ do showOutput stopUnless fetch $ @@ -438,7 +438,7 @@ mergeRemote remote currbranch mergeconfig resolvemergeoverride = ifM isBareRepo pushRemote :: SyncOptions -> Remote -> CurrBranch -> CommandStart pushRemote _o _remote (Nothing, _) = stop pushRemote o remote (Just branch, _) = stopUnless (pure (pushOption o) <&&> needpush) $ do - showStart "push" (Remote.name remote) + showStart' "push" (Just (Remote.name remote)) next $ next $ do showOutput ok <- inRepoWithSshOptionsTo (Remote.repo remote) gc $ @@ -651,7 +651,7 @@ syncFile ebloom rs af k = onlyActionOn' k $ do , return [] ) get have = includeCommandAction $ do - showStart' "get" k (mkActionItem af) + showStartKey "get" k (mkActionItem af) next $ next $ getKey' k af have wantput r @@ -703,7 +703,7 @@ seekExportContent rs = or <$> forM rs go cleanupLocal :: CurrBranch -> CommandStart cleanupLocal (Nothing, _) = stop cleanupLocal (Just currb, _) = do - showStart "cleanup" "local" + showStart' "cleanup" (Just "local") next $ next $ do delbranch $ syncBranch currb delbranch $ syncBranch $ Git.Ref.base $ Annex.Branch.name @@ -717,7 +717,7 @@ cleanupLocal (Just currb, _) = do cleanupRemote :: Remote -> CurrBranch -> CommandStart cleanupRemote _ (Nothing, _) = stop cleanupRemote remote (Just b, _) = do - showStart "cleanup" (Remote.name remote) + showStart' "cleanup" (Just (Remote.name remote)) next $ next $ inRepo $ Git.Command.runBool [ Param "push" diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs index 75e438d79..1a5da42b2 100644 --- a/Command/TestRemote.hs +++ b/Command/TestRemote.hs @@ -58,7 +58,7 @@ seek o = commandAction $ start (fromInteger $ sizeOption o) (testRemote o) start :: Int -> RemoteName -> CommandStart start basesz name = do - showStart "testremote" name + showStart' "testremote" (Just name) fast <- Annex.getState Annex.fast r <- either giveup disableExportTree =<< Remote.byName' name rs <- catMaybes <$> mapM (adjustChunkSize r) (chunkSizes basesz fast) diff --git a/Command/Trust.hs b/Command/Trust.hs index 66a1c81b3..5f161af26 100644 --- a/Command/Trust.hs +++ b/Command/Trust.hs @@ -27,7 +27,7 @@ trustCommand c level = withWords start where start ws = do let name = unwords ws - showStart c name + showStart' c (Just name) u <- Remote.nameToUUID name next $ perform u perform uuid = do diff --git a/Command/Ungroup.hs b/Command/Ungroup.hs index ddcdba466..357f5685f 100644 --- a/Command/Ungroup.hs +++ b/Command/Ungroup.hs @@ -23,7 +23,7 @@ seek = withWords start start :: [String] -> CommandStart start (name:g:[]) = do - showStart "ungroup" name + showStart' "ungroup" (Just name) u <- Remote.nameToUUID name next $ perform u g start _ = giveup "Specify a repository and a group." diff --git a/Command/Unused.hs b/Command/Unused.hs index 916e6db25..27018cf38 100644 --- a/Command/Unused.hs +++ b/Command/Unused.hs @@ -70,7 +70,7 @@ start o = do Just "." -> (".", checkUnused refspec) Just "here" -> (".", checkUnused refspec) Just n -> (n, checkRemoteUnused n refspec) - showStart "unused" name + showStart' "unused" (Just name) next perform checkUnused :: RefSpec -> CommandPerform @@ -338,5 +338,5 @@ startUnused message unused badunused tmpunused maps n = search case M.lookup n m of Nothing -> search rest Just key -> do - showStart message (show n) + showStart' message (Just $ show n) next $ a key diff --git a/Command/Upgrade.hs b/Command/Upgrade.hs index 696b794a5..1c3e62695 100644 --- a/Command/Upgrade.hs +++ b/Command/Upgrade.hs @@ -23,7 +23,7 @@ seek = withNothing start start :: CommandStart start = do - showStart "upgrade" "." + showStart' "upgrade" Nothing whenM (isNothing <$> getVersion) $ do initialize Nothing Nothing r <- upgrade False latestVersion diff --git a/Command/VAdd.hs b/Command/VAdd.hs index c94ce5722..800573732 100644 --- a/Command/VAdd.hs +++ b/Command/VAdd.hs @@ -23,7 +23,7 @@ seek = withWords start start :: [String] -> CommandStart start params = do - showStart "vadd" "" + showStart' "vadd" Nothing withCurrentView $ \view -> do let (view', change) = refineView view $ map parseViewParam $ reverse params diff --git a/Command/VCycle.hs b/Command/VCycle.hs index 28326e16f..9c1e24e0d 100644 --- a/Command/VCycle.hs +++ b/Command/VCycle.hs @@ -27,7 +27,7 @@ start = go =<< currentView where go Nothing = giveup "Not in a view." go (Just v) = do - showStart "vcycle" "" + showStart' "vcycle" Nothing let v' = v { viewComponents = vcycle [] (viewComponents v) } if v == v' then do diff --git a/Command/VFilter.hs b/Command/VFilter.hs index 130e2550c..fa545cddd 100644 --- a/Command/VFilter.hs +++ b/Command/VFilter.hs @@ -21,7 +21,7 @@ seek = withWords start start :: [String] -> CommandStart start params = do - showStart "vfilter" "" + showStart' "vfilter" Nothing withCurrentView $ \view -> do let view' = filterView view $ map parseViewParam $ reverse params diff --git a/Command/VPop.hs b/Command/VPop.hs index 58411001b..71da586c2 100644 --- a/Command/VPop.hs +++ b/Command/VPop.hs @@ -28,7 +28,7 @@ start ps = go =<< currentView where go Nothing = giveup "Not in a view." go (Just v) = do - showStart "vpop" (show num) + showStart' "vpop" (Just $ show num) removeView v (oldvs, vs) <- splitAt (num - 1) . filter (sameparentbranch v) <$> recentViews diff --git a/Command/View.hs b/Command/View.hs index 513e6d10c..298fad0ee 100644 --- a/Command/View.hs +++ b/Command/View.hs @@ -27,7 +27,7 @@ seek = withWords start start :: [String] -> CommandStart start [] = giveup "Specify metadata to include in view" start ps = do - showStart "view" "" + showStart' "view" Nothing view <- mkView ps go view =<< currentView where diff --git a/Command/Wanted.hs b/Command/Wanted.hs index fc1fa86bd..ac4175ecd 100644 --- a/Command/Wanted.hs +++ b/Command/Wanted.hs @@ -35,7 +35,7 @@ cmd' name desc getter setter = noMessages $ start (rname:[]) = go rname (performGet getter) start (rname:expr:[]) = go rname $ \uuid -> do allowMessages - showStart name rname + showStart' name (Just rname) performSet setter expr uuid start _ = giveup "Specify a repository." diff --git a/Command/Whereis.hs b/Command/Whereis.hs index c5543bc66..295d11994 100644 --- a/Command/Whereis.hs +++ b/Command/Whereis.hs @@ -53,7 +53,7 @@ start remotemap file key = startKeys remotemap key (mkActionItem afile) startKeys :: M.Map UUID Remote -> Key -> ActionItem -> CommandStart startKeys remotemap key ai = do - showStart' "whereis" key ai + showStartKey "whereis" key ai next $ perform remotemap key perform :: M.Map UUID Remote -> Key -> CommandPerform |