diff --git a/Annex/Branch.hs b/Annex/Branch.hs --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -500,11 +500,19 @@ {- Commit message used when making a commit of whatever data has changed - to the git-annex branch. -} commitMessage :: Annex String -commitMessage = fromMaybe "update" . annexCommitMessage <$> Annex.getGitConfig +commitMessage = fromMaybe "update" <$> getCommitMessage {- Commit message used when creating the branch. -} createMessage :: Annex String -createMessage = fromMaybe "branch created" . annexCommitMessage <$> Annex.getGitConfig +createMessage = fromMaybe "branch created" <$> getCommitMessage + +getCommitMessage :: Annex (Maybe String) +getCommitMessage = do + config <- Annex.getGitConfig + case annexCommitMessageCommand config of + Nothing -> return (annexCommitMessage config) + Just cmd -> catchDefaultIO (annexCommitMessage config) $ + Just <$> liftIO (readProcess "sh" ["-c", cmd]) {- Stages the journal, and commits staged changes to the branch. -} commit :: String -> Annex () diff --git a/Annex/YoutubeDl.hs b/Annex/YoutubeDl.hs --- a/Annex/YoutubeDl.hs +++ b/Annex/YoutubeDl.hs @@ -1,10 +1,12 @@ {- yt-dlp (and deprecated youtube-dl) integration for git-annex - - - Copyright 2017-2023 Joey Hess + - Copyright 2017-2024 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE DeriveGeneric #-} + module Annex.YoutubeDl ( youtubeDl, youtubeDlTo, @@ -13,6 +15,8 @@ youtubeDlFileName, youtubeDlFileNameHtmlOnly, youtubeDlCommand, + youtubePlaylist, + YoutubePlaylistItem(..), ) where import Annex.Common @@ -23,12 +27,18 @@ import Utility.HtmlDetect import Utility.Process.Transcript import Utility.Metered +import Utility.Tmp import Messages.Progress import Logs.Transfer import Network.URI import Control.Concurrent.Async import Text.Read +import Data.Either +import qualified Data.Aeson as Aeson +import GHC.Generics +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 -- youtube-dl can follow redirects to anywhere, including potentially -- localhost or a private address. So, it's only allowed to download @@ -125,8 +135,12 @@ , Param "--playlist-items", Param "0" ] ++ if isytdlp cmd - then - [ Param "--progress-template" + then + -- Avoid warnings, which go to + -- stderr and may mess up + -- git-annex's display. + [ Param "--no-warnings" + , Param "--progress-template" , Param progressTemplate , Param "--print-to-file" , Param "after_move:filepath" @@ -324,3 +338,73 @@ - was buggy and is no longer done. -} parseYoutubeDlProgress :: ProgressParser parseYoutubeDlProgress _ = (Nothing, Nothing, "") + +{- List the items that yt-dlp can download from an url. + - + - Note that this does not check youtubeDlAllowed because it does not + - download content. + -} +youtubePlaylist :: URLString -> Annex (Either String [YoutubePlaylistItem]) +youtubePlaylist url = do + cmd <- youtubeDlCommand + if cmd == "yt-dlp" + then liftIO $ youtubePlaylist' url cmd + else return $ Left $ "Scraping needs yt-dlp, but git-annex has been configured to use " ++ cmd + +youtubePlaylist' :: URLString -> String -> IO (Either String [YoutubePlaylistItem]) +youtubePlaylist' url cmd = withTmpFile "yt-dlp" $ \tmpfile h -> do + hClose h + (outerr, ok) <- processTranscript cmd + [ "--simulate" + , "--flat-playlist" + -- Skip live videos in progress + , "--match-filter", "!is_live" + , "--print-to-file" + -- Write json with selected fields. + , "%(.{" ++ intercalate "," youtubePlaylistItemFields ++ "})j" + , tmpfile + , url + ] + Nothing + if ok + then flip catchIO (pure . Left . show) $ do + v <- map Aeson.eitherDecodeStrict . B8.lines + <$> B.readFile tmpfile + return $ case partitionEithers v of + ((parserr:_), _) -> + Left $ "yt-dlp json parse errror: " ++ parserr + ([], r) -> Right r + else return $ Left $ if null outerr + then "yt-dlp failed" + else "yt-dlp failed: " ++ outerr + +-- There are other fields that yt-dlp can extract, but these are similar to +-- the information from an RSS feed. +youtubePlaylistItemFields :: [String] +youtubePlaylistItemFields = + [ "playlist_title" + , "playlist_uploader" + , "title" + , "description" + , "license" + , "url" + , "timestamp" + ] + +-- Parse JSON generated by yt-dlp for playlist. Note that any field +-- may be omitted when that information is not supported for a given website. +data YoutubePlaylistItem = YoutubePlaylistItem + { youtube_playlist_title :: Maybe String + , youtube_playlist_uploader :: Maybe String + , youtube_title :: Maybe String + , youtube_description :: Maybe String + , youtube_license :: Maybe String + , youtube_url :: Maybe String + , youtube_timestamp :: Maybe Integer -- ^ unix timestamp + } deriving (Generic, Show) + +instance Aeson.FromJSON YoutubePlaylistItem + where + parseJSON = Aeson.genericParseJSON Aeson.defaultOptions + { Aeson.fieldLabelModifier = drop (length "youtube_") } + diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs --- a/Assistant/Threads/Committer.hs +++ b/Assistant/Threads/Committer.hs @@ -1,6 +1,6 @@ {- git-annex assistant commit thread - - - Copyright 2012-2023 Joey Hess + - Copyright 2012-2024 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -19,7 +19,6 @@ import Assistant.Drop import Types.Transfer import Logs.Location -import qualified Annex.Queue import Utility.ThreadScheduler import qualified Utility.Lsof as Lsof import qualified Utility.DirWatcher as DirWatcher @@ -35,11 +34,14 @@ import Annex.CurrentBranch import Annex.FileMatcher import qualified Annex +import qualified Annex.Queue +import qualified Annex.Branch import Utility.InodeCache import qualified Database.Keys import qualified Command.Sync import qualified Command.Add import Config.GitConfig +import qualified Git.Branch import Utility.Tuple import Utility.Metered import qualified Utility.RawFilePath as R @@ -240,9 +242,18 @@ Left _ -> return False Right _ -> do cmode <- annexCommitMode <$> Annex.getGitConfig - ok <- Command.Sync.commitStaged cmode msg + ok <- inRepo $ Git.Branch.commitCommand cmode + (Git.Branch.CommitQuiet True) + [ Param "-m" + , Param msg + ] when ok $ Command.Sync.updateBranches =<< getCurrentBranch + {- Commit the git-annex branch. This comes after + - the commit of the staged changes, so that + - annex.commitmessage-command can examine that + - commit. -} + Annex.Branch.commit =<< Annex.Branch.commitMessage return ok {- If there are PendingAddChanges, or InProcessAddChanges, the files diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,23 @@ +git-annex (10.20240227) upstream; urgency=medium + + * importfeed: Added --scrape option, which uses yt-dlp to screen scrape + the equivilant of an RSS feed. + * importfeed --force: Don't treat it as a failure when an already + downloaded file exists. (Fixes a behavior change introduced in + 10.20230626.) + * importfeed --force: Avoid creating duplicates of existing + already downloaded files when yt-dlp or a special remote was used. + * addurl, importfeed: Added --raw-except option. + * stack.yaml: Update to lts-22.9 and use crypton. + * assistant, undo: When committing, let the usual git commit + hooks run. + * Added annex.commitmessage-command config. + * pre-commit: Avoid committing the git-annex branch + (except when a commit is made in a view, which changes metadata). + * Pass --no-warnings to yt-dlp. + + -- Joey Hess Tue, 27 Feb 2024 12:58:30 -0400 + git-annex (10.20240129) upstream; urgency=medium * info: Added "annex sizes of repositories" table to the overall display. diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -64,6 +64,7 @@ { relaxedOption :: Bool , rawOption :: Bool , noRawOption :: Bool + , rawExceptOption :: Maybe (DeferredParse Remote) , fileOption :: Maybe FilePath , preserveFilenameOption :: Bool , checkGitIgnoreOption :: CheckGitIgnore @@ -105,6 +106,13 @@ ( long "no-raw" <> help "prevent downloading raw url content, must use special handling" ) + <*> optional + (mkParseRemoteOption <$> strOption + ( long "raw-except" <> metavar paramRemote + <> help "disable special handling except by this remote" + <> completeRemotes + ) + ) <*> (if withfileoptions then optional (strOption ( long "file" <> metavar paramFile @@ -123,7 +131,7 @@ seek o = startConcurrency commandStages $ do addunlockedmatcher <- addUnlockedMatcher let go (si, (o', u)) = do - r <- Remote.claimingUrl u + r <- checkClaimingUrl (downloadOptions o) u if Remote.uuid r == webUUID || rawOption (downloadOptions o') then void $ commandAction $ startWeb addunlockedmatcher o' si u @@ -133,6 +141,13 @@ batchInput fmt (pure . parseBatchInput o) go NoBatch -> forM_ (addUrls o) (\u -> go (SeekInput [u], (o, u))) +checkClaimingUrl :: DownloadOptions -> URLString -> Annex Remote +checkClaimingUrl o u = do + allowedremote <- case rawExceptOption o of + Nothing -> pure (const True) + Just f -> (==) <$> getParsed f + Remote.claimingUrl' allowedremote u + parseBatchInput :: AddUrlOptions -> String -> Either String (AddUrlOptions, URLString) parseBatchInput o s | batchFilesOption o = @@ -284,7 +299,7 @@ where geturl = next $ isJust <$> addUrlFile addunlockedmatcher (downloadOptions o) url urlinfo file addurl = addUrlChecked o url file webUUID $ \k -> - ifM (pure (not (rawOption (downloadOptions o))) <&&> youtubeDlSupported url) + ifM (useYoutubeDl (downloadOptions o) <&&> youtubeDlSupported url) ( return (Just (True, True, setDownloader url YoutubeDownloader)) , checkRaw Nothing (downloadOptions o) (pure Nothing) $ return (Just (Url.urlExists urlinfo, Url.urlSize urlinfo == fromKey keySize k, url)) @@ -332,7 +347,7 @@ urlkey = addSizeUrlKey urlinfo $ Backend.URL.fromUrl url Nothing downloader f p = Url.withUrlOptions $ downloadUrl False urlkey p Nothing [url] f go Nothing = return Nothing - go (Just (tmp, backend)) = ifM (pure (not (rawOption o)) <&&> liftIO (isHtmlFile (fromRawFilePath tmp))) + go (Just (tmp, backend)) = ifM (useYoutubeDl o <&&> liftIO (isHtmlFile (fromRawFilePath tmp))) ( tryyoutubedl tmp backend , normalfinish tmp backend ) @@ -393,6 +408,15 @@ Nothing -> "" f | otherwise = a + +useYoutubeDl :: DownloadOptions -> Annex Bool +useYoutubeDl o + | rawOption o = pure False + | otherwise = case rawExceptOption o of + Nothing -> pure True + Just f -> do + remote <- getParsed f + pure (Remote.uuid remote == webUUID) {- The destination file is not known at start time unless the user provided - a filename. It's not displayed then for output consistency, diff --git a/Command/ImportFeed.hs b/Command/ImportFeed.hs --- a/Command/ImportFeed.hs +++ b/Command/ImportFeed.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2013-2023 Joey Hess + - Copyright 2013-2024 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -17,6 +17,7 @@ import qualified Data.Set as S import qualified Data.Map as M import Data.Time.Clock +import Data.Time.Clock.POSIX import Data.Time.Format import Data.Time.Calendar import Data.Time.LocalTime @@ -37,7 +38,7 @@ import qualified Utility.Format import Utility.Tmp import Utility.Metered -import Command.AddUrl (addUrlFile, downloadRemoteFile, parseDownloadOptions, DownloadOptions(..), checkCanAdd, addWorkTree, checkRaw) +import Command.AddUrl (addUrlFile, downloadRemoteFile, parseDownloadOptions, DownloadOptions(..), checkClaimingUrl, checkCanAdd, addWorkTree, checkRaw, useYoutubeDl) import Annex.UUID import Backend.URL (fromUrl) import Annex.Content @@ -61,6 +62,7 @@ data ImportFeedOptions = ImportFeedOptions { feedUrls :: CmdParams , templateOption :: Maybe String + , scrapeOption :: Bool , downloadOptions :: DownloadOptions } @@ -71,6 +73,10 @@ ( long "template" <> metavar paramFormat <> help "template for filenames" )) + <*> switch + ( long "scrape" + <> help "scrape website for content to import" + ) <*> parseDownloadOptions False seek :: ImportFeedOptions -> CommandSeek @@ -84,7 +90,7 @@ liftIO $ atomically $ do m <- takeTMVar dlst putTMVar dlst (M.insert url Nothing m) - commandAction $ getFeed url dlst + commandAction $ getFeed o url dlst startpendingdownloads addunlockedmatcher cache dlst checkst False startpendingdownloads addunlockedmatcher cache dlst checkst True @@ -135,18 +141,23 @@ clearFeedProblem url getFeed - :: URLString + :: ImportFeedOptions + -> URLString -> TMVar (M.Map URLString (Maybe (Maybe [ToDownload]))) -> CommandStart -getFeed url st = +getFeed o url st = starting "importfeed" (ActionItemOther (Just (UnquotedString url))) (SeekInput [url]) $ - get `onException` recordfail + go `onException` recordfail where record v = liftIO $ atomically $ do m <- takeTMVar st putTMVar st (M.insert url v m) recordfail = record (Just Nothing) + go + | scrapeOption o = scrape + | otherwise = get + get = withTmpFile "feed" $ \tmpf h -> do liftIO $ hClose h ifM (downloadFeed url tmpf) @@ -181,6 +192,14 @@ recordfail next $ feedProblem url (msg ++ " (use --debug --debugfilter=ImportFeed to see the feed content that was downloaded)") + + scrape = youtubePlaylist url >>= \case + Left err -> do + recordfail + next $ feedProblem url err + Right playlist -> do + record (Just (Just (playlistDownloads url playlist))) + next $ return True parseFeedFromFile' :: FilePath -> IO (Maybe Feed) #if MIN_VERSION_feed(1,1,0) @@ -190,10 +209,16 @@ #endif data ToDownload = ToDownload - { feed :: Feed - , feedurl :: URLString - , item :: Item + { feedurl :: URLString , location :: DownloadLocation + , itemid :: Maybe B.ByteString + -- Either the parsed or unparsed date. + , itempubdate :: Maybe (Either String UTCTime) + -- Fields that are used as metadata and to generate the filename. + , itemfields :: [(String, String)] + -- True when youtube-dl found this by scraping, so certainly + -- supports downloading it. + , youtubedlscraped :: Bool } data DownloadLocation = Enclosure URLString | MediaLink URLString @@ -226,12 +251,25 @@ where mk i = case getItemEnclosure i of Just (enclosureurl, _, _) -> - Just $ ToDownload f u i $ Enclosure $ - decodeBS $ fromFeedText enclosureurl + Just $ mk' i + (Enclosure $ decodeBS $ fromFeedText enclosureurl) Nothing -> case getItemLink i of - Just l -> Just $ ToDownload f u i $ - MediaLink $ decodeBS $ fromFeedText l + Just l -> Just $ mk' i + (MediaLink $ decodeBS $ fromFeedText l) Nothing -> Nothing + mk' i l = ToDownload + { feedurl = u + , location = l + , itemid = case getItemId i of + Just (_, iid) -> Just (fromFeedText iid) + _ -> Nothing + , itempubdate = case getItemPublishDate i :: Maybe (Maybe UTCTime) of + Just (Just d) -> Just (Right d) + _ -> Left . decodeBS . fromFeedText + <$> getItemPublishDateString i + , itemfields = extractFeedItemFields f i u + , youtubedlscraped = False + } {- Feeds change, so a feed download cannot be resumed. -} downloadFeed :: URLString -> FilePath -> Annex Bool @@ -261,13 +299,13 @@ checkknown url a = case dbhandle cache of Just db -> ifM (liftIO $ Db.isKnownUrl db url) ( nothingtodo - , case getItemId (item todownload) of - Just (_, itemid) -> - ifM (liftIO $ Db.isKnownItemId db (fromFeedText itemid)) + , case itemid todownload of + Just iid -> + ifM (liftIO $ Db.isKnownItemId db iid) ( nothingtodo , a ) - _ -> a + Nothing -> a ) Nothing -> a @@ -279,9 +317,8 @@ startdownloadenclosure url = checkknown url $ startUrlDownload cv todownload url $ downloadEnclosure addunlockedmatcher opts cache cv todownload url - downloadmedia linkurl mediaurl mediakey - | rawOption (downloadOptions opts) = startdownloadlink - | otherwise = ifM (youtubeDlSupported linkurl) + downloadmedia linkurl mediaurl mediakey = + ifM (useYoutubeDl (downloadOptions opts) <&&> youtubeDlSupported linkurl) ( startUrlDownload cv todownload linkurl $ withTmpWorkDir mediakey $ \workdir -> do dl <- youtubeDl linkurl (fromRawFilePath workdir) nullMeterUpdate @@ -310,8 +347,8 @@ contdownloadlink = downloadEnclosure addunlockedmatcher opts cache cv todownload linkurl addmediafast linkurl mediaurl mediakey = - ifM (pure (not (rawOption (downloadOptions opts))) - <&&> youtubeDlSupported linkurl) + ifM (useYoutubeDl (downloadOptions opts) + <&&> (pure (youtubedlscraped todownload) <||> youtubeDlSupported linkurl)) ( startUrlDownload cv todownload linkurl $ do runDownload todownload linkurl ".m" cache cv $ \f -> checkCanAdd (downloadOptions opts) f $ \canadd -> do @@ -324,7 +361,7 @@ downloadEnclosure addunlockedmatcher opts cache cv todownload url = runDownload todownload url (takeWhile (/= '?') $ takeExtension url) cache cv $ \f -> do let f' = fromRawFilePath f - r <- Remote.claimingUrl url + r <- checkClaimingUrl (downloadOptions opts) url if Remote.uuid r == webUUID || rawOption (downloadOptions opts) then checkRaw (Just url) (downloadOptions opts) (pure Nothing) $ do let dlopts = (downloadOptions opts) @@ -374,7 +411,7 @@ case dest of Nothing -> do recordsuccess - stop + next $ return True Just f -> getter (toRawFilePath f) >>= \case Just ks -- Download problem. @@ -424,7 +461,7 @@ in d show n ++ "_" ++ base tryanother = makeunique (n + 1) file alreadyexists = liftIO $ isJust <$> catchMaybeIO (R.getSymbolicLinkStatus (toRawFilePath f)) - checksameurl k = ifM (elem url <$> getUrls k) + checksameurl k = ifM (elem url . map fst . map getDownloader <$> getUrls k) ( return Nothing , tryanother ) @@ -451,9 +488,9 @@ feedFile :: Utility.Format.Format -> ToDownload -> String -> FilePath feedFile tmpl i extension = sanitizeLeadingFilePathCharacter $ Utility.Format.format tmpl $ - M.map sanitizeFilePathComponent $ M.fromList $ extractFields i ++ + M.map sanitizeFilePathComponent $ M.fromList $ itemfields i ++ [ ("extension", extension) - , extractField "itempubdate" [itempubdate] + , extractField "itempubdate" [itempubdatestring] , extractField "itempubyear" [itempubyear] , extractField "itempubmonth" [itempubmonth] , extractField "itempubday" [itempubday] @@ -462,18 +499,13 @@ , extractField "itempubsecond" [itempubsecond] ] where - itm = item i - - pubdate = case getItemPublishDate itm :: Maybe (Maybe UTCTime) of - Just (Just d) -> Just d - _ -> Nothing + pubdate = maybe Nothing eitherToMaybe (itempubdate i) - itempubdate = case pubdate of - Just pd -> Just $ - formatTime defaultTimeLocale "%F" pd + itempubdatestring = case itempubdate i of + Just (Right pd) -> Just $ formatTime defaultTimeLocale "%F" pd -- if date cannot be parsed, use the raw string - Nothing-> replace "/" "-" . decodeBS . fromFeedText - <$> getItemPublishDateString itm + Just (Left s) -> Just $ replace "/" "-" s + Nothing -> Nothing (itempubyear, itempubmonth, itempubday) = case pubdate of Nothing -> (Nothing, Nothing, Nothing) @@ -492,49 +524,78 @@ ) extractMetaData :: ToDownload -> MetaData -extractMetaData i = case getItemPublishDate (item i) :: Maybe (Maybe UTCTime) of - Just (Just d) -> unionMetaData meta (dateMetaData d meta) +extractMetaData i = case itempubdate i of + Just (Right d) -> unionMetaData meta (dateMetaData d meta) _ -> meta where tometa (k, v) = (mkMetaFieldUnchecked (T.pack k), S.singleton (toMetaValue (encodeBS v))) - meta = MetaData $ M.fromList $ map tometa $ extractFields i + meta = MetaData $ M.fromList $ map tometa $ itemfields i minimalMetaData :: ToDownload -> MetaData -minimalMetaData i = case getItemId (item i) of - (Nothing) -> emptyMetaData - (Just (_, itemid)) -> MetaData $ M.singleton itemIdField - (S.singleton $ toMetaValue $ fromFeedText itemid) +minimalMetaData i = case itemid i of + Nothing -> emptyMetaData + Just iid -> MetaData $ M.singleton itemIdField + (S.singleton $ toMetaValue iid) -{- Extract fields from the feed and item, that are both used as metadata, - - and to generate the filename. -} -extractFields :: ToDownload -> [(String, String)] -extractFields i = map (uncurry extractField) - [ ("feedurl", [Just (feedurl i)]) +noneValue :: String +noneValue = "none" + +extractField :: String -> [Maybe String] -> (String, String) +extractField k [] = (k, noneValue) +extractField k (Just v:_) + | not (null v) = (k, v) +extractField k (_:rest) = extractField k rest + +extractFeedItemFields :: Feed -> Item -> URLString -> [(String, String)] +extractFeedItemFields f i u = map (uncurry extractField) + [ ("feedurl", [Just u]) , ("feedtitle", [feedtitle]) , ("itemtitle", [itemtitle]) , ("feedauthor", [feedauthor]) , ("itemauthor", [itemauthor]) - , ("itemsummary", [decodeBS . fromFeedText <$> getItemSummary (item i)]) - , ("itemdescription", [decodeBS . fromFeedText <$> getItemDescription (item i)]) - , ("itemrights", [decodeBS . fromFeedText <$> getItemRights (item i)]) - , ("itemid", [decodeBS . fromFeedText . snd <$> getItemId (item i)]) + , ("itemsummary", [decodeBS . fromFeedText <$> getItemSummary i]) + , ("itemdescription", [decodeBS . fromFeedText <$> getItemDescription i]) + , ("itemrights", [decodeBS . fromFeedText <$> getItemRights i]) + , ("itemid", [decodeBS . fromFeedText . snd <$> getItemId i]) , ("title", [itemtitle, feedtitle]) , ("author", [itemauthor, feedauthor]) ] where - feedtitle = Just $ decodeBS $ fromFeedText $ getFeedTitle $ feed i - itemtitle = decodeBS . fromFeedText <$> getItemTitle (item i) - feedauthor = decodeBS . fromFeedText <$> getFeedAuthor (feed i) - itemauthor = decodeBS . fromFeedText <$> getItemAuthor (item i) + feedtitle = Just $ decodeBS $ fromFeedText $ getFeedTitle f + itemtitle = decodeBS . fromFeedText <$> getItemTitle i + feedauthor = decodeBS . fromFeedText <$> getFeedAuthor f + itemauthor = decodeBS . fromFeedText <$> getItemAuthor i -extractField :: String -> [Maybe String] -> (String, String) -extractField k [] = (k, noneValue) -extractField k (Just v:_) - | not (null v) = (k, v) -extractField k (_:rest) = extractField k rest +playlistFields :: URLString -> YoutubePlaylistItem -> [(String, String)] +playlistFields u i = map (uncurry extractField) + [ ("feedurl", [Just u]) + , ("feedtitle", [youtube_playlist_title i]) + , ("itemtitle", [youtube_title i]) + , ("feedauthor", [youtube_playlist_uploader i]) + , ("itemauthor", [youtube_playlist_uploader i]) + -- itemsummary omitted, no equivilant in yt-dlp data + , ("itemdescription", [youtube_description i]) + , ("itemrights", [youtube_license i]) + , ("itemid", [youtube_url i]) + , ("title", [youtube_title i, youtube_playlist_title i]) + , ("author", [youtube_playlist_uploader i]) + ] -noneValue :: String -noneValue = "none" +playlistDownloads :: URLString -> [YoutubePlaylistItem] -> [ToDownload] +playlistDownloads url = mapMaybe go + where + go i = do + iurl <- youtube_url i + return $ ToDownload + { feedurl = url + , location = MediaLink iurl + , itemid = Just (encodeBS iurl) + , itempubdate = + Right . posixSecondsToUTCTime . fromIntegral + <$> youtube_timestamp i + , itemfields = playlistFields url i + , youtubedlscraped = True + } {- Called when there is a problem with a feed. - diff --git a/Command/PreCommit.hs b/Command/PreCommit.hs --- a/Command/PreCommit.hs +++ b/Command/PreCommit.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2010-2014 Joey Hess + - Copyright 2010-2024 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -20,12 +20,14 @@ import Logs.MetaData import Types.View import Types.MetaData +import qualified Annex +import qualified Annex.Branch import qualified Data.Set as S import qualified Data.Text as T cmd :: Command -cmd = command "pre-commit" SectionPlumbing +cmd = noCommit $ command "pre-commit" SectionPlumbing "run by git pre-commit hook" paramPaths (withParams seek) @@ -47,9 +49,14 @@ -- committing changes to a view updates metadata currentView >>= \case Nothing -> noop - Just (v, _madj) -> withViewChanges - (addViewMetaData v) - (removeViewMetaData v) + Just (v, _madj) -> do + withViewChanges + (addViewMetaData v) + (removeViewMetaData v) + -- Manually commit in this case, because + -- noCommit prevents automatic commit. + whenM (annexAlwaysCommit <$> Annex.getGitConfig) $ + Annex.Branch.commit =<< Annex.Branch.commitMessage addViewMetaData :: View -> ViewedFile -> Key -> CommandStart addViewMetaData v f k = starting "metadata" ai si $ diff --git a/Command/Sync.hs b/Command/Sync.hs --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -19,7 +19,6 @@ prepMerge, mergeLocal, mergeRemote, - commitStaged, commitMsg, pushBranch, updateBranch, @@ -36,7 +35,6 @@ import qualified Annex.Branch import qualified Remote import qualified Types.Remote as Remote -import Annex.Hook import qualified Git.Command import qualified Git.LsFiles as LsFiles import qualified Git.Branch @@ -429,17 +427,6 @@ u <- getUUID m <- uuidDescMap return $ "git-annex in " ++ maybe "unknown" fromUUIDDesc (M.lookup u m) - -commitStaged :: Git.Branch.CommitMode -> String -> Annex Bool -commitStaged commitmode commitmessage = do - runAnnexHook preCommitAnnexHook - mb <- inRepo Git.Branch.currentUnsafe - let (getparent, branch) = case mb of - Just b -> (Git.Ref.sha b, b) - Nothing -> (Git.Ref.headSha, Git.Ref.headRef) - parents <- maybeToList <$> inRepo getparent - void $ inRepo $ Git.Branch.commit commitmode False commitmessage branch parents - return True mergeLocal :: [Git.Merge.MergeConfig] -> SyncOptions -> CurrBranch -> CommandStart mergeLocal mergeconfig o currbranch = stopUnless (notOnlyAnnex o) $ diff --git a/Command/Undo.hs b/Command/Undo.hs --- a/Command/Undo.hs +++ b/Command/Undo.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2014 Joey Hess + - Copyright 2014-2024 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -18,7 +18,6 @@ import qualified Git.LsFiles as LsFiles import qualified Git.Command as Git import qualified Git.Branch -import qualified Command.Sync import qualified Utility.RawFilePath as R cmd :: Command @@ -42,7 +41,7 @@ -- Committing staged changes before undo allows later -- undoing the undo. It would be nicer to only commit staged -- changes to the specified files, rather than all staged changes. - void $ Command.Sync.commitStaged Git.Branch.ManualCommit + void $ commitStaged Git.Branch.ManualCommit "commit before undo" withStrings (commandAction . start) ps @@ -81,3 +80,11 @@ inRepo $ Git.run [Param "checkout", Param "--", File f] next $ liftIO cleanup + +commitStaged :: Git.Branch.CommitMode -> String -> Annex Bool +commitStaged commitmode commitmessage = + inRepo $ Git.Branch.commitCommand commitmode + (Git.Branch.CommitQuiet True) + [ Param "-m" + , Param commitmessage + ] diff --git a/Remote.hs b/Remote.hs --- a/Remote.hs +++ b/Remote.hs @@ -1,6 +1,6 @@ {- git-annex remotes - - - Copyright 2011-2020 Joey Hess + - Copyright 2011-2024 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -59,6 +59,7 @@ logStatus, checkAvailable, claimingUrl, + claimingUrl', isExportSupported, ) where @@ -432,9 +433,15 @@ {- The web special remote claims urls by default. -} claimingUrl :: URLString -> Annex Remote -claimingUrl url = do +claimingUrl = claimingUrl' (const True) + +{- The web special remote still claims urls if there is no + - other remote that does, even when the remotefilter does + - not include it. -} +claimingUrl' :: (Remote -> Bool) -> URLString -> Annex Remote +claimingUrl' remotefilter url = do rs <- remoteList let web = Prelude.head $ filter (\r -> uuid r == webUUID) rs - fromMaybe web <$> firstM checkclaim rs + fromMaybe web <$> firstM checkclaim (filter remotefilter rs) where checkclaim = maybe (pure False) (`id` url) . claimUrl diff --git a/Test/Framework.hs b/Test/Framework.hs --- a/Test/Framework.hs +++ b/Test/Framework.hs @@ -326,11 +326,7 @@ a removeDirectoryForCleanup :: FilePath -> IO () -#if MIN_VERSION_directory(1,2,7) removeDirectoryForCleanup = removePathForcibly -#else -removeDirectoryForCleanup = removeDirectoryRecursive -#endif cleanup :: FilePath -> IO () cleanup dir = whenM (doesDirectoryExist dir) $ do diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs --- a/Types/GitConfig.hs +++ b/Types/GitConfig.hs @@ -88,6 +88,7 @@ , annexAlwaysCommit :: Bool , annexAlwaysCompact :: Bool , annexCommitMessage :: Maybe String + , annexCommitMessageCommand :: Maybe String , annexMergeAnnexBranches :: Bool , annexDelayAdd :: Maybe Int , annexHttpHeaders :: [String] @@ -176,6 +177,7 @@ , annexAlwaysCommit = getbool (annexConfig "alwayscommit") True , annexAlwaysCompact = getbool (annexConfig "alwayscompact") True , annexCommitMessage = getmaybe (annexConfig "commitmessage") + , annexCommitMessageCommand = getmaybe (annexConfig "commitmessage-command") , annexMergeAnnexBranches = getbool (annexConfig "merge-annex-branches") True , annexDelayAdd = getmayberead (annexConfig "delayadd") , annexHttpHeaders = getlist (annexConfig "http-headers") diff --git a/Upgrade/V7.hs b/Upgrade/V7.hs --- a/Upgrade/V7.hs +++ b/Upgrade/V7.hs @@ -78,11 +78,7 @@ removeOldDb db = whenM (liftIO $ doesDirectoryExist db) $ do v <- liftIO $ tryNonAsync $ -#if MIN_VERSION_directory(1,2,7) removePathForcibly db -#else - removeDirectoryRecursive db -#endif case v of Left ex -> giveup $ "Failed removing old database directory " ++ db ++ " during upgrade (" ++ show ex ++ ") -- delete that and re-run git-annex to finish the upgrade." Right () -> return () 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: 10.20240129 +Version: 10.20240227 Cabal-Version: 1.12 License: AGPL-3 Maintainer: Joey Hess diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -9,15 +9,9 @@ dbus: false debuglocks: false benchmark: true - crypton: false + crypton: true packages: - '.' -resolver: lts-22.3 +resolver: lts-22.9 extra-deps: -- git-lfs-1.2.1 -- http-client-restricted-0.1.0 -- torrent-10000.1.1 -- bencode-0.6.1.1 -- feed-1.3.2.1 -- bloomfilter-2.0.1.2 allow-newer: true