From 3b3f7512f6d0b91de21f6fcc4aba8897174bc4a8 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 29 Nov 2017 15:49:05 -0400 Subject: 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. --- Annex/Content.hs | 13 +++++--- Annex/Locations.hs | 2 +- Annex/Notification.hs | 7 +++-- Annex/Quvi.hs | 2 +- Annex/Transfer.hs | 20 +----------- Annex/YoutubeDl.hs | 86 +++++++++++++++++++++++++++++++++++++++++++++++++++ 6 files changed, 101 insertions(+), 29 deletions(-) create mode 100644 Annex/YoutubeDl.hs (limited to 'Annex') 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 + - + - 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 ) +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 -- cgit v1.2.3