diff --git a/Annex/AutoMerge.hs b/Annex/AutoMerge.hs --- a/Annex/AutoMerge.hs +++ b/Annex/AutoMerge.hs @@ -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. diff --git a/Annex/Branch.hs b/Annex/Branch.hs --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -1,6 +1,6 @@ {- management of the git-annex branch - - - Copyright 2011-2022 Joey Hess + - Copyright 2011-2023 Joey Hess - - 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 diff --git a/Annex/Branch/Transitions.hs b/Annex/Branch/Transitions.hs --- a/Annex/Branch/Transitions.hs +++ b/Annex/Branch/Transitions.hs @@ -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 $ diff --git a/Annex/Content.hs b/Annex/Content.hs --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -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 diff --git a/Annex/Content/PointerFile.hs b/Annex/Content/PointerFile.hs --- a/Annex/Content/PointerFile.hs +++ b/Annex/Content/PointerFile.hs @@ -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 diff --git a/Annex/Ingest.hs b/Annex/Ingest.hs --- a/Annex/Ingest.hs +++ b/Annex/Ingest.hs @@ -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 diff --git a/Annex/Locations.hs b/Annex/Locations.hs --- a/Annex/Locations.hs +++ b/Annex/Locations.hs @@ -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. -} diff --git a/Annex/MetaData/StandardFields.hs b/Annex/MetaData/StandardFields.hs --- a/Annex/MetaData/StandardFields.hs +++ b/Annex/MetaData/StandardFields.hs @@ -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" diff --git a/Annex/ReplaceFile.hs b/Annex/ReplaceFile.hs --- a/Annex/ReplaceFile.hs +++ b/Annex/ReplaceFile.hs @@ -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 () diff --git a/Annex/TaggedPush.hs b/Annex/TaggedPush.hs --- a/Annex/TaggedPush.hs +++ b/Annex/TaggedPush.hs @@ -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 diff --git a/Annex/UUID.hs b/Annex/UUID.hs --- a/Annex/UUID.hs +++ b/Annex/UUID.hs @@ -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 diff --git a/Assistant/MakeRepo.hs b/Assistant/MakeRepo.hs --- a/Assistant/MakeRepo.hs +++ b/Assistant/MakeRepo.hs @@ -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)) diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs --- a/Assistant/Threads/Watcher.hs +++ b/Assistant/Threads/Watcher.hs @@ -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 diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs --- a/Assistant/WebApp/Configurators/Ssh.hs +++ b/Assistant/WebApp/Configurators/Ssh.hs @@ -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" diff --git a/Author.hs b/Author.hs new file mode 100644 --- /dev/null +++ b/Author.hs @@ -0,0 +1,35 @@ +{- authorship made explicit in the code + - + - Copyright 2023 Joey Hess + - + - 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 #-} diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -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 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 diff --git a/CmdLine/Batch.hs b/CmdLine/Batch.hs --- a/CmdLine/Batch.hs +++ b/CmdLine/Batch.hs @@ -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 diff --git a/CmdLine/GitAnnex/Options.hs b/CmdLine/GitAnnex/Options.hs --- a/CmdLine/GitAnnex/Options.hs +++ b/CmdLine/GitAnnex/Options.hs @@ -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 diff --git a/CmdLine/Seek.hs b/CmdLine/Seek.hs --- a/CmdLine/Seek.hs +++ b/CmdLine/Seek.hs @@ -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 diff --git a/Command/Copy.hs b/Command/Copy.hs --- a/Command/Copy.hs +++ b/Command/Copy.hs @@ -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 diff --git a/Command/Expire.hs b/Command/Expire.hs --- a/Command/Expire.hs +++ b/Command/Expire.hs @@ -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 diff --git a/Command/Fix.hs b/Command/Fix.hs --- a/Command/Fix.hs +++ b/Command/Fix.hs @@ -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 diff --git a/Command/Fsck.hs b/Command/Fsck.hs --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -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 diff --git a/Command/GCryptSetup.hs b/Command/GCryptSetup.hs --- a/Command/GCryptSetup.hs +++ b/Command/GCryptSetup.hs @@ -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 diff --git a/Command/ImportFeed.hs b/Command/ImportFeed.hs --- a/Command/ImportFeed.hs +++ b/Command/ImportFeed.hs @@ -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) diff --git a/Command/Info.hs b/Command/Info.hs --- a/Command/Info.hs +++ b/Command/Info.hs @@ -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' diff --git a/Command/Lock.hs b/Command/Lock.hs --- a/Command/Lock.hs +++ b/Command/Lock.hs @@ -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] diff --git a/Command/Log.hs b/Command/Log.hs --- a/Command/Log.hs +++ b/Command/Log.hs @@ -1,11 +1,11 @@ {- git-annex command - - - Copyright 2012-2021 Joey Hess + - Copyright 2012-2023 Joey Hess - - 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) diff --git a/Command/LookupKey.hs b/Command/LookupKey.hs --- a/Command/LookupKey.hs +++ b/Command/LookupKey.hs @@ -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 diff --git a/Command/Move.hs b/Command/Move.hs --- a/Command/Move.hs +++ b/Command/Move.hs @@ -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. - diff --git a/Command/ReKey.hs b/Command/ReKey.hs --- a/Command/ReKey.hs +++ b/Command/ReKey.hs @@ -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 diff --git a/Command/Unlock.hs b/Command/Unlock.hs --- a/Command/Unlock.hs +++ b/Command/Unlock.hs @@ -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 diff --git a/Creds.hs b/Creds.hs --- a/Creds.hs +++ b/Creds.hs @@ -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 diff --git a/Crypto.hs b/Crypto.hs --- a/Crypto.hs +++ b/Crypto.hs @@ -3,7 +3,7 @@ - Currently using gpg; could later be modified to support different - crypto backends if necessary. - - - Copyright 2011-2022 Joey Hess + - Copyright 2011-2023 Joey Hess - - 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 diff --git a/Database/ContentIdentifier.hs b/Database/ContentIdentifier.hs --- a/Database/ContentIdentifier.hs +++ b/Database/ContentIdentifier.hs @@ -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 diff --git a/Database/Export.hs b/Database/Export.hs --- a/Database/Export.hs +++ b/Database/Export.hs @@ -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. diff --git a/Database/ImportFeed.hs b/Database/ImportFeed.hs new file mode 100644 --- /dev/null +++ b/Database/ImportFeed.hs @@ -0,0 +1,211 @@ +{- Sqlite database of known urls, and another of known itemids, + - for use by git-annex importfeed. + - + - Copyright 2023 Joey Hess + -: + - 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 () diff --git a/Database/Keys/SQL.hs b/Database/Keys/SQL.hs --- a/Database/Keys/SQL.hs +++ b/Database/Keys/SQL.hs @@ -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 $ diff --git a/Database/Types.hs b/Database/Types.hs --- a/Database/Types.hs +++ b/Database/Types.hs @@ -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 diff --git a/Git/Construct.hs b/Git/Construct.hs --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -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") diff --git a/Git/Hook.hs b/Git/Hook.hs --- a/Git/Hook.hs +++ b/Git/Hook.hs @@ -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 diff --git a/Git/Log.hs b/Git/Log.hs new file mode 100644 --- /dev/null +++ b/Git/Log.hs @@ -0,0 +1,107 @@ +{- git log + - + - Copyright 2023 Joey Hess + - + - 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" diff --git a/Logs/Chunk.hs b/Logs/Chunk.hs --- a/Logs/Chunk.hs +++ b/Logs/Chunk.hs @@ -54,3 +54,4 @@ . map (\((_ku, m), l) -> (m, value l)) . M.toList . M.filterWithKey (\(ku, _m) _ -> ku == u) + . fromMapLog diff --git a/Logs/ContentIdentifier/Pure.hs b/Logs/ContentIdentifier/Pure.hs --- a/Logs/ContentIdentifier/Pure.hs +++ b/Logs/ContentIdentifier/Pure.hs @@ -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) diff --git a/Logs/Export.hs b/Logs/Export.hs --- a/Logs/Export.hs +++ b/Logs/Export.hs @@ -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. diff --git a/Logs/File.hs b/Logs/File.hs --- a/Logs/File.hs +++ b/Logs/File.hs @@ -1,11 +1,11 @@ {- git-annex log files - - - Copyright 2018-2022 Joey Hess + - Copyright 2018-2023 Joey Hess - - 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 diff --git a/Logs/Location.hs b/Logs/Location.hs --- a/Logs/Location.hs +++ b/Logs/Location.hs @@ -8,11 +8,13 @@ - Repositories record their UUID and the date when they --get or --drop - a value. - - - Copyright 2010-2021 Joey Hess + - Copyright 2010-2023 Joey Hess - - 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.)" diff --git a/Logs/MapLog.hs b/Logs/MapLog.hs --- a/Logs/MapLog.hs +++ b/Logs/MapLog.hs @@ -6,7 +6,7 @@ - - The field names cannot contain whitespace. - - - Copyright 2014, 2019 Joey Hess + - Copyright 2014-2023 Joey Hess - - 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")]) diff --git a/Logs/RemoteState.hs b/Logs/RemoteState.hs --- a/Logs/RemoteState.hs +++ b/Logs/RemoteState.hs @@ -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 diff --git a/Logs/Trust/Pure.hs b/Logs/Trust/Pure.hs --- a/Logs/Trust/Pure.hs +++ b/Logs/Trust/Pure.hs @@ -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) diff --git a/Logs/UUIDBased.hs b/Logs/UUIDBased.hs --- a/Logs/UUIDBased.hs +++ b/Logs/UUIDBased.hs @@ -9,7 +9,7 @@ - - New uuid based logs instead use the form: "timestamp UUID INFO" - - - Copyright 2011-2019 Joey Hess + - Copyright 2011-2023 Joey Hess - - 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) diff --git a/Logs/Web.hs b/Logs/Web.hs --- a/Logs/Web.hs +++ b/Logs/Web.hs @@ -1,6 +1,6 @@ {- Web url logs. - - - Copyright 2011-2021 Joey Hess + - Copyright 2011-2023 Joey Hess - - 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 diff --git a/Messages.hs b/Messages.hs --- a/Messages.hs +++ b/Messages.hs @@ -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 diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -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 diff --git a/Remote/Git.hs b/Remote/Git.hs --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -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 diff --git a/Remote/Helper/Encryptable.hs b/Remote/Helper/Encryptable.hs --- a/Remote/Helper/Encryptable.hs +++ b/Remote/Helper/Encryptable.hs @@ -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" diff --git a/Test.hs b/Test.hs --- a/Test.hs +++ b/Test.hs @@ -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 diff --git a/Test/Framework.hs b/Test/Framework.hs --- a/Test/Framework.hs +++ b/Test/Framework.hs @@ -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 diff --git a/Types/Crypto.hs b/Types/Crypto.hs --- a/Types/Crypto.hs +++ b/Types/Crypto.hs @@ -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) diff --git a/Types/MetaData.hs b/Types/MetaData.hs --- a/Types/MetaData.hs +++ b/Types/MetaData.hs @@ -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' diff --git a/Upgrade.hs b/Upgrade.hs --- a/Upgrade.hs +++ b/Upgrade.hs @@ -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 ] diff --git a/Utility/Base64.hs b/Utility/Base64.hs --- a/Utility/Base64.hs +++ b/Utility/Base64.hs @@ -1,55 +1,25 @@ {- Simple Base64 encoding - - - Copyright 2011-2019 Joey Hess + - Copyright 2011-2023 Joey Hess - - 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 diff --git a/Utility/Data.hs b/Utility/Data.hs --- a/Utility/Data.hs +++ b/Utility/Data.hs @@ -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 diff --git a/Utility/DataUnits.hs b/Utility/DataUnits.hs --- a/Utility/DataUnits.hs +++ b/Utility/DataUnits.hs @@ -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 diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs --- a/Utility/FileMode.hs +++ b/Utility/FileMode.hs @@ -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 diff --git a/Utility/Gpg.hs b/Utility/Gpg.hs --- a/Utility/Gpg.hs +++ b/Utility/Gpg.hs @@ -1,10 +1,11 @@ {- gpg interface - - - Copyright 2011-2022 Joey Hess + - Copyright 2011-2023 Joey Hess - - 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 diff --git a/Utility/Hash.hs b/Utility/Hash.hs --- a/Utility/Hash.hs +++ b/Utility/Hash.hs @@ -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 diff --git a/Utility/HtmlDetect.hs b/Utility/HtmlDetect.hs --- a/Utility/HtmlDetect.hs +++ b/Utility/HtmlDetect.hs @@ -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 diff --git a/Utility/Metered.hs b/Utility/Metered.hs --- a/Utility/Metered.hs +++ b/Utility/Metered.hs @@ -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 diff --git a/Utility/MoveFile.hs b/Utility/MoveFile.hs --- a/Utility/MoveFile.hs +++ b/Utility/MoveFile.hs @@ -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 diff --git a/Utility/Path.hs b/Utility/Path.hs --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -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 diff --git a/Utility/Path/AbsRel.hs b/Utility/Path/AbsRel.hs --- a/Utility/Path/AbsRel.hs +++ b/Utility/Path/AbsRel.hs @@ -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. -} diff --git a/Utility/ShellEscape.hs b/Utility/ShellEscape.hs --- a/Utility/ShellEscape.hs +++ b/Utility/ShellEscape.hs @@ -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 diff --git a/git-annex.cabal b/git-annex.cabal --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1,5 +1,5 @@ Name: git-annex -Version: 10.20230926 +Version: 10.20231129 Cabal-Version: 1.12 License: AGPL-3 Maintainer: Joey Hess @@ -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 diff --git a/stack-lts-18.13.yaml b/stack-lts-18.13.yaml --- a/stack-lts-18.13.yaml +++ b/stack-lts-18.13.yaml @@ -1,6 +1,7 @@ flags: git-annex: production: true + parallelbuild: true assistant: true pairing: true torrentparser: true diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,6 +1,7 @@ flags: git-annex: production: true + parallelbuild: true assistant: true pairing: true torrentparser: true