git-annex 10.20230926 → 10.20231129
raw patch · 76 files changed
+1288/−555 lines, 76 files
Files
- Annex/AutoMerge.hs +3/−3
- Annex/Branch.hs +43/−24
- Annex/Branch/Transitions.hs +4/−3
- Annex/Content.hs +1/−1
- Annex/Content/PointerFile.hs +7/−9
- Annex/Ingest.hs +1/−1
- Annex/Locations.hs +11/−0
- Annex/MetaData/StandardFields.hs +5/−1
- Annex/ReplaceFile.hs +7/−7
- Annex/TaggedPush.hs +3/−3
- Annex/UUID.hs +4/−3
- Assistant/MakeRepo.hs +1/−1
- Assistant/Threads/Watcher.hs +1/−1
- Assistant/WebApp/Configurators/Ssh.hs +1/−1
- Author.hs +35/−0
- CHANGELOG +26/−0
- CmdLine/Batch.hs +3/−4
- CmdLine/GitAnnex/Options.hs +6/−1
- CmdLine/Seek.hs +4/−14
- Command/Copy.hs +1/−1
- Command/Expire.hs +1/−1
- Command/Fix.hs +6/−8
- Command/Fsck.hs +4/−5
- Command/GCryptSetup.hs +1/−1
- Command/ImportFeed.hs +19/−50
- Command/Info.hs +40/−7
- Command/Lock.hs +1/−1
- Command/Log.hs +299/−91
- Command/LookupKey.hs +10/−8
- Command/Move.hs +18/−12
- Command/ReKey.hs +2/−3
- Command/Unlock.hs +3/−3
- Creds.hs +7/−7
- Crypto.hs +9/−10
- Database/ContentIdentifier.hs +1/−5
- Database/Export.hs +14/−14
- Database/ImportFeed.hs +211/−0
- Database/Keys/SQL.hs +6/−6
- Database/Types.hs +6/−6
- Git/Construct.hs +11/−9
- Git/Hook.hs +11/−1
- Git/Log.hs +107/−0
- Logs/Chunk.hs +1/−0
- Logs/ContentIdentifier/Pure.hs +2/−2
- Logs/Export.hs +1/−1
- Logs/File.hs +40/−7
- Logs/Location.hs +42/−1
- Logs/MapLog.hs +52/−24
- Logs/RemoteState.hs +2/−1
- Logs/Trust/Pure.hs +4/−1
- Logs/UUIDBased.hs +9/−13
- Logs/Web.hs +16/−9
- Messages.hs +7/−1
- Remote/GCrypt.hs +3/−3
- Remote/Git.hs +1/−1
- Remote/Helper/Encryptable.hs +6/−18
- Test.hs +0/−2
- Test/Framework.hs +23/−19
- Types/Crypto.hs +5/−4
- Types/MetaData.hs +2/−2
- Upgrade.hs +5/−1
- Utility/Base64.hs +7/−37
- Utility/Data.hs +0/−16
- Utility/DataUnits.hs +7/−2
- Utility/FileMode.hs +7/−4
- Utility/Gpg.hs +25/−24
- Utility/Hash.hs +8/−2
- Utility/HtmlDetect.hs +8/−2
- Utility/Metered.hs +6/−2
- Utility/MoveFile.hs +5/−1
- Utility/Path.hs +7/−3
- Utility/Path/AbsRel.hs +3/−16
- Utility/ShellEscape.hs +16/−9
- git-annex.cabal +12/−1
- stack-lts-18.13.yaml +1/−0
- stack.yaml +1/−0
Annex/AutoMerge.hs view
@@ -242,7 +242,7 @@ stageSymlink dest' =<< hashSymlink l replacewithsymlink dest link = replaceWorkTreeFile dest $- makeGitLink link . toRawFilePath+ makeGitLink link makepointer key dest destmode = do unless inoverlay $ @@ -267,10 +267,10 @@ Nothing -> noop Just sha -> replaceWorkTreeFile item $ \tmp -> do c <- catObject sha- liftIO $ L.writeFile tmp c+ liftIO $ L.writeFile (decodeBS tmp) c when isexecutable $ liftIO $ void $ tryIO $ - modifyFileMode (toRawFilePath tmp) $+ modifyFileMode tmp $ addModes executeModes -- Update the work tree to reflect the graft.
Annex/Branch.hs view
@@ -1,6 +1,6 @@ {- management of the git-annex branch -- - Copyright 2011-2022 Joey Hess <id@joeyh.name>+ - Copyright 2011-2023 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -36,11 +36,11 @@ withIndex, precache, overBranchFileContents,+ updatedFromTree, ) where import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L-import qualified Data.ByteString.Char8 as B8 import qualified Data.Set as S import qualified Data.Map as M import Data.Function@@ -49,6 +49,7 @@ import Control.Concurrent (threadDelay) import Control.Concurrent.MVar import qualified System.FilePath.ByteString as P+import System.PosixCompat.Files (isRegularFile) import Annex.Common hiding (append) import Types.BranchState@@ -595,21 +596,24 @@ then return Nothing else do (bfs, cleanup) <- branchFiles+ jfs <- journalledFiles+ pjfs <- journalledFilesPrivate -- ++ forces the content of the first list to be -- buffered in memory, so use journalledFiles, -- which should be much smaller most of the time. -- branchFiles will stream as the list is consumed.- l <- (++) <$> journalledFiles <*> pure bfs+ let l = jfs ++ pjfs ++ bfs return (Just (l, cleanup)) -{- Lists all files currently in the journal. There may be duplicates in- - the list when using a private journal. -}+{- Lists all files currently in the journal, but not files in the private+ - journal. -} journalledFiles :: Annex [RawFilePath]-journalledFiles = ifM privateUUIDsKnown- ( (++)- <$> getJournalledFilesStale gitAnnexPrivateJournalDir- <*> getJournalledFilesStale gitAnnexJournalDir- , getJournalledFilesStale gitAnnexJournalDir+journalledFiles = getJournalledFilesStale gitAnnexJournalDir++journalledFilesPrivate :: Annex [RawFilePath]+journalledFilesPrivate = ifM privateUUIDsKnown+ ( getJournalledFilesStale gitAnnexPrivateJournalDir+ , return [] ) {- Files in the branch, not including any from journalled changes,@@ -726,13 +730,14 @@ genstream dir h jh jlogh streamer = readDirectory jh >>= \case Nothing -> return () Just file -> do- unless (dirCruft file) $ do- let path = dir P.</> toRawFilePath file+ let path = dir P.</> toRawFilePath file+ unless (dirCruft file) $ whenM (isfile path) $ do sha <- Git.HashObject.hashFile h path hPutStrLn jlogh file streamer $ Git.UpdateIndex.updateIndexLine sha TreeFile (asTopFilePath $ fileJournal $ toRawFilePath file) genstream dir h jh jlogh streamer+ isfile file = isRegularFile <$> R.getFileStatus file -- Clean up the staged files, as listed in the temp log file. -- The temp file is used to avoid needing to buffer all the -- filenames in memory.@@ -883,7 +888,7 @@ getIgnoredRefs :: Annex (S.Set Git.Sha) getIgnoredRefs = - S.fromList . mapMaybe Git.Sha.extractSha . B8.lines <$> content+ S.fromList . mapMaybe Git.Sha.extractSha . fileLines' <$> content where content = do f <- fromRawFilePath <$> fromRepo gitAnnexIgnoredRefs@@ -906,7 +911,7 @@ getMergedRefs' = do f <- fromRawFilePath <$> fromRepo gitAnnexMergedRefs s <- liftIO $ catchDefaultIO mempty $ B.readFile f- return $ map parse $ B8.lines s+ return $ map parse $ fileLines' s where parse l = let (s, b) = separate' (== (fromIntegral (ord '\t'))) l@@ -989,8 +994,11 @@ -- This can cause the action to be run a -- second time with a file it already ran on. | otherwise -> liftIO (tryTakeMVar buf) >>= \case- Nothing -> drain buf =<< journalledFiles- Just fs -> drain buf fs+ Nothing -> do+ jfs <- journalledFiles+ pjfs <- journalledFilesPrivate+ drain buf jfs pjfs+ Just (jfs, pjfs) -> drain buf jfs pjfs catObjectStreamLsTree l (select' . getTopFilePath . Git.LsTree.file) g go' `finally` liftIO (void cleanup) where@@ -1004,9 +1012,9 @@ PossiblyStaleJournalledContent journalledcontent -> Just (fromMaybe mempty branchcontent <> journalledcontent) - drain buf fs = case getnext fs of- Just (v, f, fs') -> do- liftIO $ putMVar buf fs'+ drain buf fs pfs = case getnext fs pfs of+ Just (v, f, fs', pfs') -> do+ liftIO $ putMVar buf (fs', pfs') content <- getJournalFileStale (GetPrivate True) f >>= \case NoJournalledContent -> return Nothing JournalledContent journalledcontent ->@@ -1019,11 +1027,22 @@ return (Just (content <> journalledcontent)) return (Just (v, f, content)) Nothing -> do- liftIO $ putMVar buf []+ liftIO $ putMVar buf ([], []) return Nothing - getnext [] = Nothing- getnext (f:fs) = case select f of- Nothing -> getnext fs- Just v -> Just (v, f, fs)+ getnext [] [] = Nothing+ getnext (f:fs) pfs = case select f of+ Nothing -> getnext fs pfs+ Just v -> Just (v, f, fs, pfs)+ getnext [] (pf:pfs) = case select pf of+ Nothing -> getnext [] pfs+ Just v -> Just (v, pf, [], pfs) +{- Check if the git-annex branch has been updated from the oldtree.+ - If so, returns the tuple of the old and new trees. -}+updatedFromTree :: Git.Sha -> Annex (Maybe (Git.Sha, Git.Sha))+updatedFromTree oldtree =+ inRepo (Git.Ref.tree fullname) >>= \case+ Just currtree | currtree /= oldtree ->+ return $ Just (oldtree, currtree)+ _ -> return Nothing
Annex/Branch/Transitions.hs view
@@ -18,6 +18,7 @@ import qualified Logs.Chunk.Pure as Chunk import qualified Logs.MetaData.Pure as MetaData import qualified Logs.Remote.Pure as Remote+import Logs.MapLog import Types.TrustLevel import Types.UUID import Types.MetaData@@ -53,7 +54,7 @@ | f == trustLog = PreserveFile | f == remoteLog = ChangeFile $ Remote.buildRemoteConfigLog $- M.mapWithKey minimizesameasdead $+ mapLogWithKey minimizesameasdead $ filterMapLog (notdead trustmap) id $ Remote.parseRemoteConfigLog content | otherwise = filterBranch (notdead trustmap') gc f content@@ -95,8 +96,8 @@ Just OtherLog -> PreserveFile Nothing -> PreserveFile -filterMapLog :: (UUID -> Bool) -> (k -> UUID) -> M.Map k v -> M.Map k v-filterMapLog wantuuid getuuid = M.filterWithKey $ \k _v -> wantuuid (getuuid k)+filterMapLog :: (UUID -> Bool) -> (k -> UUID) -> MapLog k v -> MapLog k v+filterMapLog wantuuid getuuid = filterMapLogWith (\k _v -> wantuuid (getuuid k)) filterLocationLog :: (UUID -> Bool) -> [Presence.LogLine] -> [Presence.LogLine] filterLocationLog wantuuid = filter $
Annex/Content.hs view
@@ -477,7 +477,7 @@ linkFromAnnex :: Key -> RawFilePath -> Maybe FileMode -> Annex LinkAnnexResult linkFromAnnex key dest destmode = replaceFile' (const noop) (fromRawFilePath dest) (== LinkAnnexOk) $ \tmp ->- linkFromAnnex' key (toRawFilePath tmp) destmode+ linkFromAnnex' key tmp destmode {- This is only safe to use when dest is not a worktree file. -} linkFromAnnex' :: Key -> RawFilePath -> Maybe FileMode -> Annex LinkAnnexResult
Annex/Content/PointerFile.hs view
@@ -38,11 +38,10 @@ destmode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus f liftIO $ removeWhenExistsWith R.removeLink f (ic, populated) <- replaceWorkTreeFile f' $ \tmp -> do- let tmp' = toRawFilePath tmp- ok <- linkOrCopy k obj tmp' destmode >>= \case- Just _ -> thawContent tmp' >> return True- Nothing -> liftIO (writePointerFile tmp' k destmode) >> return False- ic <- withTSDelta (liftIO . genInodeCache tmp')+ ok <- linkOrCopy k obj tmp destmode >>= \case+ Just _ -> thawContent tmp >> return True+ Nothing -> liftIO (writePointerFile tmp k destmode) >> return False+ ic <- withTSDelta (liftIO . genInodeCache tmp) return (ic, ok) maybe noop (restagePointerFile restage f) ic if populated@@ -60,14 +59,13 @@ secureErase file liftIO $ removeWhenExistsWith R.removeLink file ic <- replaceWorkTreeFile (fromRawFilePath file) $ \tmp -> do- let tmp' = toRawFilePath tmp- liftIO $ writePointerFile tmp' key mode+ liftIO $ writePointerFile tmp key mode #if ! defined(mingw32_HOST_OS) -- Don't advance mtime; this avoids unnecessary re-smudging -- by git in some cases. liftIO $ maybe noop- (\t -> touch tmp' t False)+ (\t -> touch tmp t False) (fmap Posix.modificationTimeHiRes st) #endif- withTSDelta (liftIO . genInodeCache tmp')+ withTSDelta (liftIO . genInodeCache tmp) maybe noop (restagePointerFile (Restage True) file) ic
Annex/Ingest.hs view
@@ -306,7 +306,7 @@ makeLink :: RawFilePath -> Key -> Maybe InodeCache -> Annex LinkTarget makeLink file key mcache = flip catchNonAsync (restoreFile file key) $ do l <- calcRepo $ gitAnnexLink file key- replaceWorkTreeFile file' $ makeAnnexLink l . toRawFilePath+ replaceWorkTreeFile file' $ makeAnnexLink l -- touch symlink to have same time as the original file, -- as provided in the InodeCache
Annex/Locations.hs view
@@ -65,6 +65,8 @@ gitAnnexImportLog, gitAnnexContentIdentifierDbDir, gitAnnexContentIdentifierLock,+ gitAnnexImportFeedDbDir,+ gitAnnexImportFeedDbLock, gitAnnexScheduleState, gitAnnexTransferDir, gitAnnexCredsDir,@@ -459,6 +461,15 @@ gitAnnexImportLog :: UUID -> Git.Repo -> GitConfig -> RawFilePath gitAnnexImportLog u r c = gitAnnexImportDir r c P.</> fromUUID u P.</> "log"++{- Directory containing database used by importfeed. -}+gitAnnexImportFeedDbDir :: Git.Repo -> GitConfig -> RawFilePath+gitAnnexImportFeedDbDir r c =+ fromMaybe (gitAnnexDir r) (annexDbDir c) P.</> "importfeed"++{- Lock file for writing to the importfeed database. -}+gitAnnexImportFeedDbLock :: Git.Repo -> GitConfig -> RawFilePath+gitAnnexImportFeedDbLock r c = gitAnnexImportFeedDbDir r c <> ".lck" {- .git/annex/schedulestate is used to store information about when - scheduled jobs were last run. -}
Annex/MetaData/StandardFields.hs view
@@ -15,7 +15,8 @@ isDateMetaField, lastChangedField, mkLastChangedField,- isLastChangedField+ isLastChangedField,+ itemIdField ) where import Types.MetaData@@ -61,3 +62,6 @@ lastchangedSuffix :: T.Text lastchangedSuffix = "-lastchanged"++itemIdField :: MetaField+itemIdField = mkMetaFieldUnchecked "itemid"
Annex/ReplaceFile.hs view
@@ -26,17 +26,17 @@ #endif {- replaceFile on a file located inside the gitAnnexDir. -}-replaceGitAnnexDirFile :: FilePath -> (FilePath -> Annex a) -> Annex a+replaceGitAnnexDirFile :: FilePath -> (RawFilePath -> Annex a) -> Annex a replaceGitAnnexDirFile = replaceFile createAnnexDirectory {- replaceFile on a file located inside the .git directory. -}-replaceGitDirFile :: FilePath -> (FilePath -> Annex a) -> Annex a+replaceGitDirFile :: FilePath -> (RawFilePath -> Annex a) -> Annex a replaceGitDirFile = replaceFile $ \dir -> do top <- fromRepo localGitDir liftIO $ createDirectoryUnder [top] dir {- replaceFile on a worktree file. -}-replaceWorkTreeFile :: FilePath -> (FilePath -> Annex a) -> Annex a+replaceWorkTreeFile :: FilePath -> (RawFilePath -> Annex a) -> Annex a replaceWorkTreeFile = replaceFile createWorkTreeDirectory {- Replaces a possibly already existing file with a new version, @@ -54,10 +54,10 @@ - The createdirectory action is only run when moving the file into place - fails, and can create any parent directory structure needed. -}-replaceFile :: (RawFilePath -> Annex ()) -> FilePath -> (FilePath -> Annex a) -> Annex a+replaceFile :: (RawFilePath -> Annex ()) -> FilePath -> (RawFilePath -> Annex a) -> Annex a replaceFile createdirectory file action = replaceFile' createdirectory file (const True) action -replaceFile' :: (RawFilePath -> Annex ()) -> FilePath -> (a -> Bool) -> (FilePath -> Annex a) -> Annex a+replaceFile' :: (RawFilePath -> Annex ()) -> FilePath -> (a -> Bool) -> (RawFilePath -> Annex a) -> Annex a replaceFile' createdirectory file checkres action = withOtherTmp $ \othertmpdir -> do let othertmpdir' = fromRawFilePath othertmpdir #ifndef mingw32_HOST_OS@@ -72,10 +72,10 @@ let basetmp = "t" #endif withTmpDirIn othertmpdir' basetmp $ \tmpdir -> do- let tmpfile = tmpdir </> basetmp+ let tmpfile = toRawFilePath (tmpdir </> basetmp) r <- action tmpfile when (checkres r) $- replaceFileFrom (toRawFilePath tmpfile) (toRawFilePath file) createdirectory+ replaceFileFrom tmpfile (toRawFilePath file) createdirectory return r replaceFileFrom :: RawFilePath -> RawFilePath -> (RawFilePath -> Annex ()) -> Annex ()
Annex/TaggedPush.hs view
@@ -38,14 +38,14 @@ toTaggedBranch u info b = Git.Ref $ S.intercalate "/" $ catMaybes [ Just "refs/synced" , Just $ fromUUID u- , toB64' . encodeBS <$> info+ , toB64 . encodeBS <$> info , Just $ Git.fromRef' $ Git.Ref.base b ] -fromTaggedBranch :: Git.Ref -> Maybe (UUID, Maybe String)+fromTaggedBranch :: Git.Ref -> Maybe (UUID, Maybe S.ByteString) fromTaggedBranch b = case splitc '/' $ Git.fromRef b of ("refs":"synced":u:info:_base) ->- Just (toUUID u, fromB64Maybe info)+ Just (toUUID u, fromB64Maybe (encodeBS info)) ("refs":"synced":u:_base) -> Just (toUUID u, Nothing) _ -> Nothing
Annex/UUID.hs view
@@ -41,6 +41,7 @@ import qualified Data.UUID as U import qualified Data.UUID.V4 as U4 import qualified Data.UUID.V5 as U5+import qualified Data.ByteString as S import Data.String configkeyUUID :: ConfigKey@@ -53,13 +54,13 @@ {- Generates a UUID from a given string, using a namespace. - Given the same namespace, the same string will always result - in the same UUID. -}-genUUIDInNameSpace :: U.UUID -> String -> UUID-genUUIDInNameSpace namespace = toUUID . U5.generateNamed namespace . s2w8+genUUIDInNameSpace :: U.UUID -> S.ByteString -> UUID+genUUIDInNameSpace namespace = toUUID . U5.generateNamed namespace . S.unpack {- Namespace used for UUIDs derived from git-remote-gcrypt ids. -} gCryptNameSpace :: U.UUID gCryptNameSpace = U5.generateNamed U5.namespaceURL $- s2w8 "http://git-annex.branchable.com/design/gcrypt/" + S.unpack "http://git-annex.branchable.com/design/gcrypt/" {- Get current repository's UUID. -} getUUID :: Annex UUID
Assistant/MakeRepo.hs view
@@ -95,4 +95,4 @@ {- Checks if a git repo exists at a location. -} probeRepoExists :: FilePath -> IO Bool probeRepoExists dir = isJust <$>- catchDefaultIO Nothing (Git.Construct.checkForRepo dir)+ catchDefaultIO Nothing (Git.Construct.checkForRepo (encodeBS dir))
Assistant/Threads/Watcher.hs view
@@ -293,7 +293,7 @@ then ensurestaged (Just link) =<< getDaemonStatus else do liftAnnex $ replaceWorkTreeFile file $- makeAnnexLink link . toRawFilePath+ makeAnnexLink link addLink file link (Just key) -- other symlink, not git-annex go Nothing = ensurestaged linktarget =<< getDaemonStatus
Assistant/WebApp/Configurators/Ssh.hs view
@@ -319,7 +319,7 @@ finduuid (k, v) | k == "annex.uuid" = Just $ toUUID v | k == fromConfigKey GCrypt.coreGCryptId =- Just $ genUUIDInNameSpace gCryptNameSpace v+ Just $ genUUIDInNameSpace gCryptNameSpace (encodeBS v) | otherwise = Nothing checkcommand c = "if which " ++ c ++ "; then " ++ report c ++ "; fi"
+ Author.hs view
@@ -0,0 +1,35 @@+{- authorship made explicit in the code+ -+ - Copyright 2023 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++{-# LANGUAGE FlexibleInstances, RankNTypes #-}+{-# OPTIONS_GHC -fno-warn-tabs #-}++module Author where++data Author = JoeyHess++-- This allows writing eg:+--+-- copyright = author JoeyHess 1999 :: Copyright+type Copyright = forall t. Authored t => t++class Authored t where+ author:: Author -> Int -> t++instance Authored Bool where+ author _ year = year >= 2010+ {-# INLINE author #-}++instance Authored (a -> a) where+ author by year f+ | author by year = f+ | otherwise = author by (pred year) f+ {-# INLINE author #-}++instance Monad m => Authored (a -> m a) where+ author by year = pure . author by year+ {-# INLINE author #-}
CHANGELOG view
@@ -1,3 +1,29 @@+git-annex (10.20231129) upstream; urgency=medium++ * Fix bug in git-annex copy --from --to that skipped files that were+ locally present.+ * Make git-annex copy --from --to --fast actually fast.+ * Fix crash of enableremote when the special remote has embedcreds=yes.+ * Ignore directories and other unusual files in .git/annex/journal/+ * info: Added calculation of combined annex size of all repositories.+ * log: Added options --sizesof, --sizes and --totalsizes that+ display how the size of repositories changed over time.+ * log: Added options --interval, --bytes, --received, and --gnuplot+ to tune the output of the above added options.+ * findkeys: Support --largerthan and --smallerthan.+ * importfeed: Use caching database to avoid needing to list urls+ on every run, and avoid using too much memory.+ * Improve memory use of --all when using annex.private.+ * lookupkey: Sped up --batch.+ * Windows: Consistently avoid ending standard output lines with CR.+ This matches the behavior of git on Windows.+ * Windows: Fix CRLF handling in some log files.+ * Windows: When git-annex init is installing hook scripts, it will+ avoid ending lines with CR for portability. Existing hook scripts+ that do have CR line endings will not be changed.++ -- Joey Hess <id@joeyh.name> Wed, 29 Nov 2023 15:59:20 -0400+ git-annex (10.20230926) upstream; urgency=medium * Fix more breakage caused by git's fix for CVE-2022-24765, this time
CmdLine/Batch.hs view
@@ -164,9 +164,8 @@ matcher <- getMatcher go $ \si v -> case v of Right f -> - let f' = toRawFilePath f- in ifM (matcher $ MatchingFile $ FileInfo f' f' Nothing)- ( a (si, Right f')+ ifM (matcher $ MatchingFile $ FileInfo f f Nothing)+ ( a (si, Right f) , return Nothing ) Left k -> a (si, Left k)@@ -177,7 +176,7 @@ -- because in non-batch mode, that is done when -- CmdLine.Seek uses git ls-files. BatchFormat _ (BatchKeys False) -> - Right . Right . fromRawFilePath + Right . Right <$$> liftIO . relPathCwdToFile . toRawFilePath BatchFormat _ (BatchKeys True) -> \i -> pure $ case deserializeKey i of
CmdLine/GitAnnex/Options.hs view
@@ -266,6 +266,7 @@ keyMatchingOptions :: [AnnexOption] keyMatchingOptions = concat [ keyMatchingOptions'+ , sizeMatchingOptions Limit.LimitAnnexFiles , anythingNothingOptions , combiningOptions , timeLimitOption @@ -398,7 +399,11 @@ <> help "limit to files whose content is the same as another file matching the glob pattern" <> hidden )- , annexOption (setAnnexState . Limit.addLargerThan lb) $ strOption+ ] ++ sizeMatchingOptions lb++sizeMatchingOptions :: Limit.LimitBy -> [AnnexOption]+sizeMatchingOptions lb =+ [ annexOption (setAnnexState . Limit.addLargerThan lb) $ strOption ( long "largerthan" <> metavar paramSize <> help "match files larger than a size" <> hidden
CmdLine/Seek.hs view
@@ -276,24 +276,14 @@ -- those. This significantly speeds up typical operations -- that need to look at the location log for each key. runallkeys = do- checktimelimit <- mkCheckTimeLimit keyaction <- mkkeyaction- config <- Annex.getGitConfig- - let getk = locationLogFileKey config+ checktimelimit <- mkCheckTimeLimit let discard reader = reader >>= \case Nothing -> noop Just _ -> discard reader- let go reader = reader >>= \case- Just (k, f, content) -> checktimelimit (discard reader) $ do- maybe noop (Annex.Branch.precache f) content- unlessM (checkDead k) $- keyaction Nothing (SeekInput [], k, mkActionItem k)- go reader- Nothing -> return ()- Annex.Branch.overBranchFileContents getk go >>= \case- Just r -> return r- Nothing -> giveup "This repository is read-only, and there are unmerged git-annex branches, which prevents operating on all keys. (Set annex.merge-annex-branches to false to ignore the unmerged git-annex branches.)"+ overLocationLogs' () + (\reader cont -> checktimelimit (discard reader) cont) + (\k _ () -> keyaction Nothing (SeekInput [], k, mkActionItem k)) runkeyaction getks = do keyaction <- mkkeyaction
Command/Copy.hs view
@@ -68,7 +68,7 @@ FromOrToRemote (FromRemote _) -> Just False FromOrToRemote (ToRemote _) -> Just True ToHere -> Just False- FromRemoteToRemote _ _ -> Just False+ FromRemoteToRemote _ _ -> Nothing , usesLocationLog = True } keyaction = Command.Move.startKey fto Command.Move.RemoveNever
Command/Expire.hs view
@@ -73,7 +73,7 @@ trustSet u DeadTrusted next $ return True where- lastact = changed <$> M.lookup u actlog+ lastact = changed <$> M.lookup u (fromMapLog actlog) whenactive = case lastact of Just (VectorClock c) -> do d <- liftIO $ durationSince $ posixSecondsToUTCTime c
Command/Fix.hs view
@@ -73,12 +73,11 @@ breakHardLink :: RawFilePath -> Key -> RawFilePath -> CommandPerform breakHardLink file key obj = do replaceWorkTreeFile (fromRawFilePath file) $ \tmp -> do- let tmp' = toRawFilePath tmp mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file- unlessM (checkedCopyFile key obj tmp' mode) $+ unlessM (checkedCopyFile key obj tmp mode) $ giveup "unable to break hard link"- thawContent tmp'- Database.Keys.storeInodeCaches key [tmp']+ thawContent tmp+ Database.Keys.storeInodeCaches key [tmp] modifyContentDir obj $ freezeContent obj next $ return True @@ -86,7 +85,7 @@ makeHardLink file key = do replaceWorkTreeFile (fromRawFilePath file) $ \tmp -> do mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file- linkFromAnnex' key (toRawFilePath tmp) mode >>= \case+ linkFromAnnex' key tmp mode >>= \case LinkAnnexFailed -> giveup "unable to make hard link" _ -> noop next $ return True@@ -99,10 +98,9 @@ <$> R.getSymbolicLinkStatus file #endif replaceWorkTreeFile (fromRawFilePath file) $ \tmpfile -> do- let tmpfile' = toRawFilePath tmpfile- liftIO $ R.createSymbolicLink link tmpfile'+ liftIO $ R.createSymbolicLink link tmpfile #if ! defined(mingw32_HOST_OS)- liftIO $ maybe noop (\t -> touch tmpfile' t False) mtime+ liftIO $ maybe noop (\t -> touch tmpfile t False) mtime #endif stageSymlink file =<< hashSymlink link next $ return True
Command/Fsck.hs view
@@ -417,16 +417,15 @@ Just k | k == key -> whenM (inAnnex key) $ do showNote "fixing worktree content" replaceWorkTreeFile (fromRawFilePath file) $ \tmp -> do- let tmp' = toRawFilePath tmp mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file ifM (annexThin <$> Annex.getGitConfig)- ( void $ linkFromAnnex' key tmp' mode+ ( void $ linkFromAnnex' key tmp mode , do obj <- calcRepo (gitAnnexLocation key)- void $ checkedCopyFile key obj tmp' mode- thawContent tmp'+ void $ checkedCopyFile key obj tmp mode+ thawContent tmp )- Database.Keys.storeInodeCaches key [tmp']+ Database.Keys.storeInodeCaches key [tmp] _ -> return () return True
Command/GCryptSetup.hs view
@@ -29,7 +29,7 @@ g <- gitRepo gu <- Remote.GCrypt.getGCryptUUID True g- let newgu = genUUIDInNameSpace gCryptNameSpace gcryptid+ let newgu = genUUIDInNameSpace gCryptNameSpace (encodeBS gcryptid) if isNothing gu || gu == Just newgu then if Git.repoIsLocalBare g then do
Command/ImportFeed.hs view
@@ -48,9 +48,8 @@ import Annex.MetaData import Annex.FileMatcher import Annex.UntrustedFilePath-import qualified Annex.Branch-import Logs import qualified Utility.RawFilePath as R+import qualified Database.ImportFeed as Db cmd :: Command cmd = notBareRepo $ withAnnexOptions os $@@ -202,53 +201,25 @@ type ItemId = String data Cache = Cache- { knownurls :: S.Set URLString- , knownitems :: S.Set ItemId+ { dbhandle :: Maybe Db.ImportFeedDbHandle , template :: Utility.Format.Format } getCache :: Maybe String -> Annex Cache getCache opttemplate = ifM (Annex.getRead Annex.force)- ( ret S.empty S.empty+ ( ret Nothing , do j <- jsonOutputEnabled unless j $ showStartMessage (StartMessage "importfeed" (ActionItemOther (Just "gathering known urls")) (SeekInput []))- (us, is) <- knownItems+ h <- Db.openDb unless j showEndOk- ret (S.fromList us) (S.fromList is)+ ret (Just h) ) where tmpl = Utility.Format.gen $ fromMaybe defaultTemplate opttemplate- ret us is = return $ Cache us is tmpl--{- Scan all url logs and metadata logs in the branch and find urls- - and ItemIds that are already known. -}-knownItems :: Annex ([URLString], [ItemId])-knownItems = Annex.Branch.overBranchFileContents select (go [] []) >>= \case- Just r -> return r- Nothing -> giveup "This repository is read-only."- where- select f- | isUrlLog f = Just ()- | isMetaDataLog f = Just ()- | otherwise = Nothing-- go uc ic reader = reader >>= \case- Just ((), f, Just content)- | isUrlLog f -> case parseUrlLog content of- [] -> go uc ic reader- us -> go (us++uc) ic reader- | isMetaDataLog f ->- let s = currentMetaDataValues itemIdField $- parseCurrentMetaData content- in if S.null s- then go uc ic reader- else go uc (map (decodeBS . fromMetaValue) (S.toList s)++ic) reader- | otherwise -> go uc ic reader- Just ((), _, Nothing) -> go uc ic reader- Nothing -> return (uc, ic)+ ret h = return $ Cache h tmpl findDownloads :: URLString -> Feed -> [ToDownload] findDownloads u f = catMaybes $ map mk (feedItems f)@@ -285,14 +256,20 @@ , downloadmedia linkurl mediaurl mediakey ) where- forced = Annex.getRead Annex.force- {- Avoids downloading any items that are already known to be- - associated with a file in the annex, unless forced. -}- checkknown url a- | knownitemid || S.member url (knownurls cache)- = ifM forced (a, nothingtodo)- | otherwise = a+ - associated with a file in the annex. -}+ 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))+ ( nothingtodo+ , a+ )+ _ -> a+ )+ Nothing -> a nothingtodo = recordsuccess >> stop @@ -302,11 +279,6 @@ startdownloadenclosure url = checkknown url $ startUrlDownload cv todownload url $ downloadEnclosure addunlockedmatcher opts cache cv todownload url - knownitemid = case getItemId (item todownload) of- Just (_, itemid) ->- S.member (decodeBS $ fromFeedText itemid) (knownitems cache)- _ -> False- downloadmedia linkurl mediaurl mediakey | rawOption (downloadOptions opts) = startdownloadlink | otherwise = ifM (youtubeDlSupported linkurl)@@ -554,9 +526,6 @@ itemtitle = decodeBS . fromFeedText <$> getItemTitle (item i) feedauthor = decodeBS . fromFeedText <$> getFeedAuthor (feed i) itemauthor = decodeBS . fromFeedText <$> getItemAuthor (item i)--itemIdField :: MetaField-itemIdField = mkMetaFieldUnchecked "itemid" extractField :: String -> [Maybe String] -> (String, String) extractField k [] = (k, noneValue)
Command/Info.hs view
@@ -89,12 +89,13 @@ { presentData :: Maybe KeyInfo , referencedData :: Maybe KeyInfo , repoData :: M.Map UUID KeyInfo+ , allRepoData :: Maybe KeyInfo , numCopiesStats :: Maybe NumCopiesStats , infoOptions :: InfoOptions } emptyStatInfo :: InfoOptions -> StatInfo-emptyStatInfo = StatInfo Nothing Nothing M.empty Nothing+emptyStatInfo = StatInfo Nothing Nothing M.empty Nothing Nothing -- a state monad for running Stats in type StatState = StateT StatInfo Annex@@ -281,8 +282,9 @@ , local_annex_size , known_annex_files True , known_annex_size True- , bloom_info+ , total_annex_size , backend_usage+ , bloom_info ] tree_fast_stats :: Bool -> [FilePath -> Stat]@@ -435,6 +437,11 @@ known_annex_size isworktree = simpleStat ("size of annexed files in " ++ treeDesc isworktree) $ showSizeKeys =<< cachedReferencedData++total_annex_size :: Stat+total_annex_size = + simpleStat "combined annex size of all repositories" $+ showSizeKeys =<< cachedAllRepoData treeDesc :: Bool -> String treeDesc True = "working tree"@@ -612,6 +619,23 @@ put s { referencedData = Just v } return v +cachedAllRepoData :: StatState KeyInfo+cachedAllRepoData = do+ s <- get+ case allRepoData s of+ Just v -> return v+ Nothing -> do+ matcher <- lift getKeyOnlyMatcher+ !v <- lift $ overLocationLogs emptyKeyInfo $ \k locs d -> do+ numcopies <- genericLength . snd+ <$> trustPartition DeadTrusted locs+ ifM (matchOnKey matcher k)+ ( return (addKeyCopies numcopies k d)+ , return d+ )+ put s { allRepoData = Just v }+ return v+ -- currently only available for directory info cachedNumCopiesStats :: StatState (Maybe NumCopiesStats) cachedNumCopiesStats = numCopiesStats <$> get@@ -627,7 +651,13 @@ (presentdata, referenceddata, numcopiesstats, repodata) <- Command.Unused.withKeysFilesReferencedIn dir initial (update matcher fast)- return $ StatInfo (Just presentdata) (Just referenceddata) repodata (Just numcopiesstats) o+ return $ StatInfo+ (Just presentdata)+ (Just referenceddata)+ repodata+ Nothing+ (Just numcopiesstats)+ o where initial = (emptyKeyInfo, emptyKeyInfo, emptyNumCopiesStats, M.empty) update matcher fast key file vs@(presentdata, referenceddata, numcopiesstats, repodata) =@@ -663,7 +693,7 @@ (presentdata, referenceddata, repodata) <- go fast matcher ls initial ifM (liftIO cleanup) ( return $ Just $- StatInfo (Just presentdata) (Just referenceddata) repodata Nothing o+ StatInfo (Just presentdata) (Just referenceddata) repodata Nothing Nothing o , return Nothing ) where@@ -695,16 +725,19 @@ emptyNumCopiesStats = NumCopiesStats M.empty addKey :: Key -> KeyInfo -> KeyInfo-addKey key (KeyInfo count size unknownsize backends) =+addKey = addKeyCopies 1++addKeyCopies :: Integer -> Key -> KeyInfo -> KeyInfo+addKeyCopies numcopies key (KeyInfo count size unknownsize backends) = KeyInfo count' size' unknownsize' backends' where {- All calculations strict to avoid thunks when repeatedly - applied to many keys. -} !count' = count + 1 !backends' = M.insertWith (+) (fromKey keyVariety key) 1 backends- !size' = maybe size (+ size) ks+ !size' = maybe size (\sz -> sz * numcopies + size) ks !unknownsize' = maybe (unknownsize + 1) (const unknownsize) ks- ks = fromKey keySize key+ !ks = fromKey keySize key updateRepoData :: Key -> [UUID] -> M.Map UUID KeyInfo -> M.Map UUID KeyInfo updateRepoData key locs m = m'
Command/Lock.hs view
@@ -79,7 +79,7 @@ mfc <- withTSDelta (liftIO . genInodeCache file) unlessM (sameInodeCache obj (maybeToList mfc)) $ do modifyContentDir obj $ replaceGitAnnexDirFile (fromRawFilePath obj) $ \tmp -> do- unlessM (checkedCopyFile key obj (toRawFilePath tmp) Nothing) $+ unlessM (checkedCopyFile key obj tmp Nothing) $ giveup "unable to lock file" Database.Keys.storeInodeCaches key [obj]
Command/Log.hs view
@@ -1,11 +1,11 @@ {- git-annex command -- - Copyright 2012-2021 Joey Hess <id@joeyh.name>+ - Copyright 2012-2023 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings, BangPatterns #-} module Command.Log where @@ -16,23 +16,24 @@ import Data.Time import qualified Data.ByteString.Char8 as B8 import qualified System.FilePath.ByteString as P+import Control.Concurrent.Async import Command import Logs import Logs.Location+import Logs.UUID+import qualified Logs.Presence.Pure as PLog+import Logs.Trust.Pure (parseTrustLog)+import Logs.UUIDBased (simpleMap)+import qualified Annex import qualified Annex.Branch-import qualified Git-import Git.Command import qualified Remote-import qualified Annex--data RefChange = RefChange - { changetime :: POSIXTime- , oldref :: Git.Ref- , newref :: Git.Ref- , changekey :: Key- }- deriving (Show)+import qualified Git+import Git.Log+import Git.CatFile+import Types.TrustLevel+import Utility.DataUnits+import Utility.HumanTime data LogChange = Added | Removed @@ -46,7 +47,14 @@ data LogOptions = LogOptions { logFiles :: CmdParams , allOption :: Bool+ , sizesOfOption :: Maybe (DeferredParse UUID)+ , sizesOption :: Bool+ , totalSizesOption :: Bool+ , intervalOption :: Maybe Duration+ , receivedOption :: Bool+ , gnuplotOption :: Bool , rawDateOption :: Bool+ , bytesOption :: Bool , gourceOption :: Bool , passthruOptions :: [CommandParam] }@@ -59,11 +67,41 @@ <> short 'A' <> help "display location log changes to all files" )+ <*> optional ((parseUUIDOption <$> strOption+ ( long "sizesof"+ <> metavar (paramRemote `paramOr` paramDesc `paramOr` paramUUID)+ <> help "display history of sizes of this repository"+ <> completeRemotes+ ))) <*> switch+ ( long "sizes"+ <> help "display history of sizes of all repositories"+ )+ <*> switch+ ( long "totalsizes"+ <> help "display history of total sizes of all repositories"+ )+ <*> optional (option (eitherReader parseDuration)+ ( long "interval" <> metavar paramTime+ <> help "minimum time between displays of changed size"+ ))+ <*> switch+ ( long "received"+ <> help "display received data per interval rather than repository sizes"+ )+ <*> switch+ ( long "gnuplot"+ <> help "graph the history"+ )+ <*> switch ( long "raw-date" <> help "display seconds from unix epoch" ) <*> switch+ ( long "bytes"+ <> help "display sizes in bytes"+ )+ <*> switch ( long "gource" <> help "format output for gource" )@@ -86,7 +124,16 @@ seek :: LogOptions -> CommandSeek seek o = ifM (null <$> Annex.Branch.getUnmergedRefs)- ( do+ ( maybe (pure Nothing) (Just <$$> getParsed) (sizesOfOption o) >>= \case+ Just u -> sizeHistoryInfo (Just u) o+ Nothing -> if sizesOption o || totalSizesOption o+ then sizeHistoryInfo Nothing o+ else go + , giveup "This repository is read-only, and there are unmerged git-annex branches, which prevents displaying location log changes. (Set annex.merge-annex-branches to false to ignore the unmerged git-annex branches.)"+ )+ where+ ww = WarnUnmatchLsFiles "log"+ go = do m <- Remote.uuidDescriptions zone <- liftIO getCurrentTimeZone outputter <- mkOutputter m zone o <$> jsonOutputEnabled@@ -102,10 +149,6 @@ =<< workTreeItems ww fs ([], True) -> commandAction (startAll o outputter) (_, True) -> giveup "Cannot specify both files and --all"- , giveup "This repository is read-only, and there are unmerged git-annex branches, which prevents displaying location log changes. (Set annex.merge-annex-branches to false to ignore the unmerged git-annex branches.)"- )- where- ww = WarnUnmatchLsFiles "log" start :: LogOptions -> (ActionItem -> SeekInput -> Outputter) -> SeekInput -> RawFilePath -> Key -> CommandStart start o outputter si file key = do@@ -117,7 +160,7 @@ startAll :: LogOptions -> (ActionItem -> SeekInput -> Outputter) -> CommandStart startAll o outputter = do- (changes, cleanup) <- getAllLog (passthruOptions o)+ (changes, cleanup) <- getGitLogAnnex [] (passthruOptions o) showLog (\ai -> outputter ai (SeekInput [])) changes void $ liftIO cleanup stop@@ -136,7 +179,7 @@ - This also generates subtly better output when the git-annex branch - got diverged. -}-showLogIncremental :: Outputter -> [RefChange] -> Annex ()+showLogIncremental :: Outputter -> [RefChange Key] -> Annex () showLogIncremental outputter ps = do sets <- mapM (getset newref) ps previous <- maybe (return genesis) (getset oldref) (lastMaybe ps)@@ -153,9 +196,9 @@ {- Displays changes made. Streams, and can display changes affecting - different keys, but does twice as much reading of logged values - as showLogIncremental. -}-showLog :: (ActionItem -> Outputter) -> [RefChange] -> Annex ()+showLog :: (ActionItem -> Outputter) -> [RefChange Key] -> Annex () showLog outputter cs = forM_ cs $ \c -> do- let ai = mkActionItem (changekey c)+ let ai = mkActionItem (changed c) new <- S.fromList <$> loggedLocationsRef (newref c) old <- S.fromList <$> loggedLocationsRef (oldref c) sequence_ $ compareChanges (outputter ai)@@ -166,7 +209,7 @@ | jsonenabled = jsonOutput m ai si | rawDateOption o = normalOutput lookupdescription ai rawTimeStamp | gourceOption o = gourceOutput lookupdescription ai - | otherwise = normalOutput lookupdescription ai (showTimeStamp zone)+ | otherwise = normalOutput lookupdescription ai (showTimeStamp zone rfc822DateFormat) where lookupdescription u = maybe (fromUUID u) (fromUUIDDesc) (M.lookup u m) @@ -236,85 +279,250 @@ - once the location log file is gone avoids it checking all the way back - to commit 0 to see if it used to exist, so generally speeds things up a - *lot* for newish files. -}-getKeyLog :: Key -> [CommandParam] -> Annex ([RefChange], IO Bool)+getKeyLog :: Key -> [CommandParam] -> Annex ([RefChange Key], IO Bool) getKeyLog key os = do top <- fromRepo Git.repoPath p <- liftIO $ relPathCwdToFile top config <- Annex.getGitConfig let logfile = p P.</> locationLogFile config key- getGitLog [fromRawFilePath logfile] (Param "--remove-empty" : os)--{- Streams the git log for all git-annex branch changes. -}-getAllLog :: [CommandParam] -> Annex ([RefChange], IO Bool)-getAllLog = getGitLog []+ getGitLogAnnex [fromRawFilePath logfile] (Param "--remove-empty" : os) -getGitLog :: [FilePath] -> [CommandParam] -> Annex ([RefChange], IO Bool)-getGitLog fs os = do+getGitLogAnnex :: [FilePath] -> [CommandParam] -> Annex ([RefChange Key], IO Bool)+getGitLogAnnex fs os = do config <- Annex.getGitConfig- (ls, cleanup) <- inRepo $ pipeNullSplit $- [ Param "log"- , Param "-z"- , Param "--pretty=format:%ct"- , Param "--raw"- , Param "--no-abbrev"- ] ++ os ++- [ Param $ Git.fromRef Annex.Branch.fullname- , Param "--"- ] ++ map Param fs- return (parseGitRawLog config (map decodeBL ls), cleanup)+ let fileselector = locationLogFileKey config . toRawFilePath+ inRepo $ getGitLog Annex.Branch.fullname fs os fileselector --- Parses chunked git log --raw output, which looks something like:------ [ "timestamp\n:changeline"--- , "logfile"--- , ""--- , "timestamp\n:changeline"--- , "logfile"--- , ":changeline"--- , "logfile"--- , ""--- ]------ The timestamp is not included before all changelines, so--- keep track of the most recently seen timestamp.-parseGitRawLog :: GitConfig -> [String] -> [RefChange]-parseGitRawLog config = parse epoch+showTimeStamp :: TimeZone -> String -> POSIXTime -> String+showTimeStamp zone format = formatTime defaultTimeLocale format+ . utcToZonedTime zone . posixSecondsToUTCTime++rawTimeStamp :: POSIXTime -> String+rawTimeStamp t = filter (/= 's') (show t)++sizeHistoryInfo :: (Maybe UUID) -> LogOptions -> Annex ()+sizeHistoryInfo mu o = do+ uuidmap <- getuuidmap+ zone <- liftIO getCurrentTimeZone+ dispst <- displaystart uuidmap zone+ (l, cleanup) <- getlog+ g <- Annex.gitRepo+ liftIO $ catObjectStream g $ \feeder closer reader -> do+ tid <- async $ do+ forM_ l $ \c -> + feeder ((changed c, changetime c), newref c)+ closer+ go reader mempty mempty mempty uuidmap dispst+ wait tid+ void $ liftIO cleanup where- epoch = toEnum 0 :: POSIXTime- parse oldts ([]:rest) = parse oldts rest- parse oldts (c1:c2:rest) = case mrc of- Just rc -> rc : parse ts rest- Nothing -> parse ts (c2:rest)+ -- Go through the log of the git-annex branch in reverse,+ -- and in date order, and pick out changes to location log files+ -- and to the trust log.+ getlog = do+ config <- Annex.getGitConfig+ let fileselector = \f -> let f' = toRawFilePath f in+ case locationLogFileKey config f' of+ Just k -> Just (Right k)+ Nothing+ | f' == trustLog -> Just (Left ())+ | otherwise -> Nothing+ inRepo $ getGitLog Annex.Branch.fullname []+ [ Param "--date-order"+ , Param "--reverse"+ ]+ fileselector++ go reader sizemap locmap trustlog uuidmap dispst = reader >>= \case+ Just ((Right k, t), Just logcontent) -> do+ let !newlog = parselocationlog logcontent uuidmap+ let !(sizemap', locmap') = case M.lookup k locmap of+ Nothing -> addnew k sizemap locmap newlog+ Just v -> update k sizemap locmap v newlog+ dispst' <- displaysizes dispst trustlog uuidmap sizemap' t+ go reader sizemap' locmap' trustlog uuidmap dispst'+ Just ((Left (), t), Just logcontent) -> do+ let !trustlog' = trustlog <> parseTrustLog logcontent+ dispst' <- displaysizes dispst trustlog' uuidmap sizemap t+ go reader sizemap locmap trustlog' uuidmap dispst'+ Just (_, Nothing) -> + go reader sizemap locmap trustlog uuidmap dispst+ Nothing -> + displayend dispst++ -- Known uuids are stored in this map, and when uuids are stored in the+ -- state, it's a value from this map. This avoids storing multiple+ -- copies of the same uuid in memory.+ getuuidmap = do+ (us, ds) <- unzip . M.toList <$> uuidDescMap+ return $ M.fromList (zip us (zip us ds))+ + -- Parses a location log file, and replaces the logged uuid+ -- with one from the uuidmap.+ parselocationlog logcontent uuidmap = + map replaceuuid $ PLog.parseLog logcontent where- (ts, cl) = case separate (== '\n') c1 of- (cl', []) -> (oldts, cl')- (tss, cl') -> (parseTimeStamp tss, cl')- mrc = do- (old, new) <- parseRawChangeLine cl- key <- locationLogFileKey config (toRawFilePath c2)- return $ RefChange- { changetime = ts- , oldref = old- , newref = new- , changekey = key- } - parse _ _ = []+ replaceuuid ll = + let !u = toUUID $ PLog.fromLogInfo $ PLog.info ll+ !ushared = maybe u fst $ M.lookup u uuidmap+ in ll { PLog.info = PLog.LogInfo (fromUUID ushared) } --- Parses something like "100644 100644 oldsha newsha M"-parseRawChangeLine :: String -> Maybe (Git.Ref, Git.Ref)-parseRawChangeLine = go . words- where- go (_:_:oldsha:newsha:_) = - Just (Git.Ref (encodeBS oldsha), Git.Ref (encodeBS newsha))- go _ = Nothing+ presentlocs = map (toUUID . PLog.fromLogInfo . PLog.info)+ . PLog.filterPresent+ + -- Since the git log is being traversed in date order, commits+ -- from different branches can appear one after the other, and so+ -- the newlog is not necessarily the complete state known at that+ -- time across all git-annex repositories.+ --+ -- This combines the new location log with what has been+ -- accumulated so far, which is equivilant to merging together+ -- all git-annex branches at that point in time.+ update k sizemap locmap (oldlog, oldlocs) newlog = + ( updatesize (updatesize sizemap sz (S.toList addedlocs))+ (negate sz) (S.toList removedlocs)+ , M.insert k (combinedlog, combinedlocs) locmap+ )+ where+ sz = ksz k+ combinedlog = PLog.compactLog (oldlog ++ newlog)+ combinedlocs = S.fromList (presentlocs combinedlog)+ addedlocs = S.difference combinedlocs oldlocs+ removedlocs+ | receivedOption o = S.empty+ | otherwise = S.difference oldlocs combinedlocs+ + addnew k sizemap locmap newlog = + ( updatesize sizemap (ksz k) locs+ , M.insert k (newlog, S.fromList locs) locmap+ )+ where+ locs = presentlocs newlog+ + ksz k = fromMaybe 0 (fromKey keySize k)+ + updatesize sizemap _ [] = sizemap+ updatesize sizemap sz (l:ls) =+ updatesize (M.insertWith (+) l sz sizemap) sz ls -parseTimeStamp :: String -> POSIXTime-parseTimeStamp = utcTimeToPOSIXSeconds . fromMaybe (giveup "bad timestamp") .- parseTimeM True defaultTimeLocale "%s"+ epoch = toEnum 0 -showTimeStamp :: TimeZone -> POSIXTime -> String-showTimeStamp zone = formatTime defaultTimeLocale rfc822DateFormat - . utcToZonedTime zone . posixSecondsToUTCTime+ displaystart uuidmap zone+ | gnuplotOption o = do+ file <- (</>)+ <$> fromRepo (fromRawFilePath . gitAnnexDir)+ <*> pure "gnuplot"+ liftIO $ putStrLn $ "Generating gnuplot script in " ++ file+ h <- liftIO $ openFile file WriteMode+ liftIO $ mapM_ (hPutStrLn h)+ [ "set datafile separator ','"+ , "set timefmt \"%Y-%m-%dT%H:%M:%S\""+ , "set xdata time"+ , "set xtics out"+ , "set ytics format '%s%c'"+ , "set tics front"+ , "set key spacing 1 font \",8\""+ ]+ unless (sizesOption o) $+ liftIO $ hPutStrLn h "set key off"+ liftIO $ hPutStrLn h "$data << EOD"+ liftIO $ hPutStrLn h $ if sizesOption o+ then uuidmapheader+ else csvheader ["value"]+ let endaction = do+ mapM_ (hPutStrLn h)+ [ "EOD"+ , ""+ , "plot for [i=2:" ++ show ncols ++ ":1] \\"+ , " \"$data\" using 1:(sum [col=i:" ++ show ncols ++ "] column(col)) \\"+ , " title columnheader(i) \\"+ , if receivedOption o+ then " with boxes"+ else " with filledcurves x1"+ ]+ hFlush h+ putStrLn $ "Running gnuplot..."+ void $ liftIO $ boolSystem "gnuplot"+ [Param "-p", File file]+ return (dispst h endaction)+ | sizesOption o = do+ liftIO $ putStrLn uuidmapheader+ return (dispst stdout noop)+ | otherwise = return (dispst stdout noop)+ where+ dispst fileh endaction = + (zone, False, epoch, Nothing, mempty, fileh, endaction)+ ncols+ | sizesOption o = 1 + length (M.elems uuidmap)+ | otherwise = 2+ uuidmapheader = csvheader $+ map (fromUUIDDesc . snd) (M.elems uuidmap) -rawTimeStamp :: POSIXTime -> String-rawTimeStamp t = filter (/= 's') (show t)+ displaysizes (zone, displayedyet, prevt, prevoutput, prevsizemap, h, endaction) trustlog uuidmap sizemap t+ | t - prevt >= dt && changedoutput = do+ displayts zone t output h+ return (zone, True, t, Just output, sizemap', h, endaction)+ | t < prevt = return (zone, displayedyet, t, Just output, prevsizemap, h, endaction)+ | otherwise = return (zone, displayedyet, prevt, prevoutput, prevsizemap, h, endaction)+ where+ output = intercalate "," (map showsize sizes)+ us = case mu of+ Just u -> [u]+ Nothing -> M.keys uuidmap+ sizes+ | totalSizesOption o = [sum (M.elems sizedisplaymap)]+ | otherwise = map (\u -> fromMaybe 0 (M.lookup u sizedisplaymap)) us+ dt = maybe 1 durationToPOSIXTime (intervalOption o)++ changedoutput+ | receivedOption o = + any (/= 0) sizes + || prevoutput /= Just output+ | otherwise = + (displayedyet || any (/= 0) sizes)+ && (prevoutput /= Just output)++ sizedisplaymap+ | receivedOption o = + M.unionWith posminus sizemap' prevsizemap+ | otherwise = sizemap'++ posminus a b = max 0 (a - b)++ -- A verison of sizemap where uuids that are currently dead+ -- have 0 size.+ sizemap' = M.mapWithKey zerodead sizemap+ zerodead u v = case M.lookup u (simpleMap trustlog) of+ Just DeadTrusted -> 0+ _ -> v++ displayts zone t output h = do+ hPutStrLn h (ts ++ "," ++ output)+ hFlush h+ where+ ts = if rawDateOption o && not (gnuplotOption o)+ then rawTimeStamp t+ else showTimeStamp zone "%Y-%m-%dT%H:%M:%S" t++ displayend dispst@(_, _, _, _, _, _, endaction) = do+ displayendsizes dispst+ endaction++ displayendsizes (zone, _, _, Just output, _, h, _) = do+ now <- getPOSIXTime+ displayts zone now output h+ displayendsizes _ = return ()++ showsize n+ | bytesOption o || gnuplotOption o = show n+ | otherwise = roughSize storageUnits True n+ + csvquote s+ | ',' `elem` s || '"' `elem` s = + '"' : concatMap escquote s ++ ['"']+ | otherwise = s+ where+ escquote '"' = "\"\""+ escquote c = [c]+ + csvheader l = intercalate "," ("date" : map csvquote l)
Command/LookupKey.hs view
@@ -50,11 +50,13 @@ -- To support absolute filenames, pass through git ls-files. -- But, this plumbing command does not recurse through directories. seekSingleGitFile :: FilePath -> Annex (Maybe RawFilePath)-seekSingleGitFile file = do- (l, cleanup) <- inRepo (Git.LsFiles.inRepo [] [toRawFilePath file])- r <- case l of- (f:[]) | takeFileName (fromRawFilePath f) == takeFileName file ->- return (Just f)- _ -> return Nothing- void $ liftIO cleanup- return r+seekSingleGitFile file+ | isRelative file = return (Just (toRawFilePath file))+ | otherwise = do+ (l, cleanup) <- inRepo (Git.LsFiles.inRepo [] [toRawFilePath file])+ r <- case l of+ (f:[]) | takeFileName (fromRawFilePath f) == takeFileName file ->+ return (Just f)+ _ -> return Nothing+ void $ liftIO cleanup+ return r
Command/Move.hs view
@@ -334,18 +334,24 @@ next $ return True fromToStart :: RemoveWhen -> AssociatedFile -> Key -> ActionItem -> SeekInput -> Remote -> Remote -> CommandStart-fromToStart removewhen afile key ai si src dest = do- if Remote.uuid src == Remote.uuid dest- then stop- else do- u <- getUUID- if u == Remote.uuid src- then toStart removewhen afile key ai si dest- else if u == Remote.uuid dest- then fromStart removewhen afile key ai si src- else stopUnless (fromOk src key) $- starting (describeMoveAction removewhen) (OnlyActionOn key ai) si $- fromToPerform src dest removewhen key afile+fromToStart removewhen afile key ai si src dest = + stopUnless somethingtodo $ do+ u <- getUUID+ if u == Remote.uuid src+ then toStart removewhen afile key ai si dest+ else if u == Remote.uuid dest+ then fromStart removewhen afile key ai si src+ else stopUnless (fromOk src key) $+ starting (describeMoveAction removewhen) (OnlyActionOn key ai) si $+ fromToPerform src dest removewhen key afile+ where+ somethingtodo+ | Remote.uuid src == Remote.uuid dest = return False+ | otherwise = do+ fast <- Annex.getRead Annex.fast+ if fast && removewhen == RemoveNever+ then not <$> expectedPresent dest key+ else return True {- When there is a local copy, transfer it to the dest, and drop from the src. -
Command/ReKey.hs view
@@ -111,10 +111,9 @@ when (linkCount st > 1) $ do freezeContent oldobj replaceWorkTreeFile (fromRawFilePath file) $ \tmp -> do- let tmp' = toRawFilePath tmp- unlessM (checkedCopyFile oldkey oldobj tmp' Nothing) $+ unlessM (checkedCopyFile oldkey oldobj tmp Nothing) $ giveup "can't lock old key"- thawContent tmp'+ thawContent tmp ic <- withTSDelta (liftIO . genInodeCache file) case v of Left e -> do
Command/Unlock.hs view
@@ -54,14 +54,14 @@ destic <- replaceWorkTreeFile (fromRawFilePath dest) $ \tmp -> do ifM (inAnnex key) ( do- r <- linkFromAnnex' key (toRawFilePath tmp) destmode+ r <- linkFromAnnex' key tmp destmode case r of LinkAnnexOk -> return () LinkAnnexNoop -> return () LinkAnnexFailed -> giveup "unlock failed"- , liftIO $ writePointerFile (toRawFilePath tmp) key destmode+ , liftIO $ writePointerFile tmp key destmode )- withTSDelta (liftIO . genInodeCache (toRawFilePath tmp))+ withTSDelta (liftIO . genInodeCache tmp) next $ cleanup dest destic key destmode cleanup :: RawFilePath -> Maybe InodeCache -> Key -> Maybe FileMode -> CommandCleanup
Creds.hs view
@@ -100,10 +100,10 @@ cmd <- gpgCmd <$> Annex.getGitConfig s <- liftIO $ encrypt cmd (pc, gc) cipher (feedBytes $ L.pack $ encodeCredPair creds)- (readBytesStrictly $ return . S.unpack)- storeconfig' key (Accepted (toB64 s))+ (readBytesStrictly return)+ storeconfig' key (Accepted (decodeBS (toB64 s))) storeconfig creds key Nothing =- storeconfig' key (Accepted (toB64 $ encodeCredPair creds))+ storeconfig' key (Accepted (decodeBS $ toB64 $ encodeBS $ encodeCredPair creds)) storeconfig' key val = return $ pc { parsedRemoteConfigMap = M.insert key (RemoteConfigValue val) (parsedRemoteConfigMap pc)@@ -129,13 +129,13 @@ case (getval, mcipher) of (Nothing, _) -> return Nothing (Just enccreds, Just (cipher, storablecipher)) ->- fromenccreds enccreds cipher storablecipher+ fromenccreds (encodeBS enccreds) cipher storablecipher (Just bcreds, Nothing) ->- fromcreds $ fromB64 bcreds+ fromcreds $ decodeBS $ fromB64 $ encodeBS bcreds fromenccreds enccreds cipher storablecipher = do cmd <- gpgCmd <$> Annex.getGitConfig mcreds <- liftIO $ catchMaybeIO $ decrypt cmd (c, gc) cipher- (feedBytes $ L.pack $ fromB64 enccreds)+ (feedBytes $ L.fromStrict $ fromB64 enccreds) (readBytesStrictly $ return . S.unpack) case mcreds of Just creds -> fromcreds creds@@ -146,7 +146,7 @@ case storablecipher of SharedCipher {} -> showLongNote "gpg error above was caused by an old git-annex bug in credentials storage. Working around it.." _ -> giveup "*** Insecure credentials storage detected for this remote! See https://git-annex.branchable.com/upgrades/insecure_embedded_creds/"- fromcreds $ fromB64 enccreds+ fromcreds $ decodeBS $ fromB64 enccreds fromcreds creds = case decodeCredPair creds of Just credpair -> do writeCacheCredPair credpair storage
Crypto.hs view
@@ -3,7 +3,7 @@ - Currently using gpg; could later be modified to support different - crypto backends if necessary. -- - Copyright 2011-2022 Joey Hess <id@joeyh.name>+ - Copyright 2011-2023 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -39,7 +39,6 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L-import Data.ByteString.UTF8 (fromString) import Control.Monad.IO.Class import Annex.Common@@ -71,12 +70,12 @@ cipherSize :: Int cipherSize = 512 -cipherPassphrase :: Cipher -> String-cipherPassphrase (Cipher c) = drop cipherBeginning c+cipherPassphrase :: Cipher -> S.ByteString+cipherPassphrase (Cipher c) = S.drop cipherBeginning c cipherPassphrase (MacOnlyCipher _) = giveup "MAC-only cipher" -cipherMac :: Cipher -> String-cipherMac (Cipher c) = take cipherBeginning c+cipherMac :: Cipher -> S.ByteString+cipherMac (Cipher c) = S.take cipherBeginning c cipherMac (MacOnlyCipher c) = c {- Creates a new Cipher, encrypted to the specified key id. -}@@ -168,7 +167,7 @@ - on content. It does need to be repeatable. -} encryptKey :: Mac -> Cipher -> EncKey encryptKey mac c k = mkKey $ \d -> d- { keyName = S.toShort $ encodeBS $ macWithCipher mac c (serializeKey k)+ { keyName = S.toShort $ encodeBS $ macWithCipher mac c (serializeKey' k) , keyVariety = OtherKey $ encryptedBackendNamePrefix <> encodeBS (showMac mac) }@@ -225,10 +224,10 @@ where params = Param "--decrypt" : getGpgDecParams c -macWithCipher :: Mac -> Cipher -> String -> String+macWithCipher :: Mac -> Cipher -> S.ByteString -> String macWithCipher mac c = macWithCipher' mac (cipherMac c)-macWithCipher' :: Mac -> String -> String -> String-macWithCipher' mac c s = calcMac mac (fromString c) (fromString s)+macWithCipher' :: Mac -> S.ByteString -> S.ByteString -> String+macWithCipher' mac c s = calcMac mac c s {- Ensure that macWithCipher' returns the same thing forevermore. -} prop_HmacSha1WithCipher_sane :: Bool
Database/ContentIdentifier.hs view
@@ -46,7 +46,6 @@ import Git.Types import Git.Sha import Git.FilePath-import qualified Git.Ref import qualified Git.DiffTree as DiffTree import Logs import qualified Logs.ContentIdentifier as Log@@ -162,10 +161,7 @@ needsUpdateFromLog :: ContentIdentifierHandle -> Annex (Maybe (Sha, Sha)) needsUpdateFromLog db = do oldtree <- liftIO $ getAnnexBranchTree db- inRepo (Git.Ref.tree Annex.Branch.fullname) >>= \case- Just currtree | currtree /= oldtree ->- return $ Just (oldtree, currtree)- _ -> return Nothing+ Annex.Branch.updatedFromTree oldtree {- The database should be locked for write when calling this. -} updateFromLog :: ContentIdentifierHandle -> (Sha, Sha) -> Annex ContentIdentifierHandle
Database/Export.hs view
@@ -73,18 +73,18 @@ -- Files that have been exported to the remote and are present on it. Exported key Key- file SFilePath+ file SByteString ExportedIndex key file -- Directories that exist on the remote, and the files that are in them. ExportedDirectory- subdir SFilePath- file SFilePath+ subdir SByteString+ file SByteString ExportedDirectoryIndex subdir file -- The content of the tree that has been exported to the remote. -- Not all of these files are necessarily present on the remote yet. ExportTree key Key- file SFilePath+ file SByteString ExportTreeKeyFileIndex key file ExportTreeFileKeyIndex file key -- The tree stored in ExportTree@@ -139,26 +139,26 @@ addExportedLocation h k el = queueDb h $ do void $ insertUniqueFast $ Exported k ef let edirs = map- (\ed -> ExportedDirectory (SFilePath (fromExportDirectory ed)) ef)+ (\ed -> ExportedDirectory (SByteString (fromExportDirectory ed)) ef) (exportDirectories el) putMany edirs where- ef = SFilePath (fromExportLocation el)+ ef = SByteString (fromExportLocation el) removeExportedLocation :: ExportHandle -> Key -> ExportLocation -> IO () removeExportedLocation h k el = queueDb h $ do deleteWhere [ExportedKey ==. k, ExportedFile ==. ef]- let subdirs = map (SFilePath . fromExportDirectory)+ let subdirs = map (SByteString . fromExportDirectory) (exportDirectories el) deleteWhere [ExportedDirectoryFile ==. ef, ExportedDirectorySubdir <-. subdirs] where- ef = SFilePath (fromExportLocation el)+ ef = SByteString (fromExportLocation el) {- Note that this does not see recently queued changes. -} getExportedLocation :: ExportHandle -> Key -> IO [ExportLocation] getExportedLocation (ExportHandle h _) k = H.queryDbQueue h $ do l <- selectList [ExportedKey ==. k] []- return $ map (mkExportLocation . (\(SFilePath f) -> f) . exportedFile . entityVal) l+ return $ map (mkExportLocation . (\(SByteString f) -> f) . exportedFile . entityVal) l {- Note that this does not see recently queued changes. -} isExportDirectoryEmpty :: ExportHandle -> ExportDirectory -> IO Bool@@ -166,13 +166,13 @@ l <- selectList [ExportedDirectorySubdir ==. ed] [] return $ null l where- ed = SFilePath $ fromExportDirectory d+ ed = SByteString $ fromExportDirectory d {- Get locations in the export that might contain a key. -} getExportTree :: ExportHandle -> Key -> IO [ExportLocation] getExportTree (ExportHandle h _) k = H.queryDbQueue h $ do l <- selectList [ExportTreeKey ==. k] []- return $ map (mkExportLocation . (\(SFilePath f) -> f) . exportTreeFile . entityVal) l+ return $ map (mkExportLocation . (\(SByteString f) -> f) . exportTreeFile . entityVal) l {- Get keys that might be currently exported to a location. -@@ -183,19 +183,19 @@ map (exportTreeKey . entityVal) <$> selectList [ExportTreeFile ==. ef] [] where- ef = SFilePath (fromExportLocation el)+ ef = SByteString (fromExportLocation el) addExportTree :: ExportHandle -> Key -> ExportLocation -> IO () addExportTree h k loc = queueDb h $ void $ insertUniqueFast $ ExportTree k ef where- ef = SFilePath (fromExportLocation loc)+ ef = SByteString (fromExportLocation loc) removeExportTree :: ExportHandle -> Key -> ExportLocation -> IO () removeExportTree h k loc = queueDb h $ deleteWhere [ExportTreeKey ==. k, ExportTreeFile ==. ef] where- ef = SFilePath (fromExportLocation loc)+ ef = SByteString (fromExportLocation loc) -- An action that is passed the old and new values that were exported, -- and updates state.
+ Database/ImportFeed.hs view
@@ -0,0 +1,211 @@+{- Sqlite database of known urls, and another of known itemids,+ - for use by git-annex importfeed.+ -+ - Copyright 2023 Joey Hess <id@joeyh.name>+ -:+ - Licensed under the GNU AGPL version 3 or higher.+ -}++{-# LANGUAGE CPP #-}+{-# LANGUAGE QuasiQuotes, TypeFamilies, TypeOperators, TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings, GADTs, FlexibleContexts, EmptyDataDecls #-}+{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DataKinds, FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+#if MIN_VERSION_persistent_template(2,8,0)+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE StandaloneDeriving #-}+#endif++module Database.ImportFeed (+ ImportFeedDbHandle,+ openDb,+ closeDb,+ isKnownUrl,+ isKnownItemId,+) where++import Database.Types+import qualified Database.Queue as H+import Database.Init+import Database.Utility+import Annex.Locations+import Annex.Common hiding (delete)+import qualified Annex.Branch+import Git.Types+import Git.Sha+import Git.FilePath+import qualified Git.DiffTree as DiffTree+import Logs+import Logs.Web+import Logs.MetaData+import Types.MetaData+import Annex.MetaData.StandardFields+import Annex.LockFile+import qualified Utility.RawFilePath as R++import Database.Persist.Sql hiding (Key)+import Database.Persist.TH+import qualified System.FilePath.ByteString as P+import qualified Data.ByteString as B+import qualified Data.Set as S++data ImportFeedDbHandle = ImportFeedDbHandle H.DbQueue++-- Note on indexes: ContentIndentifiersKeyRemoteCidIndex etc are really+-- uniqueness constraints, which cause sqlite to automatically add indexes.+-- So when adding indexes, have to take care to only add ones that work as+-- uniqueness constraints. (Unfortunately persistent does not support indexes+-- that are not uniqueness constraints; +-- https://github.com/yesodweb/persistent/issues/109)+share [mkPersist sqlSettings, mkMigrate "migrateImportFeed"] [persistLowerCase|+KnownUrls+ url SByteString+ UniqueUrl url+KnownItemIds+ itemid SByteString+ UniqueItemId itemid+-- The last git-annex branch tree sha that was used to update+-- KnownUrls and KnownItemIds+AnnexBranch+ tree SSha+ UniqueTree tree+|]++{- Opens the database, creating it if it doesn't exist yet.+ - Updates the database from the git-annex branch. -}+openDb :: Annex ImportFeedDbHandle+openDb = do+ dbdir <- calcRepo' gitAnnexImportFeedDbDir+ let db = dbdir P.</> "db"+ isnew <- liftIO $ not <$> R.doesPathExist db+ when isnew $+ initDb db $ void $ + runMigrationSilent migrateImportFeed+ dbh <- liftIO $ H.openDbQueue db "known_urls"+ let h = ImportFeedDbHandle dbh+ needsUpdateFromLog h >>= \case+ Nothing -> return ()+ Just v -> do+ lck <- calcRepo' gitAnnexImportFeedDbLock+ withExclusiveLock lck $+ updateFromLog h v+ return h++closeDb :: ImportFeedDbHandle -> Annex ()+closeDb (ImportFeedDbHandle h) = liftIO $ H.closeDbQueue h++isKnownUrl :: ImportFeedDbHandle -> URLString -> IO Bool+isKnownUrl (ImportFeedDbHandle h) u = + H.queryDbQueue h $ do+ l <- selectList+ [ KnownUrlsUrl ==. SByteString (encodeBS u)+ ] []+ return $ not (null l)++isKnownItemId :: ImportFeedDbHandle -> B.ByteString -> IO Bool+isKnownItemId (ImportFeedDbHandle h) i = + H.queryDbQueue h $ do+ l <- selectList+ [ KnownItemIdsItemid ==. SByteString i+ ] []+ return $ not (null l)++recordKnownUrl :: ImportFeedDbHandle -> URLByteString -> IO ()+recordKnownUrl h u = queueDb h $+ void $ insertUniqueFast $ KnownUrls $ SByteString u++recordKnownItemId :: ImportFeedDbHandle -> SByteString -> IO ()+recordKnownItemId h i = queueDb h $+ void $ insertUniqueFast $ KnownItemIds i++recordAnnexBranchTree :: ImportFeedDbHandle -> Sha -> IO ()+recordAnnexBranchTree h s = queueDb h $ do+ deleteWhere ([] :: [Filter AnnexBranch])+ void $ insertUniqueFast $ AnnexBranch $ toSSha s++getAnnexBranchTree :: ImportFeedDbHandle -> IO Sha+getAnnexBranchTree (ImportFeedDbHandle h) = H.queryDbQueue h $ do+ l <- selectList ([] :: [Filter AnnexBranch]) []+ case l of+ (s:[]) -> return $ fromSSha $ annexBranchTree $ entityVal s+ _ -> return emptyTree++queueDb :: ImportFeedDbHandle -> SqlPersistM () -> IO ()+queueDb (ImportFeedDbHandle h) = H.queueDb h checkcommit+ where+ -- commit queue after 10000 changes+ checkcommit sz _lastcommittime+ | sz > 10000 = return True+ | otherwise = return False++{- Check if the git-annex branch has been updated and the database needs+ - to be updated with any new information from it. -}+needsUpdateFromLog :: ImportFeedDbHandle -> Annex (Maybe (Sha, Sha))+needsUpdateFromLog db = do+ oldtree <- liftIO $ getAnnexBranchTree db+ Annex.Branch.updatedFromTree oldtree++{- The database should be locked for write when calling this. -}+updateFromLog :: ImportFeedDbHandle -> (Sha, Sha) -> Annex ()+updateFromLog db@(ImportFeedDbHandle h) (oldtree, currtree)+ | oldtree == emptyTree = do+ scanbranch+ out+ | otherwise = do+ scandiff+ out+ where+ out = liftIO $ do+ recordAnnexBranchTree db currtree+ H.flushDbQueue h+ + knownitemids s = liftIO $ forM_ (S.toList s) $+ recordKnownItemId db . SByteString . fromMetaValue++ knownurls us = liftIO $ forM_ us $+ recordKnownUrl db+ + scandiff = do+ (l, cleanup) <- inRepo $+ DiffTree.diffTreeRecursive oldtree currtree+ mapM_ godiff l+ void $ liftIO $ cleanup+ + godiff ti = do+ let f = getTopFilePath (DiffTree.file ti)+ case extLogFileKey urlLogExt f of+ Just k -> do+ knownurls =<< getUrls' k+ Nothing -> case extLogFileKey metaDataLogExt f of+ Just k -> do+ m <- getCurrentMetaData k+ knownitemids (currentMetaDataValues itemIdField m)+ Nothing -> return ()++ -- When initially populating the database, this + -- is faster than diffing from the empty tree+ -- and looking up every log file.+ scanbranch = Annex.Branch.overBranchFileContents toscan goscan >>= \case+ Just () -> return ()+ Nothing -> scandiff+ + toscan f+ | isUrlLog f = Just ()+ | isMetaDataLog f = Just ()+ | otherwise = Nothing+ + goscan reader = reader >>= \case+ Just ((), f, Just content)+ | isUrlLog f -> do+ knownurls (parseUrlLog content)+ goscan reader+ | isMetaDataLog f -> do+ knownitemids $+ currentMetaDataValues itemIdField $+ parseCurrentMetaData content+ goscan reader+ | otherwise -> goscan reader+ Just ((), _, Nothing) -> goscan reader+ Nothing -> return ()
Database/Keys/SQL.hs view
@@ -46,7 +46,7 @@ share [mkPersist sqlSettings, mkMigrate "migrateKeysDb"] [persistLowerCase| Associated key Key- file SFilePath+ file SByteString KeyFileIndex key file FileKeyIndex file key Content@@ -87,7 +87,7 @@ (Associated k af) [AssociatedFile =. af, AssociatedKey =. k] where- af = SFilePath (getTopFilePath f)+ af = SByteString (getTopFilePath f) -- Faster than addAssociatedFile, but only safe to use when the file -- was not associated with a different key before, as it does not delete@@ -96,14 +96,14 @@ newAssociatedFile k f = queueDb $ insert_ $ Associated k af where- af = SFilePath (getTopFilePath f)+ af = SByteString (getTopFilePath f) {- Note that the files returned were once associated with the key, but - some of them may not be any longer. -} getAssociatedFiles :: Key -> ReadHandle -> IO [TopFilePath] getAssociatedFiles k = readDb $ do l <- selectList [AssociatedKey ==. k] []- return $ map (asTopFilePath . (\(SFilePath f) -> f) . associatedFile . entityVal) l+ return $ map (asTopFilePath . (\(SByteString f) -> f) . associatedFile . entityVal) l {- Gets any keys that are on record as having a particular associated file. - (Should be one or none.) -}@@ -112,13 +112,13 @@ l <- selectList [AssociatedFile ==. af] [] return $ map (associatedKey . entityVal) l where- af = SFilePath (getTopFilePath f)+ af = SByteString (getTopFilePath f) removeAssociatedFile :: Key -> TopFilePath -> WriteHandle -> IO () removeAssociatedFile k f = queueDb $ deleteWhere [AssociatedKey ==. k, AssociatedFile ==. af] where- af = SFilePath (getTopFilePath f)+ af = SByteString (getTopFilePath f) addInodeCaches :: Key -> [InodeCache] -> WriteHandle -> IO () addInodeCaches k is = queueDb $
Database/Types.hs view
@@ -79,15 +79,15 @@ instance PersistFieldSql ContentIdentifier where sqlType _ = SqlBlob --- A serialized RawFilePath.-newtype SFilePath = SFilePath S.ByteString+-- A serialized bytestring.+newtype SByteString = SByteString S.ByteString deriving (Eq, Show) -instance PersistField SFilePath where- toPersistValue (SFilePath b) = toPersistValue b- fromPersistValue v = SFilePath <$> fromPersistValue v+instance PersistField SByteString where+ toPersistValue (SByteString b) = toPersistValue b+ fromPersistValue v = SByteString <$> fromPersistValue v -instance PersistFieldSql SFilePath where+instance PersistFieldSql SByteString where sqlType _ = SqlBlob -- A serialized git Sha
Git/Construct.hs view
@@ -40,6 +40,7 @@ import qualified Git.Url as Url import Utility.UserInfo import Utility.Url.Parse+import qualified Utility.RawFilePath as R import qualified Data.ByteString as B import qualified System.FilePath.ByteString as P@@ -47,14 +48,14 @@ {- Finds the git repository used for the cwd, which may be in a parent - directory. -} fromCwd :: IO (Maybe Repo)-fromCwd = getCurrentDirectory >>= seekUp+fromCwd = R.getCurrentDirectory >>= seekUp where seekUp dir = do r <- checkForRepo dir case r of- Nothing -> case upFrom (toRawFilePath dir) of+ Nothing -> case upFrom dir of Nothing -> return Nothing- Just d -> seekUp (fromRawFilePath d)+ Just d -> seekUp d Just loc -> pure $ Just $ newFrom loc {- Local Repo constructor, accepts a relative or absolute path. -}@@ -220,26 +221,27 @@ {- Checks if a git repository exists in a directory. Does not find - git repositories in parent directories. -}-checkForRepo :: FilePath -> IO (Maybe RepoLocation)+checkForRepo :: RawFilePath -> IO (Maybe RepoLocation) checkForRepo dir = check isRepo $- check (checkGitDirFile (toRawFilePath dir)) $- check (checkdir (isBareRepo dir)) $+ check (checkGitDirFile dir) $+ check (checkdir (isBareRepo dir')) $ return Nothing where check test cont = maybe cont (return . Just) =<< test checkdir c = ifM c- ( return $ Just $ LocalUnknown $ toRawFilePath dir+ ( return $ Just $ LocalUnknown dir , return Nothing ) isRepo = checkdir $ - doesFileExist (dir </> ".git" </> "config")+ doesFileExist (dir' </> ".git" </> "config") <||> -- A git-worktree lacks .git/config, but has .git/gitdir. -- (Normally the .git is a file, not a symlink, but it can -- be converted to a symlink and git will still work; -- this handles that case.)- doesFileExist (dir </> ".git" </> "gitdir")+ doesFileExist (dir' </> ".git" </> "gitdir")+ dir' = fromRawFilePath dir isBareRepo :: FilePath -> IO Bool isBareRepo dir = doesFileExist (dir </> "config")
Git/Hook.hs view
@@ -19,6 +19,7 @@ import System.PosixCompat.Files (fileMode) #endif +import qualified Data.ByteString as B data Hook = Hook { hookName :: FilePath@@ -57,7 +58,12 @@ where f = hookFile h r go = do- viaTmp writeFile f (hookScript h)+ -- On Windows, using B.writeFile here avoids+ -- the newline translation done by writeFile.+ -- Hook scripts on Windows could use CRLF endings, but+ -- they typically use unix newlines, which does work there+ -- and makes the repository more portable.+ viaTmp B.writeFile f (encodeBS (hookScript h)) void $ tryIO $ modifyFileMode (toRawFilePath f) (addModes executeModes)@@ -81,6 +87,10 @@ expectedContent :: Hook -> Repo -> IO ExpectedContent expectedContent h r = do+ -- Note that on windows, this readFile does newline translation,+ -- and so a hook file that has CRLF will be treated the same as one+ -- that has LF. That is intentional, since users may have a reason+ -- to prefer one or the other. content <- readFile $ hookFile h r return $ if content == hookScript h then ExpectedContent
+ Git/Log.hs view
@@ -0,0 +1,107 @@+{- git log+ -+ - Copyright 2023 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module Git.Log where++import Common+import Git+import Git.Command++import Data.Time+import Data.Time.Clock.POSIX++-- A change made to a file.+data RefChange t = RefChange+ { changetime :: POSIXTime+ , changed :: t+ , changedfile :: FilePath+ , oldref :: Ref+ , newref :: Ref+ }+ deriving (Show)++-- Get the git log. Note that the returned cleanup action should only be+-- run after processing the returned list.+getGitLog+ :: Ref+ -> [FilePath]+ -> [CommandParam]+ -> (FilePath -> Maybe t)+ -> Repo+ -> IO ([RefChange t], IO Bool)+getGitLog ref fs os fileselector repo = do+ (ls, cleanup) <- pipeNullSplit ps repo+ return (parseGitRawLog fileselector (map decodeBL ls), cleanup)+ where+ ps =+ [ Param "log"+ , Param "-z"+ , Param ("--pretty=format:"++commitinfoFormat)+ , Param "--raw"+ , Param "--no-abbrev"+ , Param "--no-renames"+ ] ++ os +++ [ Param (fromRef ref)+ , Param "--"+ ] ++ map Param fs ++-- The commitinfo is the timestamp of the commit, followed by+-- the commit hash and then the commit's parents, separated by spaces.+commitinfoFormat :: String+commitinfoFormat = "%ct"++-- Parses chunked git log --raw output generated by getGitLog, +-- which looks something like:+--+-- [ "commitinfo\n:changeline"+-- , "filename"+-- , ""+-- , "commitinfo\n:changeline"+-- , "filename"+-- , ":changeline"+-- , "filename"+-- , ""+-- ]+--+-- The commitinfo is not included before all changelines, so+-- keep track of the most recently seen commitinfo.+parseGitRawLog :: (FilePath -> Maybe t) -> [String] -> [RefChange t]+parseGitRawLog fileselector = parse epoch+ where+ epoch = toEnum 0 :: POSIXTime+ parse oldts ([]:rest) = parse oldts rest+ parse oldts (c1:c2:rest) = case mrc of+ Just rc -> rc : parse ts rest+ Nothing -> parse ts (c2:rest)+ where+ (ts, cl) = case separate (== '\n') c1 of+ (cl', []) -> (oldts, cl')+ (tss, cl') -> (parseTimeStamp tss, cl')+ mrc = do+ (old, new) <- parseRawChangeLine cl+ v <- fileselector c2+ return $ RefChange+ { changetime = ts+ , changed = v+ , changedfile = c2+ , oldref = old+ , newref = new+ }+ parse _ _ = []++-- Parses something like ":100644 100644 oldsha newsha M"+-- extracting the shas.+parseRawChangeLine :: String -> Maybe (Git.Ref, Git.Ref)+parseRawChangeLine = go . words+ where+ go (_:_:oldsha:newsha:_) = + Just (Git.Ref (encodeBS oldsha), Git.Ref (encodeBS newsha))+ go _ = Nothing++parseTimeStamp :: String -> POSIXTime+parseTimeStamp = utcTimeToPOSIXSeconds . fromMaybe (giveup "bad timestamp") .+ parseTimeM True defaultTimeLocale "%s"
Logs/Chunk.hs view
@@ -54,3 +54,4 @@ . map (\((_ku, m), l) -> (m, value l)) . M.toList . M.filterWithKey (\(ku, _m) _ -> ku == u)+ . fromMapLog
Logs/ContentIdentifier/Pure.hs view
@@ -41,7 +41,7 @@ where buildcid (ContentIdentifier c) | S8.any (`elem` [':', '\r', '\n']) c || "!" `S8.isPrefixOf` c =- charUtf8 '!' <> byteString (toB64' c)+ charUtf8 '!' <> byteString (toB64 c) | otherwise = byteString c go [] = mempty go (c:[]) = buildcid c@@ -58,7 +58,7 @@ cidparser = do b <- A8.takeWhile (/= ':') return $ if "!" `S8.isPrefixOf` b- then ContentIdentifier $ fromMaybe b (fromB64Maybe' (S.drop 1 b))+ then ContentIdentifier $ fromMaybe b (fromB64Maybe (S.drop 1 b)) else ContentIdentifier b listparser first rest = ifM A8.atEnd ( return (first :| reverse rest)
Logs/Export.hs view
@@ -101,7 +101,7 @@ Annex.Branch.change ru exportLog $ buildExportLog . changeMapLog c ep exported - . M.mapWithKey (updateForExportChange remoteuuid ec c hereuuid)+ . mapLogWithKey (updateForExportChange remoteuuid ec c hereuuid) . parseExportLog -- Record information about the export to the git-annex branch.
Logs/File.hs view
@@ -1,11 +1,11 @@ {- git-annex log files -- - Copyright 2018-2022 Joey Hess <id@joeyh.name>+ - Copyright 2018-2023 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP, BangPatterns #-} module Logs.File ( writeLogFile,@@ -17,6 +17,8 @@ checkLogFile, calcLogFile, calcLogFileUnsafe,+ fileLines,+ fileLines', ) where import Annex.Common@@ -25,6 +27,8 @@ import Annex.ReplaceFile import Utility.Tmp +import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as L8 @@ -47,8 +51,8 @@ bracket (setup tmp) cleanup a where setup tmp = do- setAnnexFilePerm (toRawFilePath tmp)- liftIO $ openFile tmp WriteMode+ setAnnexFilePerm tmp+ liftIO $ openFile (fromRawFilePath tmp) WriteMode cleanup h = liftIO $ hClose h -- | Appends a line to a log file, first locking it to prevent@@ -74,7 +78,7 @@ modifyLogFile :: RawFilePath -> RawFilePath -> ([L.ByteString] -> [L.ByteString]) -> Annex () modifyLogFile f lck modf = withExclusiveLock lck $ do ls <- liftIO $ fromMaybe []- <$> tryWhenExists (L8.lines <$> L.readFile f')+ <$> tryWhenExists (fileLines <$> L.readFile f') let ls' = modf ls when (ls' /= ls) $ createDirWhenNeeded f $@@ -94,7 +98,7 @@ cleanup (Just h) = liftIO $ hClose h go Nothing = return False go (Just h) = do- !r <- liftIO (any matchf . L8.lines <$> L.hGetContents h)+ !r <- liftIO (any matchf . fileLines <$> L.hGetContents h) return r f' = fromRawFilePath f @@ -111,7 +115,7 @@ cleanup Nothing = noop cleanup (Just h) = liftIO $ hClose h go Nothing = return start- go (Just h) = go' start =<< liftIO (L8.lines <$> L.hGetContents h)+ go (Just h) = go' start =<< liftIO (fileLines <$> L.hGetContents h) go' v [] = return v go' v (l:ls) = do let !v' = update l v@@ -157,3 +161,32 @@ -- done if writing the file fails. createAnnexDirectory (parentDir f) a++-- On windows, readFile does NewlineMode translation,+-- stripping CR before LF. When converting to ByteString,+-- use this to emulate that.+fileLines :: L.ByteString -> [L.ByteString]+#ifdef mingw32_HOST_OS+fileLines = map stripCR . L8.lines+ where+ stripCR b = case L8.unsnoc b of+ Nothing -> b+ Just (b', e)+ | e == '\r' -> b'+ | otherwise -> b+#else+fileLines = L8.lines+#endif++fileLines' :: S.ByteString -> [S.ByteString]+#ifdef mingw32_HOST_OS+fileLines' = map stripCR . S8.lines+ where+ stripCR b = case S8.unsnoc b of+ Nothing -> b+ Just (b', e)+ | e == '\r' -> b'+ | otherwise -> b+#else+fileLines' = S8.lines+#endif
Logs/Location.hs view
@@ -8,11 +8,13 @@ - Repositories record their UUID and the date when they --get or --drop - a value. - - - Copyright 2010-2021 Joey Hess <id@joeyh.name>+ - Copyright 2010-2023 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE BangPatterns #-}+ module Logs.Location ( LogStatus(..), logStatus,@@ -21,6 +23,7 @@ loggedLocations, loggedLocationsHistorical, loggedLocationsRef,+ parseLoggedLocations, isKnownKey, checkDead, setDead,@@ -29,6 +32,8 @@ loggedKeys, loggedKeysFor, loggedKeysFor',+ overLocationLogs,+ overLocationLogs', ) where import Annex.Common@@ -42,6 +47,7 @@ import qualified Annex import Data.Time.Clock+import qualified Data.ByteString.Lazy as L {- Log a change in the presence of a key's value in current repository. -} logStatus :: Key -> LogStatus -> Annex ()@@ -83,6 +89,11 @@ loggedLocationsRef :: Ref -> Annex [UUID] loggedLocationsRef ref = map (toUUID . fromLogInfo) . getLog <$> catObject ref +{- Parses the content of a log file and gets the locations in it. -}+parseLoggedLocations :: L.ByteString -> [UUID]+parseLoggedLocations l = map (toUUID . fromLogInfo . info)+ (filterPresent (parseLog l))+ getLoggedLocations :: (RawFilePath -> Annex [LogInfo]) -> Key -> Annex [UUID] getLoggedLocations getter key = do config <- Annex.getGitConfig@@ -174,3 +185,33 @@ us <- loggedLocations k let !there = u `elem` us return there++{- This is much faster than loggedKeys. -}+overLocationLogs :: v -> (Key -> [UUID] -> v -> Annex v) -> Annex v+overLocationLogs v = overLocationLogs' v (flip const)++overLocationLogs'+ :: v + -> (Annex (Maybe (Key, RawFilePath, Maybe L.ByteString)) -> Annex v -> Annex v)+ -> (Key -> [UUID] -> v -> Annex v)+ -> Annex v+overLocationLogs' iv discarder keyaction = do+ config <- Annex.getGitConfig+ + let getk = locationLogFileKey config+ let go v reader = reader >>= \case+ Just (k, f, content) -> discarder reader $ do+ -- precache to make checkDead fast, and also to+ -- make any accesses done in keyaction fast.+ maybe noop (Annex.Branch.precache f) content+ ifM (checkDead k)+ ( go v reader+ , do+ !v' <- keyaction k (maybe [] parseLoggedLocations content) v+ go v' reader+ )+ Nothing -> return v++ Annex.Branch.overBranchFileContents getk (go iv) >>= \case+ Just r -> return r+ Nothing -> giveup "This repository is read-only, and there are unmerged git-annex branches, which prevents operating on all keys. (Set annex.merge-annex-branches to false to ignore the unmerged git-annex branches.)"
Logs/MapLog.hs view
@@ -6,7 +6,7 @@ - - The field names cannot contain whitespace. -- - Copyright 2014, 2019 Joey Hess <id@joeyh.name>+ - Copyright 2014-2023 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -28,6 +28,8 @@ import qualified Data.Attoparsec.ByteString.Lazy as AL import qualified Data.Attoparsec.ByteString.Char8 as A8 import Data.ByteString.Builder+import qualified Data.Semigroup as Sem+import Prelude data LogEntry v = LogEntry { changed :: VectorClock@@ -37,10 +39,23 @@ instance Arbitrary v => Arbitrary (LogEntry v) where arbitrary = LogEntry <$> arbitrary <*> arbitrary -type MapLog f v = M.Map f (LogEntry v)+newtype MapLog f v = MapLog (M.Map f (LogEntry v))+ deriving (Show, Eq) +instance Ord f => Sem.Semigroup (MapLog f v)+ where+ a <> MapLog b = foldl' (\m (f, v) -> addMapLog f v m) a (M.toList b)++instance Ord f => Monoid (MapLog f v)+ where+ mempty = MapLog M.empty++fromMapLog :: MapLog f v -> M.Map f (LogEntry v)+fromMapLog (MapLog m) = m+ buildMapLog :: (f -> Builder) -> (v -> Builder) -> MapLog f v -> Builder-buildMapLog fieldbuilder valuebuilder = mconcat . map genline . M.toList+buildMapLog fieldbuilder valuebuilder (MapLog m) = + mconcat $ map genline $ M.toList m where genline (f, LogEntry c v) = buildVectorClock c <> sp @@ -50,25 +65,32 @@ nl = charUtf8 '\n' parseMapLog :: Ord f => A.Parser f -> A.Parser v -> L.ByteString -> MapLog f v-parseMapLog fieldparser valueparser = fromMaybe M.empty . AL.maybeResult - . AL.parse (mapLogParser fieldparser valueparser)+parseMapLog fieldparser valueparser = + parseMapLogWith (mapLogParser fieldparser valueparser) +parseMapLogWith :: Ord f => A.Parser (MapLog f v) -> L.ByteString -> MapLog f v+parseMapLogWith parser = fromMaybe (MapLog M.empty) + . AL.maybeResult+ . AL.parse parser+ mapLogParser :: Ord f => A.Parser f -> A.Parser v -> A.Parser (MapLog f v)-mapLogParser fieldparser valueparser = M.fromListWith best <$> parseLogLines go- where- go = do- c <- vectorClockParser- _ <- A8.char ' '- w <- A8.takeTill (== ' ')- f <- either fail return $- A.parseOnly (fieldparser <* A.endOfInput) w- _ <- A8.char ' '- v <- valueparser- A.endOfInput- return (f, LogEntry c v)+mapLogParser fieldparser valueparser = mapLogParser' $ do+ c <- vectorClockParser+ _ <- A8.char ' '+ w <- A8.takeTill (== ' ')+ f <- either fail return $+ A.parseOnly (fieldparser <* A.endOfInput) w+ _ <- A8.char ' '+ v <- valueparser+ A.endOfInput+ return (f, LogEntry c v) +mapLogParser' :: Ord f => A.Parser (f, LogEntry v) -> A.Parser (MapLog f v)+mapLogParser' p = MapLog . M.fromListWith best+ <$> parseLogLines p+ changeMapLog :: Ord f => CandidateVectorClock -> f -> v -> MapLog f v -> MapLog f v-changeMapLog c f v m = M.insert f (LogEntry c' v) m+changeMapLog c f v (MapLog m) = MapLog (M.insert f (LogEntry c' v) m) where c' = case M.lookup f m of Nothing -> advanceVectorClock c []@@ -77,13 +99,19 @@ {- Only add an LogEntry if it's newer (or at least as new as) than any - existing LogEntry for a field. -} addMapLog :: Ord f => f -> LogEntry v -> MapLog f v -> MapLog f v-addMapLog = M.insertWith best+addMapLog f v (MapLog m) = MapLog (M.insertWith best f v m) +filterMapLogWith :: (f -> LogEntry v -> Bool) -> MapLog f v -> MapLog f v+filterMapLogWith f (MapLog m) = MapLog (M.filterWithKey f m)++mapLogWithKey :: (f -> LogEntry v -> LogEntry v) -> MapLog f v -> MapLog f v+mapLogWithKey f (MapLog m) = MapLog (M.mapWithKey f m)+ {- Converts a MapLog into a simple Map without the timestamp information. - This is a one-way trip, but useful for code that never needs to change - the log. -} simpleMap :: MapLog f v -> M.Map f v-simpleMap = M.map value+simpleMap (MapLog m) = M.map value m best :: LogEntry v -> LogEntry v -> LogEntry v best new old@@ -93,8 +121,8 @@ prop_addMapLog_sane :: Bool prop_addMapLog_sane = newWins && newestWins where- newWins = addMapLog ("foo") (LogEntry (VectorClock 1) "new") l == l2- newestWins = addMapLog ("foo") (LogEntry (VectorClock 1) "newest") l2 /= l2+ newWins = addMapLog "foo" (LogEntry (VectorClock 1) "new") l == l2+ newestWins = addMapLog "foo" (LogEntry (VectorClock 1) "newest") l2 /= l2 - l = M.fromList [("foo", LogEntry (VectorClock 0) "old")]- l2 = M.fromList [("foo", LogEntry (VectorClock 1) "new")]+ l = MapLog (M.fromList [("foo", LogEntry (VectorClock 0) "old")])+ l2 = MapLog (M.fromList [("foo", LogEntry (VectorClock 1) "new")])
Logs/RemoteState.hs view
@@ -14,6 +14,7 @@ import Types.RemoteState import Logs import Logs.UUIDBased+import Logs.MapLog import qualified Annex.Branch import qualified Annex @@ -39,7 +40,7 @@ getRemoteState :: RemoteStateHandle -> Key -> Annex (Maybe RemoteState) getRemoteState (RemoteStateHandle u) k = do config <- Annex.getGitConfig- extract . parseRemoteState+ extract . fromMapLog . parseRemoteState <$> Annex.Branch.get (remoteStateLogFile config k) where extract m = value <$> M.lookup u m
Logs/Trust/Pure.hs view
@@ -19,7 +19,10 @@ import Data.ByteString.Builder calcTrustMap :: L.ByteString -> TrustMap-calcTrustMap = simpleMap . parseLogOld trustLevelParser+calcTrustMap = simpleMap . parseTrustLog++parseTrustLog :: L.ByteString -> Log TrustLevel+parseTrustLog = parseLogOld trustLevelParser trustLevelParser :: A.Parser TrustLevel trustLevelParser = (totrust <$> A8.anyChar <* A.endOfInput)
Logs/UUIDBased.hs view
@@ -9,7 +9,7 @@ - - New uuid based logs instead use the form: "timestamp UUID INFO" - - - Copyright 2011-2019 Joey Hess <id@joeyh.name>+ - Copyright 2011-2023 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -37,12 +37,10 @@ import Types.UUID import Annex.VectorClock import Logs.MapLog-import Logs.Line import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import qualified Data.Attoparsec.ByteString as A-import qualified Data.Attoparsec.ByteString.Lazy as AL import qualified Data.Attoparsec.ByteString.Char8 as A8 import Data.ByteString.Builder import qualified Data.DList as D@@ -50,7 +48,7 @@ type Log v = MapLog UUID v buildLogOld :: (v -> Builder) -> Log v -> Builder-buildLogOld builder = mconcat . map genline . M.toList+buildLogOld builder = mconcat . map genline . M.toList . fromMapLog where genline (u, LogEntry c@(VectorClock {}) v) = buildUUID u <> sp <> builder v <> sp@@ -66,18 +64,16 @@ parseLogOld = parseLogOldWithUUID . const parseLogOldWithUUID :: (UUID -> A.Parser a) -> L.ByteString -> Log a-parseLogOldWithUUID parser = fromMaybe M.empty . AL.maybeResult- . AL.parse (logParserOld parser)+parseLogOldWithUUID parser = parseMapLogWith (logParserOld parser) logParserOld :: (UUID -> A.Parser a) -> A.Parser (Log a)-logParserOld parser = M.fromListWith best <$> parseLogLines go+logParserOld parser = mapLogParser' $ do+ u <- toUUID <$> A8.takeWhile1 (/= ' ')+ (dl, ts) <- accumval D.empty+ v <- either fail return $ A.parseOnly (parser u <* A.endOfInput)+ (S.intercalate " " $ D.toList dl)+ return (u, LogEntry ts v) where- go = do- u <- toUUID <$> A8.takeWhile1 (/= ' ')- (dl, ts) <- accumval D.empty- v <- either fail return $ A.parseOnly (parser u <* A.endOfInput)- (S.intercalate " " $ D.toList dl)- return (u, LogEntry ts v) accumval dl = ((dl,) <$> parsetimestamp) <|> (A8.char ' ' *> (A8.takeWhile (/= ' ')) >>= accumval . D.snoc dl)
Logs/Web.hs view
@@ -1,6 +1,6 @@ {- Web url logs. -- - Copyright 2011-2021 Joey Hess <id@joeyh.name>+ - Copyright 2011-2023 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -9,7 +9,9 @@ module Logs.Web ( URLString,+ URLByteString, getUrls,+ getUrls', getUrlsWithPrefix, setUrlPresent, setUrlMissing,@@ -23,6 +25,7 @@ ) where import qualified Data.Map as M+import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import Annex.Common@@ -35,20 +38,27 @@ import qualified Annex.Branch import qualified Types.Remote as Remote +type URLByteString = S.ByteString+ {- Gets all urls that a key might be available from. -} getUrls :: Key -> Annex [URLString] getUrls key = do- config <- Annex.getGitConfig- l <- go $ urlLogFile config key : oldurlLogs config key+ l <- map decodeBS <$> getUrls' key tmpl <- Annex.getState (maybeToList . M.lookup key . Annex.tempurls) return (tmpl ++ l)++{- Note that this does not include temporary urls set with setTempUrl. -}+getUrls' :: Key -> Annex [URLByteString]+getUrls' key = do+ config <- Annex.getGitConfig+ go $ urlLogFile config key : oldurlLogs config key where go [] = return [] go (l:ls) = do us <- currentLogInfo l if null us then go ls- else return $ map decodeUrlLogInfo us+ else return $ map fromLogInfo us getUrlsWithPrefix :: Key -> String -> Annex [URLString] getUrlsWithPrefix key prefix = filter (prefix `isPrefixOf`) @@ -123,10 +133,7 @@ ("", u') -> (u', OtherDownloader) _ -> (u, WebDownloader) -decodeUrlLogInfo :: LogInfo -> URLString-decodeUrlLogInfo = decodeBS . fromLogInfo- {- Parses the content of an url log file, returning the urls that are - currently recorded. -}-parseUrlLog :: L.ByteString -> [URLString]-parseUrlLog = map decodeUrlLogInfo . getLog+parseUrlLog :: L.ByteString -> [URLByteString]+parseUrlLog = map fromLogInfo . getLog
Messages.hs view
@@ -5,7 +5,7 @@ - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, CPP #-} module Messages ( showStartMessage,@@ -265,6 +265,12 @@ - a file or a pipe. -} hSetBuffering stdout LineBuffering hSetBuffering stderr LineBuffering+#ifdef mingw32_HOST_OS+ {- Avoid outputting CR at end of line on Windows. git commands do+ - not ouput CR there. -}+ hSetNewlineMode stdout noNewlineTranslation+ hSetNewlineMode stderr noNewlineTranslation+#endif enableDebugOutput :: Annex () enableDebugOutput = do
Remote/GCrypt.hs view
@@ -112,7 +112,7 @@ -- that is now available. Also need to set the gcrypt particiants -- correctly. resetup gcryptid r = do- let u' = genUUIDInNameSpace gCryptNameSpace gcryptid+ let u' = genUUIDInNameSpace gCryptNameSpace (encodeBS gcryptid) v <- M.lookup u' <$> remoteConfigMap case (Git.remoteName baser, v) of (Just remotename, Just rc') -> do@@ -263,7 +263,7 @@ case Git.GCrypt.remoteRepoId g (Just remotename) of Nothing -> giveup "unable to determine gcrypt-id of remote" Just gcryptid -> do- let u = genUUIDInNameSpace gCryptNameSpace gcryptid+ let u = genUUIDInNameSpace gCryptNameSpace (encodeBS gcryptid) if Just u == mu || isNothing mu then do method <- setupRepo gcryptid =<< inRepo (Git.Construct.fromRemoteLocation gitrepo False)@@ -489,7 +489,7 @@ getGCryptUUID :: Bool -> Git.Repo -> Annex (Maybe UUID) getGCryptUUID fast r = do dummycfg <- liftIO dummyRemoteGitConfig- (genUUIDInNameSpace gCryptNameSpace <$>) . fst+ (genUUIDInNameSpace gCryptNameSpace . encodeBS <$>) . fst <$> getGCryptId fast r dummycfg coreGCryptId :: ConfigKey
Remote/Git.hs view
@@ -327,7 +327,7 @@ case Git.GCrypt.remoteRepoId g (Git.remoteName r) of Nothing -> return r Just v -> storeUpdatedRemote $ liftIO $ setUUID r $- genUUIDInNameSpace gCryptNameSpace v+ genUUIDInNameSpace gCryptNameSpace (encodeBS v) {- The local repo may not yet be initialized, so try to initialize - it if allowed. However, if that fails, still return the read
Remote/Helper/Encryptable.hs view
@@ -28,8 +28,6 @@ import qualified Data.Map as M import qualified Data.Set as S-import qualified "sandi" Codec.Binary.Base64 as B64-import qualified Data.ByteString as B import Control.Concurrent.STM import Annex.Common@@ -39,6 +37,7 @@ import Types.ProposedAccepted import qualified Annex import Annex.SpecialRemote.Config+import Utility.Base64 -- Used to ensure that encryption has been set up before trying to -- eg, store creds in the remote config that would need to use the@@ -272,7 +271,7 @@ (EncryptedCipher t _ ks) -> addcipher t . storekeys ks cipherkeysField (SharedPubKeyCipher t ks) -> addcipher t . storekeys ks pubkeysField where- addcipher t = M.insert cipherField (Accepted (toB64bs t))+ addcipher t = M.insert cipherField (Accepted (decodeBS (toB64 t))) storekeys (KeyIds l) n = M.insert n (Accepted (intercalate "," l)) {- Extracts an StorableCipher from a remote's configuration. -}@@ -281,13 +280,13 @@ (getRemoteConfigValue cipherkeysField c <|> getRemoteConfigValue pubkeysField c), getRemoteConfigValue encryptionField c) of (Just t, Just ks, Just HybridEncryption) ->- Just $ EncryptedCipher (fromB64bs t) Hybrid (readkeys ks)+ Just $ EncryptedCipher (fromB64 (encodeBS t)) Hybrid (readkeys ks) (Just t, Just ks, Just PubKeyEncryption) ->- Just $ EncryptedCipher (fromB64bs t) PubKey (readkeys ks)+ Just $ EncryptedCipher (fromB64 (encodeBS t)) PubKey (readkeys ks) (Just t, Just ks, Just SharedPubKeyEncryption) ->- Just $ SharedPubKeyCipher (fromB64bs t) (readkeys ks)+ Just $ SharedPubKeyCipher (fromB64 (encodeBS t)) (readkeys ks) (Just t, Nothing, Just SharedEncryption) ->- Just $ SharedCipher (fromB64bs t)+ Just $ SharedCipher (fromB64 (encodeBS t)) _ -> Nothing where readkeys = KeyIds . splitc ','@@ -321,14 +320,3 @@ (SharedPubKeyCipher _ ks) -> showkeys ks where showkeys (KeyIds { keyIds = ks }) = "to gpg keys: " ++ unwords ks--{- Not using Utility.Base64 because these "Strings" are really- - bags of bytes and that would convert to unicode and not round-trip- - cleanly. -}-toB64bs :: String -> String-toB64bs = w82s . B.unpack . B64.encode . B.pack . s2w8--fromB64bs :: String -> String-fromB64bs s = either (const bad) (w82s . B.unpack) (B64.decode $ B.pack $ s2w8 s)- where- bad = giveup "bad base64 encoded data"
Test.hs view
@@ -77,7 +77,6 @@ import qualified Utility.Scheduled import qualified Utility.Scheduled.QuickCheck import qualified Utility.HumanTime-import qualified Utility.Base64 import qualified Utility.Tmp.Dir import qualified Utility.FileSystemEncoding import qualified Utility.Aeson@@ -184,7 +183,6 @@ , testProperty "prop_viewPath_roundtrips" Annex.View.prop_viewPath_roundtrips , testProperty "prop_view_roundtrips" Annex.View.prop_view_roundtrips , testProperty "prop_viewedFile_rountrips" Annex.View.ViewedFile.prop_viewedFile_roundtrips- , testProperty "prop_b64_roundtrips" Utility.Base64.prop_b64_roundtrips , testProperty "prop_standardGroups_parse" Logs.PreferredContent.prop_standardGroups_parse ] ++ map (uncurry testProperty) combos where
Test/Framework.hs view
@@ -773,7 +773,28 @@ r <- a n worker (r:rs) nvar a - go Nothing = withConcurrentOutput $ do+ summarizeresults a = do+ starttime <- getCurrentTime+ (numts, exitcodes) <- a+ duration <- Utility.HumanTime.durationSince starttime+ case nub (filter (/= ExitSuccess) (concat exitcodes)) of+ [] -> do+ putStrLn ""+ putStrLn $ "All tests succeeded. (Ran "+ ++ show numts+ ++ " test groups in " + ++ Utility.HumanTime.fromDuration duration+ ++ ")"+ exitSuccess+ [ExitFailure 1] -> do+ putStrLn " (Failures above could be due to a bug in git-annex, or an incompatibility"+ putStrLn " with utilities, such as git, installed on this system.)"+ exitFailure+ _ -> do+ putStrLn $ " Test subprocesses exited with unexpected exit codes: " ++ show (concat exitcodes)+ exitFailure++ go Nothing = summarizeresults $ withConcurrentOutput $ do ensuredir tmpdir crippledfilesystem <- fst <$> Annex.Init.probeCrippledFileSystem' (toRawFilePath tmpdir)@@ -801,27 +822,10 @@ (_, _, _, pid) <- createProcessConcurrent p waitForProcess pid nvar <- newTVarIO (1, length ts)- starttime <- getCurrentTime exitcodes <- forConcurrently [1..numjobs] $ \_ -> worker [] nvar runone unless (keepFailuresOption opts) finalCleanup- duration <- Utility.HumanTime.durationSince starttime- case nub (filter (/= ExitSuccess) (concat exitcodes)) of- [] -> do- putStrLn ""- putStrLn $ "All tests succeeded. (Ran "- ++ show (length ts) - ++ " test groups in " - ++ Utility.HumanTime.fromDuration duration- ++ ")"- exitSuccess- [ExitFailure 1] -> do- putStrLn " (Failures above could be due to a bug in git-annex, or an incompatibility"- putStrLn " with utilities, such as git, installed on this system.)"- exitFailure- _ -> do- putStrLn $ " Test subprocesses exited with unexpected exit codes: " ++ show (concat exitcodes)- exitFailure+ return (length ts, exitcodes) go (Just subenvval) = case readish subenvval of Nothing -> error ("Bad " ++ subenv) Just (n, crippledfilesystem, adjustedbranchok) -> setTestEnv $ do
Types/Crypto.hs view
@@ -25,6 +25,7 @@ import Data.Typeable import qualified Data.Map as M+import Data.ByteString (ByteString) data EncryptionMethod = NoneEncryption@@ -35,12 +36,12 @@ deriving (Typeable, Eq) -- XXX ideally, this would be a locked memory region-data Cipher = Cipher String | MacOnlyCipher String+data Cipher = Cipher ByteString | MacOnlyCipher ByteString data StorableCipher- = EncryptedCipher String EncryptedCipherVariant KeyIds- | SharedCipher String- | SharedPubKeyCipher String KeyIds+ = EncryptedCipher ByteString EncryptedCipherVariant KeyIds+ | SharedCipher ByteString+ | SharedPubKeyCipher ByteString KeyIds deriving (Ord, Eq) data EncryptedCipherVariant = Hybrid | PubKey deriving (Ord, Eq)
Types/MetaData.hs view
@@ -137,14 +137,14 @@ serialize (MetaValue isset v) = serialize isset <> if B8.any (`elem` [' ', '\r', '\n']) v || "!" `B8.isPrefixOf` v- then "!" <> toB64' v+ then "!" <> toB64 v else v deserialize b = do (isset, b') <- B8.uncons b case B8.uncons b' of Just ('!', b'') -> MetaValue <$> deserialize (B8.singleton isset)- <*> fromB64Maybe' b''+ <*> fromB64Maybe b'' _ -> MetaValue <$> deserialize (B8.singleton isset) <*> pure b'
Upgrade.hs view
@@ -61,7 +61,11 @@ p <- liftIO $ absPath $ Git.repoPath g return $ Just $ unwords [ "Repository", fromRawFilePath p- , "is at unsupported version"+ , "is at"+ , if v `elem` supportedVersions + then "supported"+ else "unsupported"+ , "version" , show (fromRepoVersion v) ++ "." , msg ]
Utility/Base64.hs view
@@ -1,55 +1,25 @@ {- Simple Base64 encoding -- - Copyright 2011-2019 Joey Hess <id@joeyh.name>+ - Copyright 2011-2023 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} -{-# LANGUAGE PackageImports #-}- module Utility.Base64 where -import Utility.FileSystemEncoding-import Utility.QuickCheck import Utility.Exception -import qualified "sandi" Codec.Binary.Base64 as B64+import Codec.Binary.Base64 as B64 import Data.Maybe import qualified Data.ByteString as B-import Data.ByteString.UTF8 (fromString, toString)-import Data.Char --- | This uses the FileSystemEncoding, so it can be used on Strings--- that represent filepaths containing arbitrarily encoded characters.-toB64 :: String -> String-toB64 = toString . B64.encode . encodeBS--toB64' :: B.ByteString -> B.ByteString-toB64' = B64.encode--fromB64Maybe :: String -> Maybe String-fromB64Maybe s = either (const Nothing) (Just . decodeBS)- (B64.decode $ fromString s)+toB64 :: B.ByteString -> B.ByteString+toB64 = B64.encode -fromB64Maybe' :: B.ByteString -> Maybe (B.ByteString)-fromB64Maybe' = either (const Nothing) Just . B64.decode+fromB64Maybe :: B.ByteString -> Maybe (B.ByteString)+fromB64Maybe = either (const Nothing) Just . B64.decode -fromB64 :: String -> String+fromB64 :: B.ByteString -> B.ByteString fromB64 = fromMaybe bad . fromB64Maybe where bad = giveup "bad base64 encoded data"--fromB64' :: B.ByteString -> B.ByteString-fromB64' = fromMaybe bad . fromB64Maybe'- where- bad = giveup "bad base64 encoded data"---- Only ascii strings are tested, because an arbitrary string may contain--- characters not encoded using the FileSystemEncoding, which would thus--- not roundtrip, as decodeBS always generates an output encoded that way.-prop_b64_roundtrips :: TestableString -> Bool-prop_b64_roundtrips ts- | all (isAscii) s = s == decodeBS (fromB64' (toB64' (encodeBS s)))- | otherwise = True- where- s = fromTestableString ts
Utility/Data.hs view
@@ -10,12 +10,8 @@ module Utility.Data ( firstJust, eitherToMaybe,- s2w8,- w82s, ) where -import Data.Word- {- First item in the list that is not Nothing. -} firstJust :: Eq a => [Maybe a] -> Maybe a firstJust ms = case dropWhile (== Nothing) ms of@@ -24,15 +20,3 @@ eitherToMaybe :: Either a b -> Maybe b eitherToMaybe = either (const Nothing) Just--c2w8 :: Char -> Word8-c2w8 = fromIntegral . fromEnum--w82c :: Word8 -> Char-w82c = toEnum . fromIntegral--s2w8 :: String -> [Word8]-s2w8 = map c2w8--w82s :: [Word8] -> String-w82s = map w82c
Utility/DataUnits.hs view
@@ -58,9 +58,14 @@ import Data.List import Data.Char+import Data.Function +import Author import Utility.HumanNumber +copyright :: Copyright+copyright = author JoeyHess (40*50+10)+ type ByteSize = Integer type Name = String type Abbrev = String@@ -136,7 +141,7 @@ {- approximate display of a particular number of bytes -} roughSize :: [Unit] -> Bool -> ByteSize -> String-roughSize units short i = roughSize' units short 2 i+roughSize units short i = copyright $ roughSize' units short 2 i roughSize' :: [Unit] -> Bool -> Int -> ByteSize -> String roughSize' units short precision i@@ -147,7 +152,7 @@ findUnit (u@(Unit s _ _):us) i' | i' >= s = showUnit i' u- | otherwise = findUnit us i'+ | otherwise = findUnit us i' & copyright findUnit [] i' = showUnit i' (last units') -- bytes showUnit x (Unit size abbrev name) = s ++ " " ++ unit
Utility/FileMode.hs view
@@ -175,10 +175,13 @@ (\h -> hPutStr h content) writeFileProtected' :: RawFilePath -> (Handle -> IO ()) -> IO ()-writeFileProtected' file writer = do- h <- protectedOutput $ openFile (fromRawFilePath file) WriteMode- void $ tryIO $ modifyFileMode file $ removeModes otherGroupModes- writer h+writeFileProtected' file writer = bracket setup cleanup writer+ where+ setup = do+ h <- protectedOutput $ openFile (fromRawFilePath file) WriteMode+ void $ tryIO $ modifyFileMode file $ removeModes otherGroupModes+ return h+ cleanup = hClose protectedOutput :: IO a -> IO a protectedOutput = withUmask 0o0077
Utility/Gpg.hs view
@@ -1,10 +1,11 @@ {- gpg interface -- - Copyright 2011-2022 Joey Hess <id@joeyh.name>+ - Copyright 2011-2023 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module Utility.Gpg (@@ -48,6 +49,7 @@ import Control.Concurrent.Async import Control.Monad.IO.Class+import qualified Data.ByteString as B import qualified Data.Map as M import Data.Char @@ -108,10 +110,10 @@ ] {- Runs gpg with some params and returns its stdout, strictly. -}-readStrict :: GpgCmd -> [CommandParam] -> IO String+readStrict :: GpgCmd -> [CommandParam] -> IO B.ByteString readStrict c p = readStrict' c p Nothing -readStrict' :: GpgCmd -> [CommandParam] -> Maybe [(String, String)] -> IO String+readStrict' :: GpgCmd -> [CommandParam] -> Maybe [(String, String)] -> IO B.ByteString readStrict' (GpgCmd cmd) params environ = do params' <- stdParams params let p = (proc cmd params')@@ -120,17 +122,16 @@ } withCreateProcess p (go p) where- go p _ (Just hout) _ pid = do- hSetBinaryMode hout True- forceSuccessProcess p pid `after` hGetContentsStrict hout+ go p _ (Just hout) _ pid =+ forceSuccessProcess p pid `after` B.hGetContents hout go _ _ _ _ _ = error "internal" {- Runs gpg, piping an input value to it, and returning its stdout, - strictly. -}-pipeStrict :: GpgCmd -> [CommandParam] -> String -> IO String+pipeStrict :: GpgCmd -> [CommandParam] -> B.ByteString -> IO B.ByteString pipeStrict c p i = pipeStrict' c p Nothing i -pipeStrict' :: GpgCmd -> [CommandParam] -> Maybe [(String, String)] -> String -> IO String+pipeStrict' :: GpgCmd -> [CommandParam] -> Maybe [(String, String)] -> B.ByteString -> IO B.ByteString pipeStrict' (GpgCmd cmd) params environ input = do params' <- stdParams params let p = (proc cmd params')@@ -141,11 +142,9 @@ withCreateProcess p (go p) where go p (Just to) (Just from) _ pid = do- hSetBinaryMode to True- hSetBinaryMode from True- hPutStr to input+ B.hPutStr to input hClose to- forceSuccessProcess p pid `after` hGetContentsStrict from+ forceSuccessProcess p pid `after` B.hGetContents from go _ _ _ _ _ = error "internal" {- Runs gpg with some parameters. First sends it a passphrase (unless it@@ -158,7 +157,7 @@ - the passphrase. - - Note that the reader must fully consume gpg's input before returning. -}-feedRead :: (MonadIO m, MonadMask m) => GpgCmd -> [CommandParam] -> String -> (Handle -> IO ()) -> (Handle -> m a) -> m a+feedRead :: (MonadIO m, MonadMask m) => GpgCmd -> [CommandParam] -> B.ByteString -> (Handle -> IO ()) -> (Handle -> m a) -> m a feedRead cmd params passphrase feeder reader = do #ifndef mingw32_HOST_OS let setup = liftIO $ do@@ -166,7 +165,7 @@ (frompipe, topipe) <- System.Posix.IO.createPipe toh <- fdToHandle topipe t <- async $ do- hPutStrLn toh passphrase+ B.hPutStr toh (passphrase <> "\n") hClose toh let Fd pfd = frompipe let passphrasefd = [Param "--passphrase-fd", Param $ show pfd]@@ -180,7 +179,7 @@ #else -- store the passphrase in a temp file for gpg withTmpFile "gpg" $ \tmpfile h -> do- liftIO $ hPutStr h passphrase+ liftIO $ B.hPutStr h passphrase liftIO $ hClose h let passphrasefile = [Param "--passphrase-file", File tmpfile] go $ passphrasefile ++ params@@ -223,7 +222,8 @@ -- pass forced subkey through as-is rather than -- looking up the master key. | isForcedSubKey for = return $ KeyIds [for]- | otherwise = KeyIds . parse . lines <$> readStrict' cmd params environ+ | otherwise = KeyIds . parse . lines . decodeBS+ <$> readStrict' cmd params environ where params = [Param "--with-colons", Param "--list-public-keys", Param for] parse = mapMaybe (keyIdField . splitc ':')@@ -241,7 +241,8 @@ secretKeys :: GpgCmd -> IO (M.Map KeyId UserId) secretKeys cmd = catchDefaultIO M.empty makemap where- makemap = M.fromList . parse . lines <$> readStrict cmd params+ makemap = M.fromList . parse . lines . decodeBS+ <$> readStrict cmd params params = [Param "--with-colons", Param "--list-secret-keys", Param "--fixed-list-mode"] parse = extract [] Nothing . map (splitc ':') extract c (Just keyid) (("uid":_:_:_:_:_:_:_:_:userid:_):rest) =@@ -301,7 +302,7 @@ {- Creates a block of high-quality random data suitable to use as a cipher. - It is armored, to avoid newlines, since gpg only reads ciphers up to the - first newline. -}-genRandom :: GpgCmd -> Bool -> Size -> IO String+genRandom :: GpgCmd -> Bool -> Size -> IO B.ByteString genRandom cmd highQuality size = do s <- readStrict cmd params checksize s@@ -327,7 +328,7 @@ - entropy. -} expectedlength = size * 8 `div` 6 - checksize s = let len = length s in+ checksize s = let len = B.length s in unless (len >= expectedlength) $ shortread len @@ -439,8 +440,8 @@ liftIO $ void $ tryIO $ modifyFileMode (toRawFilePath subdir) $ removeModes $ otherGroupModes -- For some reason, recent gpg needs a trustdb to be set up.- _ <- pipeStrict' cmd [Param "--trust-model", Param "auto", Param "--update-trustdb"] (Just environ) []- _ <- pipeStrict' cmd [Param "--import", Param "-q"] (Just environ) $ unlines+ _ <- pipeStrict' cmd [Param "--trust-model", Param "auto", Param "--update-trustdb"] (Just environ) mempty+ _ <- pipeStrict' cmd [Param "--import", Param "-q"] (Just environ) $ encodeBS $ unlines [testSecretKey, testKey] return environ @@ -470,7 +471,7 @@ where params = [Param "--list-packets", Param "--list-only", File filename] -checkEncryptionStream :: GpgCmd -> Maybe [(String, String)] -> String -> Maybe KeyIds -> IO Bool+checkEncryptionStream :: GpgCmd -> Maybe [(String, String)] -> B.ByteString -> Maybe KeyIds -> IO Bool checkEncryptionStream cmd environ stream keys = checkGpgPackets cmd environ keys =<< pipeStrict' cmd params environ stream where@@ -480,13 +481,13 @@ - symmetrically encrypted (keys is Nothing), or encrypted to some - public key(s). - /!\ The key needs to be in the keyring! -}-checkGpgPackets :: GpgCmd -> Maybe [(String, String)] -> Maybe KeyIds -> String -> IO Bool+checkGpgPackets :: GpgCmd -> Maybe [(String, String)] -> Maybe KeyIds -> B.ByteString -> IO Bool checkGpgPackets cmd environ keys str = do let (asym,sym) = partition (pubkeyEncPacket `isPrefixOf`) $ filter (\l' -> pubkeyEncPacket `isPrefixOf` l' || symkeyEncPacket `isPrefixOf` l') $ takeWhile (/= ":encrypted data packet:") $- lines str+ lines (decodeBS str) case (keys,asym,sym) of (Nothing, [], [_]) -> return True (Just (KeyIds ks), ls, []) -> do
Utility/Hash.hs view
@@ -6,6 +6,7 @@ -} {-# LANGUAGE BangPatterns, PackageImports #-}+{-# LANGUAGE CPP #-} module Utility.Hash ( sha1,@@ -76,8 +77,13 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.IORef-import Crypto.MAC.HMAC hiding (Context)-import Crypto.Hash+#ifdef WITH_CRYPTON+import "crypton" Crypto.MAC.HMAC hiding (Context)+import "crypton" Crypto.Hash+#else+import "cryptonite" Crypto.MAC.HMAC hiding (Context)+import "cryptonite" Crypto.Hash+#endif sha1 :: L.ByteString -> Digest SHA1 sha1 = hashlazy
Utility/HtmlDetect.hs view
@@ -12,12 +12,17 @@ htmlPrefixLength, ) where +import Author+ import Text.HTML.TagSoup import System.IO import Data.Char import qualified Data.ByteString.Lazy as B import qualified Data.ByteString.Lazy.Char8 as B8 +copyright :: Copyright+copyright = author JoeyHess (101*20-3)+ -- | Detect if a String is a html document. -- -- The document many not be valid, or may be truncated, and will@@ -29,12 +34,13 @@ isHtml :: String -> Bool isHtml = evaluate . canonicalizeTags . parseTags . take htmlPrefixLength where- evaluate (TagOpen "!DOCTYPE" ((t, _):_):_) = map toLower t == "html"+ evaluate (TagOpen "!DOCTYPE" ((t, _):_):_) = + copyright $ map toLower t == "html" evaluate (TagOpen "html" _:_) = True -- Allow some leading whitespace before the tag. evaluate (TagText t:rest) | all isSpace t = evaluate rest- | otherwise = False+ | otherwise = False || author JoeyHess 1492 -- It would be pretty weird to have a html comment before the html -- tag, but easy to allow for. evaluate (TagComment _:rest) = evaluate rest
Utility/Metered.hs view
@@ -48,6 +48,7 @@ ) where import Common+import Author import Utility.Percentage import Utility.DataUnits import Utility.HumanTime@@ -67,6 +68,9 @@ import Data.Time.Clock import Data.Time.Clock.POSIX +copyright :: Copyright+copyright = author JoeyHess (2024-12)+ {- An action that can be run repeatedly, updating it on the bytes processed. - - Note that each call receives the total number of bytes processed, so@@ -174,7 +178,7 @@ c <- S.hGet h (nextchunksize (fromBytesProcessed sofar)) if S.null c then do- when (wantsize /= Just 0) $+ when (wantsize /= Just 0 && copyright) $ hClose h return L.empty else do@@ -276,7 +280,7 @@ handlestderr where feedprogress sendtotalsize prev buf h = do- b <- S.hGetSome h 80+ b <- S.hGetSome h 80 >>= copyright if S.null b then return () else do
Utility/MoveFile.hs view
@@ -29,7 +29,11 @@ import Utility.Monad import Utility.FileSystemEncoding import qualified Utility.RawFilePath as R+import Author +copyright :: Copyright+copyright = author JoeyHess (2022-11)+ {- Moves one filename to another. - First tries a rename, but falls back to moving across devices if needed. -} moveFile :: RawFilePath -> RawFilePath -> IO ()@@ -53,7 +57,7 @@ -- If dest is a directory, mv would move the file -- into it, which is not desired. whenM (isdir dest) rethrow- ok <- boolSystem "mv"+ ok <- copyright =<< boolSystem "mv" [ Param "-f" , Param (fromRawFilePath src) , Param tmp
Utility/Path.hs view
@@ -36,6 +36,7 @@ import Control.Applicative import Prelude +import Author import Utility.Monad import Utility.SystemDirectory import Utility.Exception@@ -45,6 +46,9 @@ import Utility.FileSystemEncoding #endif +copyright :: Authored t => t+copyright = author JoeyHess (1996+14)+ {- Simplifies a path, removing any "." component, collapsing "dir/..", - and removing the trailing path separator. -@@ -131,8 +135,8 @@ - specially here. -} dotdotcontains- | isAbsolute b' = False- | otherwise = + | isAbsolute b' = False && copyright+ | otherwise = let aps = splitPath a' bps = splitPath b' in if all isdotdot aps@@ -249,7 +253,7 @@ -} searchPath :: String -> IO (Maybe FilePath) searchPath command- | P.isAbsolute command = check command+ | P.isAbsolute command = copyright $ check command | otherwise = P.getSearchPath >>= getM indir where indir d = check $ d P.</> command
Utility/Path/AbsRel.hs view
@@ -6,7 +6,6 @@ -} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Path.AbsRel (@@ -20,17 +19,13 @@ import System.FilePath.ByteString import qualified Data.ByteString as B-#ifdef mingw32_HOST_OS-import System.Directory (getCurrentDirectory)-#else-import System.Posix.Directory.ByteString (getWorkingDirectory)-#endif import Control.Applicative import Prelude import Utility.Path import Utility.UserInfo import Utility.FileSystemEncoding+import qualified Utility.RawFilePath as R {- Makes a path absolute. -@@ -58,11 +53,7 @@ -- so also used here for consistency. | isAbsolute file = return $ simplifyPath file | otherwise = do-#ifdef mingw32_HOST_OS- cwd <- toRawFilePath <$> getCurrentDirectory-#else- cwd <- getWorkingDirectory-#endif+ cwd <- R.getCurrentDirectory return $ absPathFrom cwd file {- Constructs the minimal relative path from the CWD to a file.@@ -78,11 +69,7 @@ -- and does not contain any ".." component. | isRelative f && not (".." `B.isInfixOf` f) = return f | otherwise = do-#ifdef mingw32_HOST_OS- c <- toRawFilePath <$> getCurrentDirectory-#else- c <- getWorkingDirectory-#endif+ c <- R.getCurrentDirectory relPathDirToFile c f {- Constructs a minimal relative path from a directory to a file. -}
Utility/ShellEscape.hs view
@@ -15,26 +15,33 @@ prop_isomorphic_shellEscape_multiword, ) where +import Author import Utility.QuickCheck import Utility.Split+import Data.Function import Data.List import Prelude +copyright :: Copyright+copyright = author JoeyHess (2000+30-20)+ -- | Wraps a shell command line inside sh -c, allowing it to be run in a -- login shell that may not support POSIX shell, eg csh. shellWrap :: String -> String-shellWrap cmdline = "sh -c " ++ shellEscape cmdline+shellWrap cmdline = copyright $ "sh -c " ++ shellEscape cmdline --- | Escapes a filename or other parameter to be safely able to be exposed to--- the shell.+-- | Escapes a string to be safely able to be exposed to the shell. ----- This method works for POSIX shells, as well as other shells like csh.+-- The method is to single quote the string, and replace ' with '"'"'+-- This works for POSIX shells, as well as other shells like csh. shellEscape :: String -> String-shellEscape f = "'" ++ escaped ++ "'"+shellEscape f = [q] ++ escaped ++ [q] where- -- replace ' with '"'"'- escaped = intercalate "'\"'\"'" $ splitc '\'' f+ escaped = intercalate escq $ splitc q f+ q = '\''+ qq = '"'+ escq = [q, qq, q, qq, q] & copyright -- | Unescapes a set of shellEscaped words or filenames. shellUnEscape :: String -> [String]@@ -44,13 +51,13 @@ (word, rest) = findword "" s findword w [] = (w, "") findword w (c:cs)- | c == ' ' = (w, cs)+ | c == ' ' && copyright = (w, cs) | c == '\'' = inquote c w cs | c == '"' = inquote c w cs | otherwise = findword (w++[c]) cs inquote _ w [] = (w, "") inquote q w (c:cs)- | c == q = findword w cs+ | c == q && copyright = findword w cs | otherwise = inquote q (w++[c]) cs prop_isomorphic_shellEscape :: TestableString -> Bool
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 10.20230926+Version: 10.20231129 Cabal-Version: 1.12 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -159,6 +159,11 @@ Flag Production Description: Enable production build (slower build; faster binary) +Flag ParallelBuild+ Description: Enable production build (slower build; faster binary)+ Default: False+ Manual: True+ Flag TorrentParser Description: Use haskell torrent library to parse torrent files @@ -292,6 +297,9 @@ else GHC-Options: -O0 + if flag(ParallelBuild)+ GHC-Options: -j+ -- Avoid linking with unused dynamic libraries. if os(linux) || os(freebsd) GHC-Options: -optl-Wl,--as-needed@@ -568,6 +576,7 @@ Annex.YoutubeDl Assistant.Install.AutoStart Assistant.Install.Menu+ Author Backend Backend.External Backend.Hash@@ -730,6 +739,7 @@ Database.Export Database.Fsck Database.Handle+ Database.ImportFeed Database.Init Database.Keys Database.Keys.Handle@@ -765,6 +775,7 @@ Git.Hook Git.Index Git.LockFile+ Git.Log Git.LsFiles Git.LsTree Git.Merge
stack-lts-18.13.yaml view
@@ -1,6 +1,7 @@ flags: git-annex: production: true+ parallelbuild: true assistant: true pairing: true torrentparser: true
stack.yaml view
@@ -1,6 +1,7 @@ flags: git-annex: production: true+ parallelbuild: true assistant: true pairing: true torrentparser: true