youtube-dl working

Including resuming and cleanup of incomplete downloads.

Still todo: --fast, --relaxed, importfeed, disk reserve checking,
quvi code cleanup.

This commit was sponsored by Anthony DeRobertis on Patreon.

6 files changed, 101 insertions, 29 deletions

diff --git a/Annex/Content.hs b/Annex/Content.hs
index 5b11c7eb1..0899a12ab 100644
--- a/Annex/Content.hs
+++ b/Annex/Content.hs
@@ -1017,14 +1017,15 @@ pruneTmpWorkDirBefore f action = do
 {- Runs an action, passing it a temporary work directory where
  - it can write files while receiving the content of a key.
  -
- - On exception, the temporary work directory is left, so resumes can
- - use it.
+ - On exception, or when the action returns a Left value,
+ - the temporary work directory is left, so resumes can use it.
  -}
-withTmpWorkDir :: Key -> (FilePath -> Annex a) -> Annex a
-withTmpWorkDir key action = withTmp key $ \obj -> do
+withTmpWorkDir :: Key -> (FilePath -> Annex (Either a b)) -> Annex (Either a b)
+withTmpWorkDir key action = do
 	-- Create the object file if it does not exist. This way,
 	-- staleKeysPrune only has to look for object files, and can
 	-- clean up gitAnnexTmpWorkDir for those it finds.
+	obj <- prepTmp key
 	unlessM (liftIO $ doesFileExist obj) $ do
 		liftIO $ writeFile obj ""
 		setAnnexFilePerm obj
@@ -1032,7 +1033,9 @@ withTmpWorkDir key action = withTmp key $ \obj -> do
 	liftIO $ createDirectoryIfMissing True tmpdir
 	setAnnexDirPerm tmpdir
 	res <- action tmpdir
-	liftIO $ removeDirectoryRecursive tmpdir
+	case res of
+		Right _ -> liftIO $ removeDirectoryRecursive tmpdir
+		Left _ -> noop
 	return res
 
 {- Finds items in the first, smaller list, that are not
diff --git a/Annex/Locations.hs b/Annex/Locations.hs
index acae9c079..bb45d8a3e 100644
--- a/Annex/Locations.hs
+++ b/Annex/Locations.hs
@@ -263,7 +263,7 @@ gitAnnexTmpWorkDir :: FilePath -> FilePath
 gitAnnexTmpWorkDir p =
 	let (dir, f) = splitFileName p
 	-- Using a prefix avoids name conflict with any other keys.
-	in dir </> "work." </> f
+	in dir </> "work." ++ f
 
 {- .git/annex/bad/ is used for bad files found during fsck -}
 gitAnnexBadDir :: Git.Repo -> FilePath
diff --git a/Annex/Notification.hs b/Annex/Notification.hs
index 6a13d91dd..f3d5006e3 100644
--- a/Annex/Notification.hs
+++ b/Annex/Notification.hs
@@ -39,7 +39,7 @@ instance Transferrable URLString where
 {- Wrap around an action that performs a transfer, which may run multiple
  - attempts. Displays notification when supported and when the user asked
  - for it. -}
-notifyTransfer :: Transferrable t => Direction -> t -> (NotifyWitness -> Annex Bool) -> Annex Bool
+notifyTransfer :: Transferrable t => Observable v => Direction -> t -> (NotifyWitness -> Annex v) -> Annex v
 notifyTransfer direction t a = case descTransfrerrable t of
 	Nothing -> a NotifyWitness
 	Just desc -> do
@@ -51,12 +51,13 @@ notifyTransfer direction t a = case descTransfrerrable t of
 				startnotification <- liftIO $ if notifyStart wanted
 					then Just <$> Notify.notify client (startedTransferNote direction desc)
 					else pure Nothing
-				ok <- a NotifyWitness
+				res <- a NotifyWitness
+				let ok = observeBool res
 				when (notifyFinish wanted) $ liftIO $ void $ maybe 
 					(Notify.notify client $ finishedTransferNote ok direction desc)
 					(\n -> Notify.replace client n $ finishedTransferNote ok direction desc)
 					startnotification
-				return ok
+				return res
 			else a NotifyWitness
 #else
 		a NotifyWitness
diff --git a/Annex/Quvi.hs b/Annex/Quvi.hs
index efc63ca9f..79b9ee6fa 100644
--- a/Annex/Quvi.hs
+++ b/Annex/Quvi.hs
@@ -17,7 +17,7 @@ import Utility.Url
 withQuviOptions :: forall a. Query a -> [QuviParams] -> URLString -> Annex a
 withQuviOptions a ps url = do
 	v <- quviVersion
-	opts <- map Param . annexQuviOptions <$> Annex.getGitConfig
+	opts <- return []
 	liftIO $ a v (concatMap (\mkp -> mkp v) ps ++ opts) url
 
 quviSupported :: URLString -> Annex Bool
diff --git a/Annex/Transfer.hs b/Annex/Transfer.hs
index 3fcf1a1b9..ccb5409a7 100644
--- a/Annex/Transfer.hs
+++ b/Annex/Transfer.hs
@@ -5,7 +5,7 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-{-# LANGUAGE CPP, FlexibleInstances, BangPatterns #-}
+{-# LANGUAGE CPP, BangPatterns #-}
 
 module Annex.Transfer (
 	module X,
@@ -27,7 +27,6 @@ import Annex.Perms
 import Utility.Metered
 import Annex.LockPool
 import Types.Key
-import Types.Remote (Verification(..))
 import qualified Types.Remote as Remote
 import Types.Concurrency
 
@@ -35,23 +34,6 @@ import Control.Concurrent
 import qualified Data.Map.Strict as M
 import Data.Ord
 
-class Observable a where
-	observeBool :: a -> Bool
-	observeFailure :: a
-
-instance Observable Bool where
-	observeBool = id
-	observeFailure = False
-
-instance Observable (Bool, Verification) where
-	observeBool = fst
-	observeFailure = (False, UnVerified)
-
-instance Observable (Either e Bool) where
-	observeBool (Left _) = False
-	observeBool (Right b) = b
-	observeFailure = Right False
-
 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
diff --git a/Annex/YoutubeDl.hs b/Annex/YoutubeDl.hs
new file mode 100644
index 000000000..e646f3fe8
--- /dev/null
+++ b/Annex/YoutubeDl.hs
@@ -0,0 +1,86 @@
+{- youtube-dl integration for git-annex
+ -
+ - Copyright 2017 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.YoutubeDl where
+
+import Annex.Common
+import qualified Annex
+import Annex.Content
+import Utility.Url (URLString)
+
+-- Runs youtube-dl in a work directory, to download a single media file
+-- from the url. Reutrns the path to the media file in the work directory.
+--
+-- If youtube-dl fails without writing any files to the work directory, 
+-- or is not installed, returns Right Nothing.
+--
+-- The work directory can contain files from a previous run of youtube-dl
+-- and it will resume. It should not contain any other files though,
+-- and youtube-dl needs to finish up with only one file in the directory
+-- so we know which one it downloaded.
+--
+-- (Note that we can't use --output to specifiy the file to download to,
+-- due to <https://github.com/rg3/youtube-dl/issues/14864>)
+youtubeDl :: URLString -> FilePath -> Annex (Either String (Maybe FilePath))
+youtubeDl url workdir = ifM (liftIO (inPath "youtube-dl") <&&> runcmd)
+	( do
+		fs <- liftIO $ filterM (doesFileExist) =<< dirContents workdir
+		case fs of
+			(f:[]) -> return (Right (Just f))
+			[] -> return nofiles
+			_ -> return (toomanyfiles fs)
+	, do
+		fs <- liftIO $ filterM (doesFileExist) =<< dirContents workdir
+		if null fs
+			then return (Right Nothing)
+			else return (Left "youtube-dl download is incomplete. Run the command again to resume.")
+	)
+  where
+	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 ++
+			[ Param url
+			-- To make youtube-dl only download one file,
+			-- when given a page with a video and a playlist,
+			-- download only the video.
+			, Param "--no-playlist"
+			-- And when given a page with only a playlist,
+			-- download only the first video on the playlist.
+			-- (Assumes the video is somewhat stable, but
+			-- this is the only way to prevent youtube-dl
+			-- from downloading the whole playlist.)
+			, Param "--playlist-items", Param "0"
+			-- TODO --max-filesize
+			] ++
+			if quiet then [ Param "--quiet" ] else []
+		liftIO $ boolSystem' "youtube-dl" opts' $
+			\p -> p { cwd = Just workdir }
+
+-- Download a media file to a destination, 
+youtubeDlTo :: Key -> URLString -> FilePath -> Annex Bool
+youtubeDlTo key url dest = do
+	res <- withTmpWorkDir key $ \workdir -> do
+		dl <- youtubeDl url workdir
+		case dl of
+			Right (Just mediafile) -> do
+				liftIO $ renameFile mediafile dest
+				return (Right True)
+			Right Nothing -> return (Right False)
+			Left msg -> return (Left msg)
+	case res of
+		Left msg -> do
+			warning msg
+			return False
+		Right r -> return r
+
+-- Check if youtube-dl can still find media in an url.
+youtubeDlSupported :: URLString -> Annex (Either String Bool)
+youtubeDlSupported url = liftIO $ catchMsgIO $
+	snd <$> processTranscript "youtube-dl" [ url, "--simulate" ] Nothing