git-annex 10.20240129 → 10.20240227
raw patch · 15 files changed
+320/−116 lines, 15 files
Files
- Annex/Branch.hs +10/−2
- Annex/YoutubeDl.hs +87/−3
- Assistant/Threads/Committer.hs +14/−3
- CHANGELOG +20/−0
- Command/AddUrl.hs +27/−3
- Command/ImportFeed.hs +125/−64
- Command/PreCommit.hs +12/−5
- Command/Sync.hs +0/−13
- Command/Undo.hs +10/−3
- Remote.hs +10/−3
- Test/Framework.hs +0/−4
- Types/GitConfig.hs +2/−0
- Upgrade/V7.hs +0/−4
- git-annex.cabal +1/−1
- stack.yaml +2/−8
Annex/Branch.hs view
@@ -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 ()
Annex/YoutubeDl.hs view
@@ -1,10 +1,12 @@ {- yt-dlp (and deprecated youtube-dl) integration for git-annex -- - Copyright 2017-2023 Joey Hess <id@joeyh.name>+ - Copyright 2017-2024 Joey Hess <id@joeyh.name> - - 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_") }+
Assistant/Threads/Committer.hs view
@@ -1,6 +1,6 @@ {- git-annex assistant commit thread -- - Copyright 2012-2023 Joey Hess <id@joeyh.name>+ - Copyright 2012-2024 Joey Hess <id@joeyh.name> - - 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
CHANGELOG view
@@ -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 <id@joeyh.name> 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.
Command/AddUrl.hs view
@@ -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,
Command/ImportFeed.hs view
@@ -1,6 +1,6 @@ {- git-annex command -- - Copyright 2013-2023 Joey Hess <id@joeyh.name>+ - Copyright 2013-2024 Joey Hess <id@joeyh.name> - - 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. -
Command/PreCommit.hs view
@@ -1,6 +1,6 @@ {- git-annex command -- - Copyright 2010-2014 Joey Hess <id@joeyh.name>+ - Copyright 2010-2024 Joey Hess <id@joeyh.name> - - 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 $
Command/Sync.hs view
@@ -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) $
Command/Undo.hs view
@@ -1,6 +1,6 @@ {- git-annex command -- - Copyright 2014 Joey Hess <id@joeyh.name>+ - Copyright 2014-2024 Joey Hess <id@joeyh.name> - - 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+ ]
Remote.hs view
@@ -1,6 +1,6 @@ {- git-annex remotes -- - Copyright 2011-2020 Joey Hess <id@joeyh.name>+ - Copyright 2011-2024 Joey Hess <id@joeyh.name> - - 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
Test/Framework.hs view
@@ -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
Types/GitConfig.hs view
@@ -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")
Upgrade/V7.hs view
@@ -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 ()
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 10.20240129+Version: 10.20240227 Cabal-Version: 1.12 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name>
stack.yaml view
@@ -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