check youtube-dl for --fast and --relaxed when adding new file

The filename comes from youtube-dl also.

This commit was sponsored by Denis Dzyubenko on Patreon.

Annex/YoutubeDl.hs

@@ -43,9 +43,8 @@ youtubeDl url workdir = ifM (liftIO (inPath "youtube-dl") <&&> runcmd)
 	nofiles = Left "youtube-dl did not put any media in its work directory, perhaps it's been configured to store files somewhere else?"
 	toomanyfiles fs = Left $ "youtube-dl downloaded multiple media files; git-annex is only able to deal with one per url: " ++ show fs
 	runcmd = do
-		opts <- map Param . annexYoutubeDlOptions <$> Annex.getGitConfig
 		quiet <- commandProgressDisabled
-		let opts' = opts ++
+		opts <- youtubeDlOpts $
 			[ Param url
 			-- To make youtube-dl only download one file,
 			-- when given a page with a video and a playlist,
@@ -60,7 +59,7 @@ youtubeDl url workdir = ifM (liftIO (inPath "youtube-dl") <&&> runcmd)
 			-- TODO --max-filesize
 			] ++
 			if quiet then [ Param "--quiet" ] else []
-		liftIO $ boolSystem' "youtube-dl" opts' $
+		liftIO $ boolSystem' "youtube-dl" opts $
 			\p -> p { cwd = Just workdir }
 
 -- Download a media file to a destination, 
@@ -81,9 +80,32 @@ youtubeDlTo key url dest = do
 youtubeDlSupported :: URLString -> Annex Bool
 youtubeDlSupported url = either (const False) id <$> youtubeDlCheck url
 
--- Check if youtube-dl can still find media in an url.
+-- Check if youtube-dl can find media in an url.
 youtubeDlCheck :: URLString -> Annex (Either String Bool)
 youtubeDlCheck url = catchMsgIO $ do
+	opts <- youtubeDlOpts [ Param url, Param "--simulate" ]
+	liftIO $ snd <$> processTranscript "youtube-dl" (toCommand opts) Nothing
+
+-- Ask youtube-dl for the filename of media in an url.
+--
+-- (This is not always identical to the filename it uses when downloading.)
+youtubeDlFileName :: URLString -> Annex (Either String FilePath)
+youtubeDlFileName url = flip catchIO (pure . Left . show) $ do
+	-- Sometimes youtube-dl will fail with an ugly backtrace
+	-- (eg, http://bugs.debian.org/874321)
+	-- so catch stderr as well as stdout to avoid the user seeing it. 
+	-- --no-warnings avoids warning messages that are output to stdout.
+	opts <- youtubeDlOpts
+		[ Param url
+		, Param "--get-filename"
+		, Param "--no-warnings"
+		]
+	(output, ok) <- liftIO $ processTranscript "youtube-dl" (toCommand opts) Nothing
+	return $ case (ok, lines output) of
+		(True, (f:_)) | not (null f) -> Right f
+		_ -> Left "no media in url"
+
+youtubeDlOpts :: [CommandParam] -> Annex [CommandParam]
+youtubeDlOpts addopts = do
 	opts <- map Param . annexYoutubeDlOptions <$> Annex.getGitConfig
-	let opts' = opts ++ [ Param url, Param "--simulate" ]
-	liftIO $ snd <$> processTranscript "youtube-dl" (toCommand opts') Nothing
+	return (opts ++ addopts)

Command/AddUrl.hs

@@ -244,7 +244,7 @@ addUrlChecked relaxed url u checkexistssize key =
 addUrlFile :: Maybe AddUrlOptions -> Bool -> URLString -> Url.UrlInfo -> FilePath -> Annex (Maybe Key)
 addUrlFile mo relaxed url urlinfo file =
 	ifM (Annex.getState Annex.fast <||> pure relaxed)
-		( nodownloadWeb url urlinfo file
+		( nodownloadWeb mo url urlinfo file
 		, downloadWeb mo url urlinfo file
 		)
 
@@ -274,7 +274,7 @@ downloadWeb mo url urlinfo file =
 				case dl of
 					Right (Just mediafile) -> do
 						pruneTmpWorkDirBefore tmp (liftIO . nukeFile)
-						let dest = if isJust (fileOption <$> mo)
+						let dest = if isJust (fileOption =<< mo)
 							then file
 							else takeFileName mediafile
 						checkCanAdd dest $ do
@@ -372,17 +372,30 @@ addWorkTree u url file key mtmp = case mtmp of
 			, maybe noop (\tmp -> pruneTmpWorkDirBefore tmp (liftIO . nukeFile)) mtmp
 			)
 
--- TODO youtube-dl
-nodownloadWeb :: URLString -> Url.UrlInfo -> FilePath -> Annex (Maybe Key)
-nodownloadWeb url urlinfo file
-	| Url.urlExists urlinfo = checkCanAdd file $ do
-		liftIO $ createDirectoryIfMissing True (parentDir file)
-		let key = Backend.URL.fromUrl url (Url.urlSize urlinfo)
-		addWorkTree webUUID url file key Nothing
-		return (Just key)
+nodownloadWeb :: Maybe AddUrlOptions -> URLString -> Url.UrlInfo -> FilePath -> Annex (Maybe Key)
+nodownloadWeb mo url urlinfo file
+	| Url.urlExists urlinfo = go =<< youtubeDlFileName url
 	| otherwise = do
 		warning $ "unable to access url: " ++ url
 		return Nothing
+  where
+	go (Left _) = do
+		let key = Backend.URL.fromUrl url (Url.urlSize urlinfo)
+		nodownloadWeb' url key file
+	go (Right mediafile) = do
+		let dest = if isJust (fileOption =<< mo)
+			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