packages feed

git-annex 7.20181211 → 7.20190122

raw patch · 201 files changed

+2113/−1792 lines, 201 files

Files

Annex.hs view
@@ -74,6 +74,7 @@ import Control.Concurrent import Control.Concurrent.Async import Control.Concurrent.STM+import qualified Control.Monad.Fail as Fail import qualified Control.Concurrent.SSem as SSem import qualified Data.Map.Strict as M import qualified Data.Set as S@@ -93,6 +94,7 @@ 		MonadCatch, 		MonadThrow, 		MonadMask,+		Fail.MonadFail, 		Functor, 		Applicative 	)@@ -122,7 +124,7 @@ 	, globalnumcopies :: Maybe NumCopies 	, forcenumcopies :: Maybe NumCopies 	, limit :: ExpandableMatcher Annex-	, uuidmap :: Maybe UUIDMap+	, uuiddescmap :: Maybe UUIDDescMap 	, preferredcontentmap :: Maybe (FileMatcherMap Annex) 	, requiredcontentmap :: Maybe (FileMatcherMap Annex) 	, forcetrust :: TrustMap@@ -181,7 +183,7 @@ 		, globalnumcopies = Nothing 		, forcenumcopies = Nothing 		, limit = BuildingMatcher []-		, uuidmap = Nothing+		, uuiddescmap = Nothing 		, preferredcontentmap = Nothing 		, requiredcontentmap = Nothing 		, forcetrust = M.empty
Annex/Action.hs view
@@ -11,7 +11,6 @@  import qualified Data.Map as M #ifndef mingw32_HOST_OS-import System.Posix.Signals import System.Posix.Process (getAnyProcessStatus) import Utility.Exception #endif@@ -26,12 +25,7 @@  {- Actions to perform each time ran. -} startup :: Annex ()-startup =-#ifndef mingw32_HOST_OS-	liftIO $ void $ installHandler sigINT Default Nothing-#else-	return ()-#endif+startup = return ()  {- Cleanup actions. -} shutdown :: Bool -> Annex ()
Annex/AdjustedBranch.hs view
@@ -55,7 +55,7 @@ import Annex.Link import Annex.AutoMerge import Annex.Content-import Annex.Perms+import Annex.Tmp import Annex.GitOverlay import Utility.Tmp.Dir import Utility.CopyFile@@ -356,12 +356,10 @@ 	 - (Doing the merge this way also lets it run even though the main 	 - index file is currently locked.) 	 -}-	changestomerge (Just updatedorig) = do-		misctmpdir <- fromRepo gitAnnexTmpMiscDir-		void $ createAnnexDirectory misctmpdir+	changestomerge (Just updatedorig) = withOtherTmp $ \othertmpdir -> do 		tmpwt <- fromRepo gitAnnexMergeDir 		git_dir <- fromRepo Git.localGitDir-		withTmpDirIn misctmpdir "git" $ \tmpgit -> withWorkTreeRelated tmpgit $+		withTmpDirIn othertmpdir "git" $ \tmpgit -> withWorkTreeRelated tmpgit $ 			withemptydir tmpwt $ withWorkTree tmpwt $ do 				liftIO $ writeFile (tmpgit </> "HEAD") (fromRef updatedorig) 				-- Copy in refs and packed-refs, to work
Annex/Branch.hs view
@@ -34,12 +34,14 @@ import qualified Data.Map as M import Data.Function import Data.Char+import Data.ByteString.Builder import Control.Concurrent (threadDelay)  import Annex.Common import Annex.BranchState import Annex.Journal import Annex.GitOverlay+import Annex.Tmp import qualified Git import qualified Git.Command import qualified Git.Ref@@ -65,7 +67,6 @@ import Annex.Branch.Transitions import qualified Annex import Annex.Hook-import Utility.FileSystemEncoding import Utility.Directory.Stream  {- Name of the branch that is used to store git-annex's information. -}@@ -210,7 +211,7 @@  - content is returned.  -  - Returns an empty string if the file doesn't exist yet. -}-get :: FilePath -> Annex String+get :: FilePath -> Annex L.ByteString get file = do 	update 	getLocal file@@ -219,21 +220,21 @@  - reflect changes in remotes.  - (Changing the value this returns, and then merging is always the  - same as using get, and then changing its value.) -}-getLocal :: FilePath -> Annex String+getLocal :: FilePath -> Annex L.ByteString getLocal file = go =<< getJournalFileStale file   where 	go (Just journalcontent) = return journalcontent 	go Nothing = getRef fullname file  {- Gets the content of a file as staged in the branch's index. -}-getStaged :: FilePath -> Annex String+getStaged :: FilePath -> Annex L.ByteString getStaged = getRef indexref   where 	-- This makes git cat-file be run with ":file", 	-- so it looks at the index. 	indexref = Ref "" -getHistorical :: RefDate -> FilePath -> Annex String+getHistorical :: RefDate -> FilePath -> Annex L.ByteString getHistorical date file = 	-- This check avoids some ugly error messages when the reflog 	-- is empty.@@ -242,27 +243,29 @@ 		, getRef (Git.Ref.dateRef fullname date) file 		) -getRef :: Ref -> FilePath -> Annex String-getRef ref file = withIndex $ decodeBS <$> catFile ref file+getRef :: Ref -> FilePath -> Annex L.ByteString+getRef ref file = withIndex $ catFile ref file  {- Applies a function to modify the content of a file.  -  - Note that this does not cause the branch to be merged, it only  - modifes the current content of the file on the branch.  -}-change :: FilePath -> (String -> String) -> Annex ()+change :: Journalable content => FilePath -> (L.ByteString -> content) -> Annex () change file f = lockJournal $ \jl -> f <$> getLocal file >>= set jl file  {- Applies a function which can modify the content of a file, or not. -}-maybeChange :: FilePath -> (String -> Maybe String) -> Annex ()+maybeChange :: Journalable content => FilePath -> (L.ByteString -> Maybe content) -> Annex () maybeChange file f = lockJournal $ \jl -> do 	v <- getLocal file 	case f v of-		Just v' | v' /= v -> set jl file v'+		Just jv ->+			let b = journalableByteString jv+			in when (v /= b) $ set jl file b 		_ -> noop  {- Records new content of a file into the journal -}-set :: JournalLocked -> FilePath -> String -> Annex ()+set :: Journalable content => JournalLocked -> FilePath -> content -> Annex () set = setJournalFile  {- Commit message used when making a commit of whatever data has changed@@ -320,7 +323,7 @@   where 	-- look for "parent ref" lines and return the refs 	commitparents = map (Git.Ref . snd) . filter isparent .-		map (toassoc . decodeBS) . L.split newline+		map (toassoc . decodeBL) . L.split newline 	newline = fromIntegral (ord '\n') 	toassoc = separate (== ' ') 	isparent (k,_) = k == "parent"@@ -486,9 +489,7 @@ 		mapM_ (removeFile . (dir </>)) stagedfs 		hClose jlogh 		nukeFile jlogf-	openjlog = do-		tmpdir <- fromRepo gitAnnexTmpMiscDir-		createAnnexDirectory tmpdir+	openjlog = withOtherTmp $ \tmpdir ->  		liftIO $ openTempFile tmpdir "jlog"  {- This is run after the refs have been merged into the index,@@ -522,7 +523,7 @@ 			return True   where 	getreftransition ref = do-		ts <- parseTransitionsStrictly "remote" . decodeBS+		ts <- parseTransitionsStrictly "remote" 			<$> catFile ref transitionsLog 		return (ref, ts) @@ -558,7 +559,7 @@ 		| neednewlocalbranch && null transitionedrefs = "new branch for transition " ++ tdesc 		| otherwise = "continuing transition " ++ tdesc 	tdesc = show $ map describeTransition tlist-	tlist = transitionList ts+	tlist = knownTransitionList ts  	{- The changes to make to the branch are calculated and applied to 	 - the branch directly, rather than going through the journal,@@ -585,7 +586,8 @@ 				-- File is deleted; can't run any other 				-- transitions on it. 				return ()-			ChangeFile content' -> do+			ChangeFile builder -> do+				let content' = toLazyByteString builder 				sha <- hashBlob content' 				Annex.Queue.addUpdateIndex $ Git.UpdateIndex.pureStreamer $ 					Git.UpdateIndex.updateIndexLine sha TreeFile (asTopFilePath file)@@ -595,7 +597,7 @@  checkBranchDifferences :: Git.Ref -> Annex () checkBranchDifferences ref = do-	theirdiffs <- allDifferences . parseDifferencesLog . decodeBS+	theirdiffs <- allDifferences . parseDifferencesLog 		<$> catFile ref differenceLog 	mydiffs <- annexDifferences <$> Annex.getGitConfig 	when (theirdiffs /= mydiffs) $
Annex/Branch/Transitions.hs view
@@ -1,6 +1,6 @@ {- git-annex branch transitions  -- - Copyright 2013-2018 Joey Hess <id@joeyh.name>+ - Copyright 2013-2019 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -10,6 +10,7 @@ 	getTransitionCalculator ) where +import Common import Logs import Logs.Transitions import qualified Logs.UUIDBased as UUIDBased@@ -22,41 +23,49 @@  import qualified Data.Map as M import qualified Data.Set as S-import Data.Default+import qualified Data.ByteString.Lazy as L+import qualified Data.Attoparsec.ByteString.Lazy as A+import Data.ByteString.Builder  data FileTransition-	= ChangeFile String+	= ChangeFile Builder 	| RemoveFile 	| PreserveFile -type TransitionCalculator = FilePath -> String -> TrustMap -> FileTransition+type TransitionCalculator = FilePath -> L.ByteString -> TrustMap -> FileTransition  getTransitionCalculator :: Transition -> Maybe TransitionCalculator getTransitionCalculator ForgetGitHistory = Nothing getTransitionCalculator ForgetDeadRemotes = Just dropDead -dropDead :: FilePath -> String -> TrustMap -> FileTransition+dropDead :: FilePath -> L.ByteString -> TrustMap -> FileTransition dropDead f content trustmap = case getLogVariety f of 	Just UUIDBasedLog 		-- Don't remove the dead repo from the trust log, 		-- because git remotes may still exist, and they need 		-- to still know it's dead. 		| f == trustLog -> PreserveFile-		| otherwise -> ChangeFile $ UUIDBased.showLog id $ dropDeadFromMapLog trustmap id $ UUIDBased.parseLog Just content+		| otherwise -> ChangeFile $+			UUIDBased.buildLog byteString $+				dropDeadFromMapLog trustmap id $+					UUIDBased.parseLog A.takeByteString content 	Just NewUUIDBasedLog -> ChangeFile $-		UUIDBased.showLogNew id $ dropDeadFromMapLog trustmap id $ UUIDBased.parseLogNew Just content+		UUIDBased.buildLogNew byteString $+			dropDeadFromMapLog trustmap id $+				UUIDBased.parseLogNew A.takeByteString content 	Just (ChunkLog _) -> ChangeFile $-		Chunk.showLog $ dropDeadFromMapLog trustmap fst $ Chunk.parseLog content+		Chunk.buildLog $ dropDeadFromMapLog trustmap fst $ Chunk.parseLog content 	Just (PresenceLog _) ->-		let newlog = Presence.compactLog $ dropDeadFromPresenceLog trustmap $ Presence.parseLog content+		let newlog = Presence.compactLog $+			dropDeadFromPresenceLog trustmap $ Presence.parseLog content 		in if null newlog 			then RemoveFile-			else ChangeFile $ Presence.showLog newlog+			else ChangeFile $ Presence.buildLog newlog 	Just RemoteMetaDataLog -> 		let newlog = dropDeadFromRemoteMetaDataLog trustmap $ MetaData.simplifyLog $ MetaData.parseLog content 		in if S.null newlog 			then RemoveFile-			else ChangeFile $ MetaData.showLog newlog+			else ChangeFile $ MetaData.buildLog newlog 	Just OtherLog -> PreserveFile 	Nothing -> PreserveFile @@ -68,7 +77,7 @@  - a dead uuid is dropped; any other values are passed through. -} dropDeadFromPresenceLog :: TrustMap -> [Presence.LogLine] -> [Presence.LogLine] dropDeadFromPresenceLog trustmap =-	filter $ notDead trustmap (toUUID . Presence.info)+	filter $ notDead trustmap (toUUID . Presence.fromLogInfo . Presence.info)  dropDeadFromRemoteMetaDataLog :: TrustMap -> MetaData.Log MetaData -> MetaData.Log MetaData dropDeadFromRemoteMetaDataLog trustmap =
Annex/CatFile.hs view
@@ -38,7 +38,6 @@ import Annex.Link import Annex.CurrentBranch import Types.AdjustedBranch-import Utility.FileSystemEncoding  catFile :: Git.Branch -> FilePath -> Annex L.ByteString catFile branch file = do@@ -106,12 +105,12 @@ 		-- Avoid catting large files, that cannot be symlinks or 		-- pointer files, which would require buffering their 		-- content in memory, as well as a lot of IO.-		| sz <= maxPointerSz = parseLinkOrPointer <$> catObject ref+		| sz <= maxPointerSz = parseLinkTargetOrPointer . L.toStrict <$> catObject ref 	go _ = return Nothing  {- Gets a symlink target. -} catSymLinkTarget :: Sha -> Annex String-catSymLinkTarget sha = fromInternalGitPath . decodeBS <$> get+catSymLinkTarget sha = fromInternalGitPath . decodeBL <$> get   where 	-- Avoid buffering the whole file content, which might be large. 	-- 8192 is enough if it really is a symlink.
Annex/Content.hs view
@@ -405,7 +405,7 @@ 	, "this safety check.)" 	]   where-	kv = formatKeyVariety (keyVariety k)+	kv = decodeBS (formatKeyVariety (keyVariety k))  data VerifyConfig = AlwaysVerify | NoVerify | RemoteVerify Remote | DefaultVerify @@ -544,7 +544,7 @@ 	| cryptographicallySecure (keyVariety key) = return True 	| otherwise = ifM (annexSecureHashesOnly <$> Annex.getGitConfig) 		( do-			warning $ "annex.securehashesonly blocked adding " ++ formatKeyVariety (keyVariety key) ++ " key to annex objects"+			warning $ "annex.securehashesonly blocked adding " ++ decodeBS (formatKeyVariety (keyVariety key)) ++ " key to annex objects" 			return False 		, return True 		)@@ -880,7 +880,8 @@ 		whenM (annexAlwaysCommit <$> Annex.getGitConfig) $ 			Annex.Branch.commit =<< Annex.Branch.commitMessage -{- Downloads content from any of a list of urls. -}+{- Downloads content from any of a list of urls, displaying a progress+ - meter. -} downloadUrl :: Key -> MeterUpdate -> [Url.URLString] -> FilePath -> Annex Bool downloadUrl k p urls file =  	-- Poll the file to handle configurations where an external
Annex/Difference.hs view
@@ -41,7 +41,7 @@ 					warning "Cannot change tunable parameters in already initialized repository." 				return oldds 			, if otherds == mempty-				then ifM (any (/= u) . M.keys <$> uuidMap)+				then ifM (any (/= u) . M.keys <$> uuidDescMap) 					( do 						warning "Cannot change tunable parameters in a clone of an existing repository." 						return mempty
Annex/DirHashes.hs view
@@ -26,7 +26,6 @@ import Key import Types.GitConfig import Types.Difference-import Utility.FileSystemEncoding import Utility.Hash  type Hasher = Key -> FilePath@@ -66,15 +65,14 @@ hashDirs _ sz s = addTrailingPathSeparator $ take sz s </> drop sz s  hashDirLower :: HashLevels -> Hasher-hashDirLower n k = hashDirs n 3 $ take 6 $ show $ md5 $-	encodeBS $ key2file $ nonChunkKey k+hashDirLower n k = hashDirs n 3 $ take 6 $ show $ md5 $ serializeKey' $ nonChunkKey k  {- This was originally using Data.Hash.MD5 from MissingH. This new version - is faster, but ugly as it has to replicate the 4 Word32's that produced. -} hashDirMixed :: HashLevels -> Hasher hashDirMixed n k = hashDirs n 2 $ take 4 $ concatMap display_32bits_as_dir $ 	encodeWord32 $ map fromIntegral $ Data.ByteArray.unpack $-		Utility.Hash.md5 $ encodeBS $ key2file $ nonChunkKey k+		Utility.Hash.md5 $ serializeKey' $ nonChunkKey k   where 	encodeWord32 (b1:b2:b3:b4:rest) = 		(shiftL b4 24 .|. shiftL b3 16 .|. shiftL b2 8 .|. b1)
Annex/Drop.hs view
@@ -11,11 +11,12 @@ import qualified Annex import Logs.Trust import Annex.NumCopies-import Types.Remote (uuid, appendonly)+import Types.Remote (uuid, appendonly, config) import qualified Remote import qualified Command.Drop import Command import Annex.Wanted+import Annex.Export import Config import Annex.Content.Direct import qualified Database.Keys@@ -30,7 +31,8 @@  - and numcopies settings.  -  - Skips trying to drop from remotes that are appendonly, since those drops- - would presumably fail.+ - would presumably fail. Also skips dropping from exporttree remotes,+ - which don't allow dropping individual keys.  -  - The UUIDs are ones where the content is believed to be present.  - The Remote list can include other remotes that do not have the content;@@ -61,10 +63,9 @@ 		AssociatedFile (Just f) -> nub (f : l) 		AssociatedFile Nothing -> l 	n <- getcopies fs-	let rs' = filter (not . appendonly) rs 	void $ if fromhere && checkcopies n Nothing-		then go fs rs' n >>= dropl fs-		else go fs rs' n+		then go fs rs n >>= dropl fs+		else go fs rs n   where 	getcopies fs = do 		(untrusted, have) <- trustPartition UnTrusted locs@@ -91,6 +92,8 @@ 	go _ [] n = pure n 	go fs (r:rest) n 		| uuid r `S.notMember` slocs = go fs rest n+		| appendonly r = go fs rest n+		| exportTree (config r) = go fs rest n 		| checkcopies n (Just $ Remote.uuid r) = 			dropr fs r n >>= go fs rest 		| otherwise = pure n@@ -112,7 +115,7 @@ 				liftIO $ debugM "drop" $ unwords 					[ "dropped" 					, case afile of-						AssociatedFile Nothing -> key2file key+						AssociatedFile Nothing -> serializeKey key 						AssociatedFile (Just af) -> af 					, "(from " ++ maybe "here" show u ++ ")" 					, "(copies now " ++ show (fromNumCopies have - 1) ++ ")"
Annex/Export.hs view
@@ -15,6 +15,7 @@ import qualified Types.Remote as Remote import Config import Messages+import Utility.FileSystemEncoding  import qualified Data.Map as M import Control.Applicative@@ -35,7 +36,7 @@   where 	mk (Just k) = AnnexKey k 	mk Nothing = GitKey $ Key-		{ keyName = Git.fromRef sha+		{ keyName = encodeBS $ Git.fromRef sha 		, keyVariety = SHA1Key (HasExt False) 		, keySize = Nothing 		, keyMtime = Nothing
Annex/HashObject.hs view
@@ -41,7 +41,7 @@ {- Note that the content will be written to a temp file.  - So it may be faster to use Git.HashObject.hashObject for large  - blob contents. -}-hashBlob :: String -> Annex Sha+hashBlob :: Git.HashObject.HashableBlob b => b -> Annex Sha hashBlob content = do 	h <- hashObjectHandle 	liftIO $ Git.HashObject.hashBlob h content
Annex/Ingest.hs view
@@ -30,6 +30,7 @@ import Annex.Content import Annex.Content.Direct import Annex.Perms+import Annex.Tmp import Annex.Link import Annex.MetaData import Annex.CurrentBranch@@ -84,14 +85,12 @@ lockDown' :: LockDownConfig -> FilePath -> Annex (Either IOException LockedDown) lockDown' cfg file = ifM (pure (not (hardlinkFileTmp cfg)) <||> crippledFileSystem) 	( withTSDelta $ liftIO . tryIO . nohardlink-	, tryIO $ do-		tmp <- fromRepo gitAnnexTmpMiscDir-		createAnnexDirectory tmp+	, tryIO $ withOtherTmp $ \tmp -> do 		when (lockingFile cfg) $ 			freezeContent file 		withTSDelta $ \delta -> liftIO $ do 			(tmpfile, h) <- openTempFile tmp $-				relatedTemplate $ takeFileName file+				relatedTemplate $ "ingest-" ++ takeFileName file 			hClose h 			nukeFile tmpfile 			withhardlink delta tmpfile `catchIO` const (nohardlink delta)
Annex/Init.hs view
@@ -44,6 +44,7 @@ import Annex.InodeSentinal import Upgrade import Annex.Perms+import Annex.Tmp import Utility.UserInfo #ifndef mingw32_HOST_OS import Utility.FileMode@@ -68,14 +69,14 @@ 				giveup "Not initialized." 			) -genDescription :: Maybe String -> Annex String-genDescription (Just d) = return d+genDescription :: Maybe String -> Annex UUIDDesc+genDescription (Just d) = return $ UUIDDesc $ encodeBS d genDescription Nothing = do 	reldir <- liftIO . relHome =<< liftIO . absPath =<< fromRepo Git.repoPath 	hostname <- fromMaybe "" <$> liftIO getHostname 	let at = if null hostname then "" else "@" 	v <- liftIO myUserName-	return $ concat $ case v of+	return $ UUIDDesc $ encodeBS $ concat $ case v of 		Right username -> [username, at, hostname, ":", reldir] 		Left _ -> [hostname, ":", reldir] @@ -109,7 +110,10 @@ 		hookWrite postReceiveHook 	setDifferences 	unlessM (isJust <$> getVersion) $-		setVersion (fromMaybe defaultVersion mversion)+		ifM (crippledFileSystem <&&> (not <$> isBareRepo))+			( setVersion (fromMaybe versionForCrippledFilesystem mversion)+			, setVersion (fromMaybe defaultVersion mversion)+			) 	whenM versionSupportsUnlockedPointers $ do 		configureSmudgeFilter 		scanUnlockedFiles@@ -160,9 +164,7 @@ {- A crippled filesystem is one that does not allow making symlinks,  - or removing write access from files. -} probeCrippledFileSystem :: Annex Bool-probeCrippledFileSystem = do-	tmp <- fromRepo gitAnnexTmpMiscDir-	createAnnexDirectory tmp+probeCrippledFileSystem = withOtherTmp $ \tmp -> do 	(r, warnings) <- liftIO $ probeCrippledFileSystem' tmp 	mapM_ warning warnings 	return r@@ -219,17 +221,16 @@ #ifdef mingw32_HOST_OS 	return True #else-	tmp <- fromRepo gitAnnexTmpMiscDir-	let f = tmp </> "lockprobe"-	createAnnexDirectory tmp-	mode <- annexFileMode-	liftIO $ do-		nukeFile f-		ok <- catchBoolIO $ do-			Posix.dropLock =<< Posix.lockExclusive (Just mode) f-			return True-		nukeFile f-		return ok+	withOtherTmp $ \tmp -> do+		let f = tmp </> "lockprobe"+		mode <- annexFileMode+		liftIO $ do+			nukeFile f+			ok <- catchBoolIO $ do+				Posix.dropLock =<< Posix.lockExclusive (Just mode) f+				return True+			nukeFile f+			return ok #endif  probeFifoSupport :: Annex Bool@@ -237,20 +238,19 @@ #ifdef mingw32_HOST_OS 	return False #else-	tmp <- fromRepo gitAnnexTmpMiscDir-	let f = tmp </> "gaprobe"-	let f2 = tmp </> "gaprobe2"-	createAnnexDirectory tmp-	liftIO $ do-		nukeFile f-		nukeFile f2-		ms <- tryIO $ do-			createNamedPipe f ownerReadMode-			createLink f f2-			getFileStatus f-		nukeFile f-		nukeFile f2-		return $ either (const False) isNamedPipe ms+	withOtherTmp $ \tmp -> do+		let f = tmp </> "gaprobe"+		let f2 = tmp </> "gaprobe2"+		liftIO $ do+			nukeFile f+			nukeFile f2+			ms <- tryIO $ do+				createNamedPipe f ownerReadMode+				createLink f f2+				getFileStatus f+			nukeFile f+			nukeFile f2+			return $ either (const False) isNamedPipe ms #endif  checkLockSupport :: Annex ()@@ -286,11 +286,12 @@ 		=<< getGlobalConfig "annex.securehashesonly"  adjustToCrippledFilesystem :: Annex ()-adjustToCrippledFilesystem = ifM (liftIO $ AdjustedBranch.isGitVersionSupported)-	( do-		void $ upgrade True versionForCrippledFilesystem-		AdjustedBranch.adjustToCrippledFileSystem-	, enableDirectMode +adjustToCrippledFilesystem = ifM versionSupportsAdjustedBranch+	( ifM (liftIO $ AdjustedBranch.isGitVersionSupported)+		( AdjustedBranch.adjustToCrippledFileSystem+		, enableDirectMode +		)+	, enableDirectMode 	)  enableDirectMode :: Annex ()
Annex/Journal.hs view
@@ -4,21 +4,37 @@  - git-annex branch. Among other things, it ensures that if git-annex is  - interrupted, its recorded data is not lost.  -- - Copyright 2011-2013 Joey Hess <id@joeyh.name>+ - Copyright 2011-2019 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -} -{-# LANGUAGE CPP #-}- module Annex.Journal where  import Annex.Common import qualified Git import Annex.Perms+import Annex.Tmp import Annex.LockFile import Utility.Directory.Stream +import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString as S+import Data.ByteString.Builder++class Journalable t where+	writeJournalHandle :: Handle -> t -> IO ()+	journalableByteString :: t -> L.ByteString++instance Journalable L.ByteString where+	writeJournalHandle = L.hPut+	journalableByteString = id++-- This is more efficient than the ByteString instance.+instance Journalable Builder where+	writeJournalHandle = hPutBuilder+	journalableByteString = toLazyByteString+ {- Records content for a file in the branch to the journal.  -  - Using the journal, rather than immediatly staging content to the index@@ -28,32 +44,34 @@  - getJournalFileStale to always return a consistent journal file  - content, although possibly not the most current one.  -}-setJournalFile :: JournalLocked -> FilePath -> String -> Annex ()-setJournalFile _jl file content = do-	tmp <- fromRepo gitAnnexTmpMiscDir+setJournalFile :: Journalable content => JournalLocked -> FilePath -> content -> Annex ()+setJournalFile _jl file content = withOtherTmp $ \tmp -> do 	createAnnexDirectory =<< fromRepo gitAnnexJournalDir-	createAnnexDirectory tmp 	-- journal file is written atomically 	jfile <- fromRepo $ journalFile file 	let tmpfile = tmp </> takeFileName jfile 	liftIO $ do-		withFile tmpfile WriteMode $ \h -> do-#ifdef mingw32_HOST_OS-			hSetNewlineMode h noNewlineTranslation-#endif-			hPutStr h content+		withFile tmpfile WriteMode $ \h -> writeJournalHandle h content 		moveFile tmpfile jfile  {- Gets any journalled content for a file in the branch. -}-getJournalFile :: JournalLocked -> FilePath -> Annex (Maybe String)+getJournalFile :: JournalLocked -> FilePath -> Annex (Maybe L.ByteString) getJournalFile _jl = getJournalFileStale  {- Without locking, this is not guaranteed to be the most recent  - version of the file in the journal, so should not be used as a basis for- - changes. -}-getJournalFileStale :: FilePath -> Annex (Maybe String)+ - changes.+ -+ - The file is read strictly so that its content can safely be fed into+ - an operation that modifies the file. While setJournalFile doesn't+ - write directly to journal files and so probably avoids problems with+ - writing to the same file that's being read, but there could be+ - concurrency or other issues with a lazy read, and the minor loss of+ - laziness doesn't matter much, as the files are not very large.+ -}+getJournalFileStale :: FilePath -> Annex (Maybe L.ByteString) getJournalFileStale file = inRepo $ \g -> catchMaybeIO $-	readFileStrict $ journalFile file g+	L.fromStrict <$> S.readFile (journalFile file g)  {- List of existing journal files, but without locking, may miss new ones  - just being added, or may have false positives if the journal is staged
Annex/Link.hs view
@@ -7,7 +7,7 @@  -  - Pointer files are used instead of symlinks for unlocked files.  -- - Copyright 2013-2018 Joey Hess <id@joeyh.name>+ - Copyright 2013-2019 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -30,18 +30,20 @@ import Annex.HashObject import Annex.InodeSentinal import Utility.FileMode-import Utility.FileSystemEncoding import Utility.InodeCache import Utility.Tmp.Dir import Utility.CopyFile+import qualified Utility.RawFilePath as R +import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L  type LinkTarget = String  {- Checks if a file is a link to a key. -} isAnnexLink :: FilePath -> Annex (Maybe Key)-isAnnexLink file = maybe Nothing (fileKey . takeFileName) <$> getAnnexLinkTarget file+isAnnexLink file = maybe Nothing parseLinkTargetOrPointer <$> getAnnexLinkTarget file  {- Gets the link target of a symlink.  -@@ -51,40 +53,42 @@  - Returns Nothing if the file is not a symlink, or not a link to annex  - content.  -}-getAnnexLinkTarget :: FilePath -> Annex (Maybe LinkTarget)+getAnnexLinkTarget :: FilePath -> Annex (Maybe S.ByteString) getAnnexLinkTarget f = getAnnexLinkTarget' f 	=<< (coreSymlinks <$> Annex.getGitConfig) -{- Pass False to force looking inside file. -}-getAnnexLinkTarget' :: FilePath -> Bool -> Annex (Maybe LinkTarget)+{- Pass False to force looking inside file, for when git checks out+ - symlinks as plain files. -}+getAnnexLinkTarget' :: FilePath -> Bool -> Annex (Maybe S.ByteString) getAnnexLinkTarget' file coresymlinks = if coresymlinks-	then check readSymbolicLink $+	then check probesymlink $ 		return Nothing-	else check readSymbolicLink $+	else check probesymlink $ 		check probefilecontent $ 			return Nothing   where 	check getlinktarget fallback = -		liftIO (catchMaybeIO $ getlinktarget file) >>= \case+		liftIO (catchMaybeIO getlinktarget) >>= \case 			Just l-				| isLinkToAnnex (fromInternalGitPath l) -> return (Just l)+				| isLinkToAnnex l -> return (Just l) 				| otherwise -> return Nothing 			Nothing -> fallback -	probefilecontent f = withFile f ReadMode $ \h -> do-		-- The first 8k is more than enough to read; link-		-- files are small.-		s <- take 8192 <$> hGetContents h-		-- If we got the full 8k, the file is too large-		if length s == 8192-			then return ""+	probesymlink = R.readSymbolicLink $ toRawFilePath file++	probefilecontent = withFile file ReadMode $ \h -> do+		s <- S.hGet h unpaddedMaxPointerSz+		-- If we got the full amount, the file is too large+		-- to be a symlink target.+		return $ if S.length s == unpaddedMaxPointerSz+			then mempty 			else  				-- If there are any NUL or newline 				-- characters, or whitespace, we-				-- certianly don't have a link to a+				-- certianly don't have a symlink to a 				-- git-annex key.-				return $ if any (`elem` s) "\0\n\r \t"-					then ""+				if any (`S8.elem` s) "\0\n\r \t"+					then mempty 					else s  makeAnnexLink :: LinkTarget -> FilePath -> Annex ()@@ -113,7 +117,7 @@  {- Injects a symlink target into git, returning its Sha. -} hashSymlink :: LinkTarget -> Annex Sha-hashSymlink linktarget = hashBlob (toInternalGitPath linktarget)+hashSymlink linktarget = hashBlob $ toRawFilePath $ toInternalGitPath linktarget  {- Stages a symlink to an annexed object, using a Sha of its target. -} stageSymlink :: FilePath -> Sha -> Annex ()@@ -123,7 +127,7 @@  {- Injects a pointer file content into git, returning its Sha. -} hashPointerFile :: Key -> Annex Sha-hashPointerFile key = hashBlob (formatPointer key)+hashPointerFile key = hashBlob $ formatPointer key  {- Stages a pointer file, using a Sha of its content -} stagePointerFile :: FilePath -> Maybe FileMode -> Sha -> Annex ()@@ -137,7 +141,7 @@  writePointerFile :: FilePath -> Key -> Maybe FileMode -> IO () writePointerFile file k mode = do-	writeFile file (formatPointer k)+	S.writeFile file (formatPointer k) 	maybe noop (setFileMode file) mode  newtype Restage = Restage Bool@@ -223,49 +227,58 @@ 	, "git update-index -q --refresh " ++ fromMaybe "<file>" mf 	] -{- Parses a symlink target or a pointer file to a Key.- - Only looks at the first line, as pointer files can have subsequent- - lines. -}-parseLinkOrPointer :: L.ByteString -> Maybe Key-parseLinkOrPointer = parseLinkOrPointer' -	. decodeBS . L.take (fromIntegral maxPointerSz)+{- Parses a symlink target or a pointer file to a Key. -}+parseLinkTargetOrPointer :: S.ByteString -> Maybe Key+parseLinkTargetOrPointer = parseLinkTarget . S8.takeWhile (not . lineend)   where+	lineend '\n' = True+	lineend '\r' = True+	lineend _ = False -{- Want to avoid buffering really big files in git into+{- Avoid looking at more of the lazy ByteString than necessary since it+ - could be reading from a large file that is not a pointer file. -}+parseLinkTargetOrPointerLazy :: L.ByteString -> Maybe Key+parseLinkTargetOrPointerLazy b = +	let b' = L.take (fromIntegral maxPointerSz) b+	in parseLinkTargetOrPointer (L.toStrict b')++{- Parses a symlink target to a Key. -}+parseLinkTarget :: S.ByteString -> Maybe Key+parseLinkTarget l+	| isLinkToAnnex l = fileKey' $ snd $ S8.breakEnd pathsep l+	| otherwise = Nothing+  where+	pathsep '/' = True+#ifdef mingw32_HOST_OS+	pathsep '\\' = True+#endif+	pathsep _ = False++formatPointer :: Key -> S.ByteString+formatPointer k = prefix <> keyFile' k <> nl+  where+	prefix = toRawFilePath $ toInternalGitPath (pathSeparator:objectDir)+	nl = S8.singleton '\n'++{- Maximum size of a file that could be a pointer to a key.+ - Check to avoid buffering really big files in git into  - memory when reading files that may be pointers.  -- - 8192 bytes is plenty for a pointer to a key.- - Pad some more to allow for any pointer files that might have+ - 8192 bytes is plenty for a pointer to a key. This adds some additional+ - padding to allow for any pointer files that might have  - lines after the key explaining what the file is used for. -} maxPointerSz :: Integer maxPointerSz = 81920 -parseLinkOrPointer' :: String -> Maybe Key-parseLinkOrPointer' = go . fromInternalGitPath . takeWhile (not . lineend)-  where-	go l-		| isLinkToAnnex l = fileKey $ takeFileName l-		| otherwise = Nothing-	lineend '\n' = True-	lineend '\r' = True-	lineend _ = False--formatPointer :: Key -> String-formatPointer k = -	toInternalGitPath (pathSeparator:objectDir </> keyFile k) ++ "\n"+unpaddedMaxPointerSz :: Int+unpaddedMaxPointerSz = 8192  {- Checks if a worktree file is a pointer to a key.  -  - Unlocked files whose content is present are not detected by this. -} isPointerFile :: FilePath -> IO (Maybe Key)-isPointerFile f = catchDefaultIO Nothing $ bracket open close $ \h -> do-	b <- take (fromIntegral maxPointerSz) <$> hGetContents h-	-- strict so it reads before the file handle is closed-	let !mk = parseLinkOrPointer' b-	return mk-  where-	open = openBinaryFile f ReadMode-	close = hClose+isPointerFile f = catchDefaultIO Nothing $ withFile f ReadMode $ \h ->+	parseLinkTargetOrPointer <$> S.hGet h unpaddedMaxPointerSz  {- Checks a symlink target or pointer file first line to see if it  - appears to point to annexed content.@@ -274,10 +287,15 @@  - directory itself, because GIT_DIR may cause a directory name other  - than .git to be used.  -}-isLinkToAnnex :: FilePath -> Bool-isLinkToAnnex s = (pathSeparator:objectDir) `isInfixOf` s+isLinkToAnnex :: S.ByteString -> Bool+isLinkToAnnex s = p `S.isInfixOf` s #ifdef mingw32_HOST_OS 	-- '/' is still used inside pointer files on Windows, not the native 	-- '\'-	|| ('/':objectDir) `isInfixOf` s+	|| p' `S.isInfixOf` s+#endif+  where+	p = toRawFilePath (pathSeparator:objectDir)+#ifdef mingw32_HOST_OS+	p' = toRawFilePath ('/':objectDir) #endif
Annex/Locations.hs view
@@ -1,13 +1,17 @@ {- git-annex file locations  -- - Copyright 2010-2017 Joey Hess <id@joeyh.name>+ - Copyright 2010-2019 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Annex.Locations ( 	keyFile,+	keyFile', 	fileKey,+	fileKey', 	keyPaths, 	keyPath, 	annexDir,@@ -24,7 +28,9 @@ 	annexLocations, 	gitAnnexDir, 	gitAnnexObjectDir,-	gitAnnexTmpMiscDir,+	gitAnnexTmpOtherDir,+	gitAnnexTmpOtherLock,+	gitAnnexTmpOtherDirOld, 	gitAnnexTmpObjectDir, 	gitAnnexTmpObjectLocation, 	gitAnnexTmpWorkDir,@@ -76,16 +82,15 @@ 	hashDirLower, 	preSanitizeKeyName, 	reSanitizeKeyName,--	prop_isomorphic_fileKey ) where  import Data.Char import Data.Default+import qualified Data.ByteString.Char8 as S8+import qualified Data.ByteString.Lazy as L  import Common import Key-import Types.Key import Types.UUID import Types.GitConfig import Types.Difference@@ -243,14 +248,22 @@ gitAnnexObjectDir :: Git.Repo -> FilePath gitAnnexObjectDir r = addTrailingPathSeparator $ Git.localGitDir r </> objectDir -{- .git/annex/misctmp/ is used for random temp files -}-gitAnnexTmpMiscDir :: Git.Repo -> FilePath-gitAnnexTmpMiscDir r = addTrailingPathSeparator $ gitAnnexDir r </> "misctmp"- {- .git/annex/tmp/ is used for temp files for key's contents -} gitAnnexTmpObjectDir :: Git.Repo -> FilePath gitAnnexTmpObjectDir r = addTrailingPathSeparator $ gitAnnexDir r </> "tmp" +{- .git/annex/othertmp/ is used for other temp files -}+gitAnnexTmpOtherDir :: Git.Repo -> FilePath+gitAnnexTmpOtherDir r = addTrailingPathSeparator $ gitAnnexDir r </> "othertmp"++{- Lock file for gitAnnexTmpOtherDir. -}+gitAnnexTmpOtherLock :: Git.Repo -> FilePath+gitAnnexTmpOtherLock r = gitAnnexDir r </> "othertmp.lck"++{- Directory used by old versions of git-annex. -}+gitAnnexTmpOtherDirOld :: Git.Repo -> FilePath+gitAnnexTmpOtherDirOld r = addTrailingPathSeparator $ gitAnnexDir r </> "misctmp"+ {- The temp file to use for a given key's content. -} gitAnnexTmpObjectLocation :: Key -> Git.Repo -> FilePath gitAnnexTmpObjectLocation key r = gitAnnexTmpObjectDir r </> keyFile key@@ -479,8 +492,8 @@   where 	escape c 		| isAsciiUpper c || isAsciiLower c || isDigit c = [c]-		| c `elem` ".-_" = [c] -- common, assumed safe-		| c `elem` "/%:" = [c] -- handled by keyFile+		| c `elem` ['.', '-', '_'] = [c] -- common, assumed safe+		| c `elem` ['/', '%', ':'] = [c] -- handled by keyFile 		-- , is safe and uncommon, so will be used to escape 		-- other characters. By itself, it is escaped to  		-- doubled form.@@ -509,33 +522,38 @@  - can cause existing objects to get lost.  -} keyFile :: Key -> FilePath-keyFile = concatMap esc . key2file+keyFile = fromRawFilePath . keyFile'++keyFile' :: Key -> RawFilePath+keyFile' k = +	let b = L.toStrict (serializeKey' k)+	in if any (`S8.elem` b) ['&', '%', ':', '/']+		then S8.concatMap esc b+		else b   where 	esc '&' = "&a" 	esc '%' = "&s" 	esc ':' = "&c" 	esc '/' = "%"-	esc c = [c]+	esc c = S8.singleton c  {- Reverses keyFile, converting a filename fragment (ie, the basename of  - the symlink target) into a key. -} fileKey :: FilePath -> Maybe Key-fileKey = file2key . unesc [] -  where-	unesc r [] = reverse r-	unesc r ('%':cs) = unesc ('/':r) cs-	unesc r ('&':'c':cs) = unesc (':':r) cs-	unesc r ('&':'s':cs) = unesc ('%':r) cs-	unesc r ('&':'a':cs) = unesc ('&':r) cs-	unesc r (c:cs) = unesc (c:r) cs+fileKey = fileKey' . toRawFilePath -{- for quickcheck -}-prop_isomorphic_fileKey :: String -> Bool-prop_isomorphic_fileKey s-	| null s = True -- it's not legal for a key to have no keyName-	| otherwise= Just k == fileKey (keyFile k)+fileKey' :: RawFilePath -> Maybe Key+fileKey' = deserializeKey' . S8.intercalate "/" . map go . S8.split '%'   where-	k = stubKey { keyName = s, keyVariety = OtherKey "test" }+	go = S8.concat . unescafterfirst . S8.split '&'+	unescafterfirst [] = []+	unescafterfirst (b:bs) = b : map (unesc . S8.uncons) bs+	unesc :: Maybe (Char, S8.ByteString) -> S8.ByteString+	unesc Nothing = mempty+	unesc (Just ('c', b)) = S8.cons ':' b+	unesc (Just ('s', b)) = S8.cons '%' b+	unesc (Just ('a', b)) = S8.cons '&' b+	unesc (Just (c, b)) = S8.cons c b  {- A location to store a key on a special remote that uses a filesystem.  - A directory hash is used, to protect against filesystems that dislike
Annex/LockFile.hs view
@@ -1,6 +1,6 @@ {- git-annex lock files.  -- - Copyright 2012-2015 Joey Hess <id@joeyh.name>+ - Copyright 2012-2019 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -12,6 +12,7 @@ 	unlockFile, 	getLockCache, 	fromLockCache,+	withSharedLock, 	withExclusiveLock, 	tryExclusiveLock, ) where@@ -57,6 +58,21 @@ changeLockCache a = do 	m <- getLockCache 	changeState $ \s -> s { lockcache = a m }++{- Runs an action with a shared lock held. If an exclusive lock is held,+ - blocks until it becomes free. -}+withSharedLock :: (Git.Repo -> FilePath) -> Annex a -> Annex a+withSharedLock getlockfile a = debugLocks $ do+	lockfile <- fromRepo getlockfile+	createAnnexDirectory $ takeDirectory lockfile+	mode <- annexFileMode+	bracket (lock mode lockfile) (liftIO . dropLock) (const a)+  where+#ifndef mingw32_HOST_OS+	lock mode = noUmask mode . lockShared (Just mode)+#else+	lock _mode = liftIO . waitToLock . lockShared+#endif  {- Runs an action with an exclusive lock held. If the lock is already  - held, blocks until it becomes free. -}
Annex/MetaData.hs view
@@ -22,6 +22,7 @@ import Utility.Glob  import qualified Data.Set as S+import qualified Data.Text as T import Data.Time.Calendar import Data.Time.Clock import Data.Time.Clock.POSIX@@ -71,30 +72,30 @@  - only changes to add the date fields. -} dateMetaData :: UTCTime -> MetaData -> MetaData dateMetaData mtime old = modMeta old $-	(SetMeta yearMetaField $ S.singleton $ toMetaValue $ show y)+	(SetMeta yearMetaField $ S.singleton $ toMetaValue $ encodeBS' $ show y) 		`ComposeModMeta`-	(SetMeta monthMetaField $ S.singleton $ toMetaValue $ show m)+	(SetMeta monthMetaField $ S.singleton $ toMetaValue $ encodeBS' $ show m) 		`ComposeModMeta`-	(SetMeta dayMetaField $ S.singleton $ toMetaValue $ show d)+	(SetMeta dayMetaField $ S.singleton $ toMetaValue $ encodeBS' $ show d)   where 	(y, m, d) = toGregorian $ utctDay mtime  {- Parses field=value, field+=value, field-=value, field?=value -} parseModMeta :: String -> Either String ModMeta parseModMeta p = case lastMaybe f of-	Just '+' -> AddMeta <$> mkMetaField f' <*> v-	Just '-' -> DelMeta <$> mkMetaField f' <*> (Just <$> v)-	Just '?' -> MaybeSetMeta <$> mkMetaField f' <*> v-	_ -> SetMeta <$> mkMetaField f <*> (S.singleton <$> v)+	Just '+' -> AddMeta <$> mkMetaField (T.pack f') <*> v+	Just '-' -> DelMeta <$> mkMetaField (T.pack f') <*> (Just <$> v)+	Just '?' -> MaybeSetMeta <$> mkMetaField (T.pack f') <*> v+	_ -> SetMeta <$> mkMetaField (T.pack f) <*> (S.singleton <$> v)   where 	(f, sv) = separate (== '=') p 	f' = beginning f-	v = pure (toMetaValue sv)+	v = pure (toMetaValue (encodeBS sv))  {- Parses field=value, field<value, field<=value, field>value, field>=value -} parseMetaDataMatcher :: String -> Either String (MetaField, MetaValue -> Bool) parseMetaDataMatcher p = (,)-	<$> mkMetaField f+	<$> mkMetaField (T.pack f) 	<*> pure matcher   where 	(f, op_v) = break (`elem` "=<>") p@@ -107,8 +108,8 @@ 		_ -> checkglob "" 	checkglob v = 		let cglob = compileGlob v CaseInsensative-		in matchGlob cglob . fromMetaValue-	checkcmp cmp v v' = case (doubleval v, doubleval (fromMetaValue v')) of+		in matchGlob cglob . decodeBS . fromMetaValue+	checkcmp cmp v v' = case (doubleval v, doubleval (decodeBS (fromMetaValue v'))) of 		(Just d, Just d') -> d' `cmp` d 		_ -> False 	doubleval v = readish v :: Maybe Double
Annex/MetaData/StandardFields.hs view
@@ -5,6 +5,8 @@  - Licensed under the GNU GPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Annex.MetaData.StandardFields ( 	tagMetaField, 	yearMetaField,@@ -18,7 +20,9 @@  import Types.MetaData -import Data.List+import qualified Data.Text as T+import Data.Monoid+import Prelude  tagMetaField :: MetaField tagMetaField = mkMetaFieldUnchecked "tag"@@ -43,17 +47,17 @@ lastChangedField = mkMetaFieldUnchecked lastchanged  mkLastChangedField :: MetaField -> MetaField-mkLastChangedField f = mkMetaFieldUnchecked (fromMetaField f ++ lastchangedSuffix)+mkLastChangedField f = mkMetaFieldUnchecked (fromMetaField f <> lastchangedSuffix)  isLastChangedField :: MetaField -> Bool isLastChangedField f 	| f == lastChangedField = True-	| otherwise = lastchanged `isSuffixOf` s && s /= lastchangedSuffix+	| otherwise = lastchanged `T.isSuffixOf` s && s /= lastchangedSuffix   where 	s = fromMetaField f -lastchanged :: String+lastchanged :: T.Text lastchanged = "lastchanged" -lastchangedSuffix :: String+lastchangedSuffix :: T.Text lastchangedSuffix = "-lastchanged"
Annex/ReplaceFile.hs view
@@ -10,7 +10,7 @@ module Annex.ReplaceFile where  import Annex.Common-import Annex.Perms+import Annex.Tmp import Utility.Tmp.Dir import Utility.Path.Max @@ -27,21 +27,19 @@  - Throws an IO exception when it was unable to replace the file.  -} replaceFile :: FilePath -> (FilePath -> Annex a) -> Annex a-replaceFile file action = do-	misctmpdir <- fromRepo gitAnnexTmpMiscDir-	void $ createAnnexDirectory misctmpdir+replaceFile file action = withOtherTmp $ \othertmpdir -> do #ifndef mingw32_HOST_OS 	-- Use part of the filename as the template for the temp 	-- directory. This does not need to be unique, but it 	-- makes it more clear what this temp directory is for.-	filemax <- liftIO $ fileNameLengthLimit misctmpdir+	filemax <- liftIO $ fileNameLengthLimit othertmpdir 	let basetmp = take (filemax `div` 2) (takeFileName file) #else 	-- Windows has limits on the whole path length, so keep 	-- it short. 	let basetmp = "t" #endif-	withTmpDirIn misctmpdir basetmp $ \tmpdir -> do+	withTmpDirIn othertmpdir basetmp $ \tmpdir -> do 		let tmpfile = tmpdir </> basetmp 		r <- action tmpfile 		liftIO $ replaceFileFrom tmpfile file
Annex/Ssh.hs view
@@ -32,7 +32,6 @@ import Config import Annex.Path import Utility.Env-import Utility.FileSystemEncoding import Utility.Hash import Types.CleanupActions import Types.Concurrency@@ -300,7 +299,7 @@ 	fromSshHost host ++ "!" ++ show port hostport2socket' :: String -> FilePath hostport2socket' s-	| length s > lengthofmd5s = show $ md5 $ encodeBS s+	| length s > lengthofmd5s = show $ md5 $ encodeBL s 	| otherwise = s   where 	lengthofmd5s = 32
+ Annex/Tmp.hs view
@@ -0,0 +1,56 @@+{- git-annex tmp files+ -+ - Copyright 2019 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Annex.Tmp where++import Common+import Annex+import Annex.Locations+import Annex.LockFile+import Annex.Perms+import Types.CleanupActions++import Data.Time.Clock.POSIX++-- | For creation of tmp files, other than for key's contents.+--+-- The action should normally clean up whatever files it writes to the temp+-- directory that is passed to it. However, once the action is done,+-- any files left in that directory may be cleaned up by another process at+-- any time.+withOtherTmp :: (FilePath -> Annex a) -> Annex a+withOtherTmp a = do+	addCleanup OtherTmpCleanup cleanupOtherTmp+	tmpdir <- fromRepo gitAnnexTmpOtherDir+	tmplck <- fromRepo gitAnnexTmpOtherLock+	void $ createAnnexDirectory tmpdir+	withSharedLock (const tmplck) (a tmpdir)++-- | Cleans up any tmp files that were left by a previous+-- git-annex process that got interrupted or failed to clean up after+-- itself for some other reason.+--+-- Does not do anything if withOtherTmp is running.+cleanupOtherTmp :: Annex ()+cleanupOtherTmp = do+	tmplck <- fromRepo gitAnnexTmpOtherLock+	void $ tryIO $ tryExclusiveLock (const tmplck) $ do+		tmpdir <- fromRepo gitAnnexTmpOtherDir+		void $ liftIO $ tryIO $ removeDirectoryRecursive tmpdir+		-- This is only to clean up cruft left by old versions of+		-- git-annex; it can be removed eventually.+		oldtmp <- fromRepo gitAnnexTmpOtherDirOld+		liftIO $ mapM_ cleanold =<< dirContentsRecursive oldtmp+		liftIO $ void $ tryIO $ removeDirectory oldtmp -- when empty+  where+	cleanold f = do+		now <- liftIO getPOSIXTime+		let oldenough = now - (60 * 60 * 24 * 7)+		catchMaybeIO (modificationTime <$> getSymbolicLinkStatus f) >>= \case+			Just mtime | realToFrac mtime <= oldenough -> +				void $ tryIO $ nukeFile f+			_ -> return ()
Annex/Transfer.hs view
@@ -178,7 +178,7 @@ 	| cryptographicallySecure variety = a 	| otherwise = ifM (annexSecureHashesOnly <$> Annex.getGitConfig) 		( do-			warning $ "annex.securehashesonly blocked transfer of " ++ formatKeyVariety variety ++ " key"+			warning $ "annex.securehashesonly blocked transfer of " ++ decodeBS (formatKeyVariety variety) ++ " key" 			return observeFailure 		, a 		)
Annex/UUID.hs view
@@ -37,20 +37,20 @@ import qualified Data.UUID as U import qualified Data.UUID.V4 as U4 import qualified Data.UUID.V5 as U5-import Utility.FileSystemEncoding+import Data.String  configkey :: ConfigKey configkey = annexConfig "uuid"  {- Generates a random UUID, that does not include the MAC address. -} genUUID :: IO UUID-genUUID = UUID . show <$> U4.nextRandom+genUUID = toUUID <$> U4.nextRandom  {- 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 = UUID . show . U5.generateNamed namespace . s2w8+genUUIDInNameSpace namespace = toUUID . U5.generateNamed namespace . s2w8  {- Namespace used for UUIDs derived from git-remote-gcrypt ids. -} gCryptNameSpace :: U.UUID@@ -117,8 +117,8 @@  -- Dummy uuid for the whole web. Do not alter. webUUID :: UUID-webUUID = UUID "00000000-0000-0000-0000-000000000001"+webUUID = UUID (fromString "00000000-0000-0000-0000-000000000001")  -- Dummy uuid for bittorrent. Do not alter. bitTorrentUUID :: UUID-bitTorrentUUID = UUID "00000000-0000-0000-0000-000000000002"+bitTorrentUUID = UUID (fromString "00000000-0000-0000-0000-000000000002")
Annex/VariantFile.hs view
@@ -8,9 +8,10 @@ module Annex.VariantFile where  import Annex.Common-import Utility.FileSystemEncoding import Utility.Hash +import qualified Data.ByteString.Lazy as L+ variantMarker :: String variantMarker = ".variant-" @@ -35,10 +36,10 @@  -} variantFile :: FilePath -> Key -> FilePath variantFile file key-	| doubleconflict = mkVariant file (key2file key)-	| otherwise = mkVariant file (shortHash $ key2file key)+	| doubleconflict = mkVariant file (keyFile key)+	| otherwise = mkVariant file (shortHash $ serializeKey' key)   where 	doubleconflict = variantMarker `isInfixOf` file -shortHash :: String -> String-shortHash = take 4 . show . md5 . encodeBS+shortHash :: L.ByteString -> String+shortHash = take 4 . show . md5
Annex/VectorClock.hs view
@@ -3,7 +3,7 @@  - We don't have a way yet to keep true distributed vector clocks.  - The next best thing is a timestamp.  -- - Copyright 2017 Joey Hess <id@joeyh.name>+ - Copyright 2017-2019 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -11,17 +11,19 @@ module Annex.VectorClock where  import Data.Time.Clock.POSIX+import Data.ByteString.Builder import Control.Applicative import Prelude  import Utility.Env import Utility.TimeStamp import Utility.QuickCheck+import qualified Data.Attoparsec.ByteString.Lazy as A  -- | Some very old logs did not have any time stamp at all; -- Unknown is used for those. data VectorClock = Unknown | VectorClock POSIXTime-	deriving (Eq, Ord)+	deriving (Eq, Ord, Show)  -- Unknown is oldest. prop_VectorClock_sane :: Bool@@ -39,8 +41,14 @@ 		Nothing -> VectorClock <$> getPOSIXTime  formatVectorClock :: VectorClock -> String-formatVectorClock  Unknown = "0"+formatVectorClock Unknown = "0" formatVectorClock (VectorClock t) = show t +buildVectorClock :: VectorClock -> Builder+buildVectorClock = string7 . formatVectorClock+ parseVectorClock :: String -> Maybe VectorClock parseVectorClock t = VectorClock <$> parsePOSIXTime t++vectorClockParser :: A.Parser VectorClock+vectorClockParser = VectorClock <$> parserPOSIXTime
Annex/View.hs view
@@ -31,6 +31,8 @@ import Types.Command import CmdLine.Action +import qualified Data.Text as T+import qualified Data.ByteString as B import qualified Data.Set as S import qualified Data.Map as M import "mtl" Control.Monad.Writer@@ -68,18 +70,18 @@ 		) 	(field, wanted) 		| end field == "!" ->-			( mkMetaFieldUnchecked (beginning field)+			( mkMetaFieldUnchecked (T.pack (beginning field)) 			, mkExcludeValues wanted 			) 		| otherwise ->-			( mkMetaFieldUnchecked field+			( mkMetaFieldUnchecked (T.pack field) 			, mkFilterValues wanted 			)   where 	mkFilterValues v 		| any (`elem` v) "*?" = FilterGlob v-		| otherwise = FilterValues $ S.singleton $ toMetaValue v-	mkExcludeValues = ExcludeValues . S.singleton . toMetaValue+		| otherwise = FilterValues $ S.singleton $ toMetaValue $ encodeBS v+	mkExcludeValues = ExcludeValues . S.singleton . toMetaValue . encodeBS  data ViewChange = Unchanged | Narrowing | Widening 	deriving (Ord, Eq, Show)@@ -156,7 +158,7 @@ combineViewFilter (FilterValues _) newglob@(FilterGlob _) = 	(newglob, Widening) combineViewFilter (FilterGlob oldglob) new@(FilterValues s)-	| all (matchGlob (compileGlob oldglob CaseInsensative) . fromMetaValue) (S.toList s) = (new, Narrowing)+	| all (matchGlob (compileGlob oldglob CaseInsensative) . decodeBS . fromMetaValue) (S.toList s) = (new, Narrowing) 	| otherwise = (new, Widening) combineViewFilter (FilterGlob old) newglob@(FilterGlob new) 	| old == new = (newglob, Unchanged)@@ -211,7 +213,7 @@ 		FilterGlob glob -> 			let cglob = compileGlob glob CaseInsensative 			in \values -> setmatches $-				S.filter (matchGlob cglob . fromMetaValue) values+				S.filter (matchGlob cglob . decodeBS . fromMetaValue) values 		ExcludeValues excludes -> \values ->  			if S.null (S.intersection values excludes) 				then Just []@@ -231,7 +233,7 @@ pseudoBackslash = "\56546\56469\56498"  toViewPath :: MetaValue -> FilePath-toViewPath = escapeslash [] . fromMetaValue+toViewPath = escapeslash [] . decodeBS . fromMetaValue   where 	escapeslash s ('/':cs) = escapeslash (pseudoSlash:s) cs 	escapeslash s ('\\':cs) = escapeslash (pseudoBackslash:s) cs@@ -243,7 +245,7 @@ 	escapeslash s cs = concat (reverse (cs:s))  fromViewPath :: FilePath -> MetaValue-fromViewPath = toMetaValue . deescapeslash []+fromViewPath = toMetaValue . encodeBS . deescapeslash []   where 	deescapeslash s ('%':escapedc:cs) = deescapeslash ([escapedc]:s) cs 	deescapeslash s (c1:c2:c3:cs)@@ -285,7 +287,7 @@ 	all hasfields (viewedFiles view viewedFileFromReference f metadata)   where 	view = View (Git.Ref "master") $-		map (\(mf, mv) -> ViewComponent mf (FilterValues $ S.filter (not . null . fromMetaValue) mv) visible)+		map (\(mf, mv) -> ViewComponent mf (FilterValues $ S.filter (not . B.null . fromMetaValue) mv) visible) 			(fromMetaData metadata) 	visiblefields = sort (map viewField $ filter viewVisible (viewComponents view)) 	hasfields fv = sort (map fst (fromMetaData (fromView view fv))) == visiblefields@@ -300,9 +302,9 @@ getDirMetaData d = MetaData $ M.fromList $ zip fields values   where 	dirs = splitDirectories d-	fields = map (mkMetaFieldUnchecked . addTrailingPathSeparator . joinPath)+	fields = map (mkMetaFieldUnchecked . T.pack . addTrailingPathSeparator . joinPath) 		(inits dirs)-	values = map (S.singleton . toMetaValue . fromMaybe "" . headMaybe)+	values = map (S.singleton . toMetaValue . encodeBS . fromMaybe "" . headMaybe) 		(tails dirs)  getWorkTreeMetaData :: FilePath -> MetaData
Annex/YoutubeDl.hs view
@@ -27,7 +27,7 @@ import Network.URI import Control.Concurrent.Async --- youtube-dl is can follow redirects to anywhere, including potentially+-- youtube-dl can follow redirects to anywhere, including potentially -- localhost or a private address. So, it's only allowed to download -- content if the user has allowed access to all addresses. youtubeDlAllowed :: Annex Bool
Assistant/MakeRemote.hs view
@@ -106,8 +106,8 @@ 	(c', u) <- R.setup remotetype ss mu mcreds weakc dummycfg 	configSet u c' 	when setdesc $-		whenM (isNothing . M.lookup u <$> uuidMap) $-			describeUUID u name+		whenM (isNothing . M.lookup u <$> uuidDescMap) $+			describeUUID u (toUUIDDesc name) 	return name  {- Returns the name of the git remote it created. If there's already a
Assistant/Monad.hs view
@@ -27,6 +27,7 @@  import "mtl" Control.Monad.Reader import System.Log.Logger+import qualified Control.Monad.Fail as Fail  import Annex.Common import Assistant.Types.ThreadedMonad@@ -49,6 +50,7 @@ 		Monad, 		MonadIO, 		MonadReader AssistantData,+		Fail.MonadFail, 		Functor, 		Applicative 	)
Assistant/Threads/Committer.hs view
@@ -29,6 +29,7 @@ import Annex.Content import Annex.Ingest import Annex.Link+import Annex.Tmp import Annex.CatFile import Annex.InodeSentinal import Annex.Version@@ -487,9 +488,7 @@ 		( liftIO $ do 			let segments = segmentXargsUnordered $ map keyFilename keysources 			concat <$> forM segments (\fs -> Lsof.query $ "--" : fs)-		, do-			tmpdir <- fromRepo gitAnnexTmpMiscDir-			liftIO $ Lsof.queryDir tmpdir+		, withOtherTmp $ liftIO . Lsof.queryDir 		)  {- After a Change is committed, queue any necessary transfers or drops
Assistant/Threads/ConfigMonitor.hs view
@@ -57,7 +57,7 @@ {- All git-annex's config files, and actions to run when they change. -} configFilesActions :: [(FilePath, Assistant ())] configFilesActions =-	[ (uuidLog, void $ liftAnnex uuidMapLoad)+	[ (uuidLog, void $ liftAnnex uuidDescMapLoad) 	, (remoteLog, void $ liftAnnex remoteListRefresh) 	, (trustLog, void $ liftAnnex trustMapLoad) 	, (groupLog, void $ liftAnnex groupMapLoad)
Assistant/Threads/SanityChecker.hs view
@@ -6,6 +6,7 @@  -}  {-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}  module Assistant.Threads.SanityChecker ( 	sanityCheckerStartupThread,@@ -39,8 +40,8 @@ import Assistant.Unused import Logs.Unused import Types.Transfer-import Types.Key import Annex.Path+import Annex.Tmp import qualified Annex #ifdef WITH_WEBAPP import Assistant.WebApp.Types@@ -86,9 +87,7 @@ 	liftIO $ fixUpSshRemotes  	{- Clean up old temp files. -}-	void $ liftAnnex $ tryNonAsync $ do-		cleanOldTmpMisc-		cleanReallyOldTmp+	void $ liftAnnex $ tryNonAsync $ cleanupOtherTmp  	{- If there's a startup delay, it's done here. -} 	liftIO $ maybe noop (threadDelaySeconds . Seconds . fromIntegral . durationSeconds) startupdelay@@ -267,58 +266,6 @@ #else 		debug [show $ renderTense Past msg] #endif--{- Files may be left in misctmp by eg, an interrupted add of files- - by the assistant, which hard links files to there as part of lockdown- - checks. Delete these files if they're more than a day old.- -- - Note that this is not safe to run after the Watcher starts up, since it- - will create such files, and due to hard linking they may have old- - mtimes. So, this should only be called from the- - sanityCheckerStartupThread, which runs before the Watcher starts up.- -- - Also, if a git-annex add is being run at the same time the assistant- - starts up, its tmp files could be deleted. However, the watcher will- - come along and add everything once it starts up anyway, so at worst- - this would make the git-annex add fail unexpectedly.- -}-cleanOldTmpMisc :: Annex ()-cleanOldTmpMisc = do-	now <- liftIO getPOSIXTime-	let oldenough = now - (60 * 60 * 24)-	tmp <- fromRepo gitAnnexTmpMiscDir-	liftIO $ mapM_ (cleanOld (<= oldenough)) =<< dirContentsRecursive tmp--{- While .git/annex/tmp is now only used for storing partially transferred- - objects, older versions of git-annex used it for misctemp. Clean up any- - files that might be left from that, by looking for files whose names- - cannot be the key of an annexed object. Only delete files older than- - 1 week old.- -- - Also, some remotes such as rsync may use this temp directory for storing- - eg, encrypted objects that are being transferred. So, delete old- - objects that use a GPGHMAC backend.- -}-cleanReallyOldTmp :: Annex ()-cleanReallyOldTmp = do-	now <- liftIO getPOSIXTime-	let oldenough = now - (60 * 60 * 24 * 7)-	tmp <- fromRepo gitAnnexTmpObjectDir-	liftIO $ mapM_ (cleanjunk (<= oldenough)) =<< dirContentsRecursive tmp-  where-	cleanjunk check f = case fileKey (takeFileName f) of-		Nothing -> cleanOld check f-		Just k-			| "GPGHMAC" `isPrefixOf` formatKeyVariety (keyVariety k) ->-				cleanOld check f-			| otherwise -> noop--cleanOld :: (POSIXTime -> Bool) -> FilePath -> IO ()-cleanOld check f = go =<< catchMaybeIO getmtime-  where-	getmtime = realToFrac . modificationTime <$> getSymbolicLinkStatus f-	go (Just mtime) | check mtime = nukeFile f-	go _ = noop  checkRepoExists :: Assistant () checkRepoExists = do
Assistant/Threads/Watcher.hs view
@@ -44,7 +44,6 @@ import Config import Config.GitConfig import Utility.ThreadScheduler-import Utility.FileSystemEncoding import Logs.Location import qualified Database.Keys #ifndef mingw32_HOST_OS@@ -303,11 +302,11 @@ 			case linktarget of 				Nothing -> a 				Just lt -> do-					case fileKey $ takeFileName lt of+					case parseLinkTarget lt of 						Nothing -> noop 						Just key -> liftAnnex $ 							addassociatedfile key file-					onAddSymlink' linktarget mk isdirect file fs+					onAddSymlink' (Just $ fromRawFilePath lt) mk isdirect file fs  {- A symlink might be an arbitrary symlink, which is just added.  - Or, if it is a git-annex symlink, ensure it points to the content
Assistant/TransferQueue.hs view
@@ -191,16 +191,17 @@ 		sz <- readTVar (queuesize q) 		if sz < 1 			then retry -- blocks until queuesize changes-			else do-				(r@(t,info):rest) <- readTList (queuelist q)-				void $ modifyTVar' (queuesize q) pred-				setTList (queuelist q) rest-				if acceptable info-					then do-						adjustTransfersSTM dstatus $-							M.insert t info-						return $ Just r-					else return Nothing+			else readTList (queuelist q) >>= \case+				[] -> retry -- blocks until something is queued+				(r@(t,info):rest) -> do+					void $ modifyTVar' (queuesize q) pred+					setTList (queuelist q) rest+					if acceptable info+						then do+							adjustTransfersSTM dstatus $+								M.insert t info+							return $ Just r+						else return Nothing  {- Moves transfers matching a condition from the queue, to the  - currentTransfers map. -}
Assistant/Unused.hs view
@@ -74,7 +74,7 @@ 	now <- liftIO getPOSIXTime 	let oldkeys = M.keys $ M.filter (tooold now) m 	forM_ oldkeys $ \k -> do-		debug ["removing old unused key", key2file k]+		debug ["removing old unused key", serializeKey k] 		liftAnnex $ tryNonAsync $ do 			lockContentForRemoval k removeAnnex 			logStatus k InfoMissing
Assistant/WebApp/Configurators/Edit.hs view
@@ -45,6 +45,7 @@ import Config import Config.GitConfig import Config.DynamicConfig+import Types.Group  import qualified Data.Text as T import qualified Data.Map as M@@ -66,15 +67,15 @@ getRepoConfig uuid mremote = do 	-- Ensure we're editing current data by discarding caches. 	void groupMapLoad-	void uuidMapLoad+	void uuidDescMapLoad  	groups <- lookupGroups uuid 	remoteconfig <- M.lookup uuid <$> readRemoteLog 	let (repogroup, associateddirectory) = case getStandardGroup groups of-		Nothing -> (RepoGroupCustom $ unwords $ S.toList groups, Nothing)+		Nothing -> (RepoGroupCustom $ unwords $ map fromGroup $ S.toList groups, Nothing) 		Just g -> (RepoGroupStandard g, associatedDirectory remoteconfig g) 	-	description <- fmap T.pack . M.lookup uuid <$> uuidMap+	description <- fmap (T.pack . fromUUIDDesc) . M.lookup uuid <$> uuidDescMap  	syncable <- case mremote of 		Just r -> liftIO $ getDynamicConfig $ remoteAnnexSync $ Remote.gitconfig r@@ -90,8 +91,8 @@ setRepoConfig :: UUID -> Maybe Remote -> RepoConfig -> RepoConfig -> Handler () setRepoConfig uuid mremote oldc newc = do 	when descriptionChanged $ liftAnnex $ do-		maybe noop (describeUUID uuid . T.unpack) (repoDescription newc)-		void uuidMapLoad+		maybe noop (describeUUID uuid . toUUIDDesc . T.unpack) (repoDescription newc)+		void uuidDescMapLoad 	when nameChanged $ do 		liftAnnex $ do 			name <- uniqueRemoteName (legalName newc) 0 <$> Annex.getGitRemotes@@ -127,7 +128,7 @@ 	when groupChanged $ do 		liftAnnex $ case repoGroup newc of 			RepoGroupStandard g -> setStandardGroup uuid g-			RepoGroupCustom s -> groupSet uuid $ S.fromList $ words s+			RepoGroupCustom s -> groupSet uuid $ S.fromList $ map toGroup $ words s 		{- Enabling syncing will cause a scan, 		 - so avoid queueing a duplicate scan. -} 		when (repoSyncable newc && not syncableChanged) $ liftAssistant $
Assistant/WebApp/Configurators/Local.hs view
@@ -289,7 +289,7 @@ 	askcombine = page "Combine repositories?" (Just Configuration) $ 		$(widgetFile "configurators/adddrive/combine") 	isknownuuid driveuuid =-		ifM (M.member driveuuid <$> liftAnnex uuidMap)+		ifM (M.member driveuuid <$> liftAnnex uuidDescMap) 			( knownrepo 			, askcombine 			)
Assistant/WebApp/Configurators/Ssh.hs view
@@ -213,23 +213,21 @@ enableSshRemote getsshdata rsyncnetsetup genericsetup u = do 	m <- fromMaybe M.empty . M.lookup u <$> liftAnnex readRemoteLog 	case (unmangle <$> getsshdata m, M.lookup "name" m) of-		(Just sshdata, Just reponame)-			| isGitLab sshdata -> enableGitLab sshdata-			| otherwise -> sshConfigurator $ do-				((result, form), enctype) <- liftH $-					runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $-						sshInputAForm textField $ mkSshInput sshdata-				case result of-					FormSuccess sshinput-						| isRsyncNet (inputHostname sshinput) ->-							void $ liftH $ rsyncnetsetup sshinput reponame-						| otherwise -> do-							s <- liftAssistant $ testServer sshinput-							case s of-								Left status -> showform form enctype status-								Right (sshdata', _u) -> void $ liftH $ genericsetup-									( sshdata' { sshRepoName = reponame } ) u-					_ -> showform form enctype UntestedServer+		(Just sshdata, Just reponame) -> sshConfigurator $ do+			((result, form), enctype) <- liftH $+				runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $+					sshInputAForm textField $ mkSshInput sshdata+			case result of+				FormSuccess sshinput+					| isRsyncNet (inputHostname sshinput) ->+						void $ liftH $ rsyncnetsetup sshinput reponame+					| otherwise -> do+						s <- liftAssistant $ testServer sshinput+						case s of+							Left status -> showform form enctype status+							Right (sshdata', _u) -> void $ liftH $ genericsetup+								( sshdata' { sshRepoName = reponame } ) u+				_ -> showform form enctype UntestedServer 		_ -> redirect AddSshR   where 	unmangle sshdata = sshdata@@ -418,7 +416,7 @@ getConfirmSshR :: SshData -> UUID -> Handler Html getConfirmSshR sshdata u 	| u == NoUUID = handlenew-	| otherwise = handleexisting =<< (M.lookup u <$> liftAnnex uuidMap)+	| otherwise = handleexisting =<< (M.lookup u <$> liftAnnex uuidDescMap)   where 	handlenew = sshConfigurator $ do 		cmd <- liftAnnex $ gpgCmd <$> Annex.getGitConfig@@ -675,110 +673,3 @@ isRsyncNet :: Maybe Text -> Bool isRsyncNet Nothing = False isRsyncNet (Just host) = ".rsync.net" `T.isSuffixOf` T.toLower host--data GitLabUrl = GitLabUrl { unGitLabUrl :: Text }--badGitLabUrl :: Text-badGitLabUrl = "Bad SSH clone url. Expected something like: git@gitlab.com:yourlogin/annex.git"--parseGitLabUrl :: GitLabUrl -> Maybe SshData-parseGitLabUrl (GitLabUrl t) = -	let (u, r) = separate (== '@') (T.unpack t)-	    (h, p) = separate (== ':') r-	in if null u || null h || null p-		then Nothing-		else Just $ SshData-			{ sshHostName = T.pack h-			, sshUserName = Just (T.pack u)-			, sshDirectory = T.pack p-			, sshRepoName = genSshRepoName h p-			, sshPort = 22-			, needsPubKey = False-			, sshCapabilities = -				[ GitAnnexShellCapable-				, GitCapable-				, PushCapable-				]-			, sshRepoUrl = Just (T.unpack t)-			}--isGitLab :: SshData -> Bool-isGitLab d = T.pack "gitlab.com" `T.isSuffixOf` (T.toLower (sshHostName d))--toGitLabUrl :: SshData -> GitLabUrl-toGitLabUrl d = GitLabUrl $ T.concat-	[ fromMaybe (T.pack "git") (sshUserName d)-	, T.pack "@"-	, sshHostName d-	, T.pack ":"-	, sshDirectory d-	]--{- Try to ssh into the gitlab server, verify we can access the repository,- - and get the uuid of the repository, if it already has one.- -- - A repository on gitlab won't be initialized as a git-annex repo - - unless a git-annex branch was already pushed to it. So, if- - git-annex-shell fails to work that's probably why; verify if- - the server is letting us ssh in by running git send-pack- - (in dry run mode). -}-testGitLabUrl :: GitLabUrl -> Annex (ServerStatus, Maybe SshData, UUID)-testGitLabUrl glu = case parseGitLabUrl glu of-	Nothing -> return (UnusableServer badGitLabUrl, Nothing, NoUUID)-	Just sshdata -> -		checkor sshdata $ do-			(sshdata', keypair) <- liftIO $ setupSshKeyPair sshdata-			checkor sshdata' $ -				return (ServerNeedsPubKey (sshPubKey keypair), Just sshdata', NoUUID)-  where-	checkor sshdata ora = do-		u <- probeuuid sshdata-		if u /= NoUUID-			then return (UsableServer (sshCapabilities sshdata), Just sshdata, u)-			else ifM (verifysshworks sshdata)-				( return (UsableServer (sshCapabilities sshdata), Just sshdata, NoUUID)-				, ora-				)-	probeuuid sshdata = do-		r <- inRepo $ Git.Construct.fromRemoteLocation (fromJust $ sshRepoUrl sshdata)-		getUncachedUUID . either (const r) fst <$>-			Remote.Helper.Ssh.onRemote NoConsumeStdin r-				(Git.Config.fromPipe r, return (Left $ error "configlist failed"))-				"configlist" [] []-	verifysshworks sshdata = inRepo $ Git.Command.runBool-		[ Param "send-pack"-		, Param (fromJust $ sshRepoUrl sshdata)-		, Param "--dry-run"-		, Param "--force"-		, Param (fromRef Annex.Branch.name)-		]--gitLabUrlAForm :: Maybe GitLabUrl -> AForm Handler GitLabUrl-gitLabUrlAForm defval = GitLabUrl <$> areq check_input (bfs "SSH clone url") (unGitLabUrl <$> defval)-  where-	check_input = checkBool (isJust . parseGitLabUrl . GitLabUrl)-		badGitLabUrl textField--getAddGitLabR :: Handler Html-getAddGitLabR = postAddGitLabR-postAddGitLabR :: Handler Html-postAddGitLabR = promptGitLab Nothing--promptGitLab :: Maybe GitLabUrl -> Handler Html-promptGitLab defval = sshConfigurator $ do-	((result, form), enctype) <- liftH $-		runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $-			gitLabUrlAForm defval-	case result of-		FormSuccess gitlaburl -> do-			(status, msshdata, u) <- liftAnnex $ testGitLabUrl gitlaburl-			case (status, msshdata) of-				(UsableServer _, Just sshdata) ->-					liftH $ redirect $ ConfirmSshR sshdata u-				_ -> showform form enctype status-		_ -> showform form enctype UntestedServer-  where-	showform form enctype status = $(widgetFile "configurators/gitlab.com/add")--enableGitLab :: SshData -> Handler Html-enableGitLab = promptGitLab . Just . toGitLabUrl
Assistant/WebApp/Configurators/WebDAV.hs view
@@ -30,9 +30,6 @@ webDAVConfigurator :: Widget -> Handler Html webDAVConfigurator = page "Add a WebDAV repository" (Just Configuration) -boxConfigurator :: Widget -> Handler Html-boxConfigurator = page "Add a Box.com repository" (Just Configuration)- data WebDAVInput = WebDAVInput 	{ user :: Text 	, password :: Text@@ -44,14 +41,6 @@ toCredPair :: WebDAVInput -> CredPair toCredPair input = (T.unpack $ user input, T.unpack $ password input) -boxComAForm :: Maybe CredPair -> MkAForm WebDAVInput-boxComAForm defcreds = WebDAVInput-	<$> areq textField (bfs "Username or Email") (T.pack . fst <$> defcreds)-	<*> areq passwordField (bfs "Box.com Password") (T.pack . snd <$> defcreds)-	<*> areq checkBoxField "Share this account with other devices and friends?" (Just True)-	<*> areq textField (bfs "Directory") (Just "annex")-	<*> enableEncryptionField- webDAVCredsAForm :: Maybe CredPair -> MkAForm WebDAVInput webDAVCredsAForm defcreds = WebDAVInput 	<$> areq textField (bfs "Username or Email") (T.pack . fst <$> defcreds)@@ -60,32 +49,6 @@ 	<*> pure T.empty 	<*> pure NoEncryption -- not used! -getAddBoxComR :: Handler Html-getAddBoxComR = postAddBoxComR-postAddBoxComR :: Handler Html-#ifdef WITH_WEBDAV-postAddBoxComR = boxConfigurator $ do-	defcreds <- liftAnnex $ previouslyUsedWebDAVCreds "box.com"-	((result, form), enctype) <- liftH $-		runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout-			$ boxComAForm defcreds-	case result of-		FormSuccess input -> liftH $ -			makeWebDavRemote initSpecialRemote "box.com" (toCredPair input) $ M.fromList-				[ configureEncryption $ enableEncryption input-				, ("embedcreds", if embedCreds input then "yes" else "no")-				, ("type", "webdav")-				, ("url", "https://dav.box.com/dav/" ++ T.unpack (directory input))-				-- Box.com has a max file size of 100 mb, but-				-- using smaller chunks has better memory-				-- performance.-				, ("chunk", "10mb")-				]-		_ -> $(widgetFile "configurators/addbox.com")-#else-postAddBoxComR = giveup "WebDAV not supported by this build"-#endif- getEnableWebDAVR :: UUID -> Handler Html getEnableWebDAVR = postEnableWebDAVR postEnableWebDAVR :: UUID -> Handler Html@@ -101,11 +64,7 @@ 	case mcreds of 		Just creds -> webDAVConfigurator $ liftH $ 			makeWebDavRemote enableSpecialRemote name creds M.empty-		Nothing-			| "box.com/" `isInfixOf` url ->-				boxConfigurator $ showform name url-			| otherwise ->-				webDAVConfigurator $ showform name url+		Nothing -> webDAVConfigurator $ showform name url   where 	showform name url = do 		defcreds <- liftAnnex $
Assistant/WebApp/DashBoard.hs view
@@ -44,7 +44,7 @@ 	isrunning info = not $ 		transferPaused info || isNothing (startedTime info) 	desc transfer info = case associatedFile info of-		AssociatedFile Nothing -> key2file $ transferKey transfer+		AssociatedFile Nothing -> serializeKey $ transferKey transfer 		AssociatedFile (Just af) -> af  {- Simplifies a list of transfers, avoiding display of redundant
Assistant/WebApp/routes view
@@ -55,8 +55,6 @@ /config/repository/add/cloud/S3 AddS3R GET POST /config/repository/add/cloud/IA AddIAR GET POST /config/repository/add/cloud/glacier AddGlacierR GET POST-/config/repository/add/cloud/box.com AddBoxComR GET POST-/config/repository/add/cloud/gitlab.com AddGitLabR GET POST  /config/repository/pair/local/start StartLocalPairR GET POST /config/repository/pair/local/running/#SecretReminder RunningLocalPairR GET
Backend.hs view
@@ -29,6 +29,7 @@ import qualified Backend.URL  import qualified Data.Map as M+import qualified Data.ByteString.Char8 as S8  list :: [Backend] list = Backend.Hash.backends ++ Backend.WORM.backends ++ Backend.URL.backends@@ -46,7 +47,7 @@ 		Annex.changeState $ \s -> s { Annex.backend = Just b } 		return b 	valid name = not (null name)-	lookupname = lookupBackendVariety . parseKeyVariety+	lookupname = lookupBackendVariety . parseKeyVariety . encodeBS  {- Generates a key for a file. -} genKey :: KeySource -> Maybe Backend -> Annex (Maybe (Key, Backend))@@ -57,7 +58,7 @@ 		Just k -> Just (makesane k, b)   where 	-- keyNames should not contain newline characters.-	makesane k = k { keyName = map fixbadchar (keyName k) }+	makesane k = k { keyName = S8.map fixbadchar (keyName k) } 	fixbadchar c 		| c == '\n' = '_' 		| otherwise = c@@ -66,7 +67,7 @@ getBackend file k = case maybeLookupBackendVariety (keyVariety k) of 	Just backend -> return $ Just backend 	Nothing -> do-		warning $ "skipping " ++ file ++ " (unknown backend " ++ formatKeyVariety (keyVariety k) ++ ")"+		warning $ "skipping " ++ file ++ " (unknown backend " ++ decodeBS (formatKeyVariety (keyVariety k)) ++ ")" 		return Nothing  {- Looks up the backend that should be used for a file.@@ -75,7 +76,7 @@ chooseBackend :: FilePath -> Annex (Maybe Backend) chooseBackend f = Annex.getState Annex.forcebackend >>= go   where-	go Nothing = maybeLookupBackendVariety . parseKeyVariety+	go Nothing = maybeLookupBackendVariety . parseKeyVariety . encodeBS 		<$> checkAttr "annex.backend" f 	go (Just _) = Just <$> defaultBackend @@ -83,7 +84,7 @@ lookupBackendVariety :: KeyVariety -> Backend lookupBackendVariety v = fromMaybe unknown $ maybeLookupBackendVariety v   where-	unknown = giveup $ "unknown backend " ++ formatKeyVariety v+	unknown = giveup $ "unknown backend " ++ decodeBS (formatKeyVariety v)  maybeLookupBackendVariety :: KeyVariety -> Maybe Backend maybeLookupBackendVariety v = M.lookup v varietyMap
Backend/Hash.hs view
@@ -1,11 +1,12 @@ {- git-annex hashing backends  -- - Copyright 2011-2018 Joey Hess <id@joeyh.name>+ - Copyright 2011-2019 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}  {-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}  module Backend.Hash ( 	backends,@@ -19,6 +20,8 @@ import Types.KeySource import Utility.Hash +import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import Data.Char @@ -71,15 +74,15 @@ 	}  hashKeyVariety :: Hash -> HasExt -> KeyVariety-hashKeyVariety MD5Hash = MD5Key-hashKeyVariety SHA1Hash = SHA1Key-hashKeyVariety (SHA2Hash size) = SHA2Key size-hashKeyVariety (SHA3Hash size) = SHA3Key size-hashKeyVariety (SkeinHash size) = SKEINKey size+hashKeyVariety MD5Hash he = MD5Key he+hashKeyVariety SHA1Hash he = SHA1Key he+hashKeyVariety (SHA2Hash size) he = SHA2Key size he+hashKeyVariety (SHA3Hash size) he = SHA3Key size he+hashKeyVariety (SkeinHash size) he = SKEINKey size he #if MIN_VERSION_cryptonite(0,23,0)-hashKeyVariety (Blake2bHash size) = Blake2bKey size-hashKeyVariety (Blake2sHash size) = Blake2sKey size-hashKeyVariety (Blake2spHash size) = Blake2spKey size+hashKeyVariety (Blake2bHash size) he = Blake2bKey size he+hashKeyVariety (Blake2sHash size) he = Blake2sKey size he+hashKeyVariety (Blake2spHash size) he = Blake2spKey size he #endif  {- A key is a hash of its contents. -}@@ -89,7 +92,7 @@ 	filesize <- liftIO $ getFileSize file 	s <- hashFile hash file 	return $ Just $ stubKey-		{ keyName = s+		{ keyName = encodeBS s 		, keyVariety = hashKeyVariety hash (HasExt False) 		, keySize = Just filesize 		}@@ -102,7 +105,7 @@ 		maxlen <- annexMaxExtensionLength <$> Annex.getGitConfig 		let ext = selectExtension maxlen (keyFilename source) 		return $ Just $ k-			{ keyName = keyName k ++ ext+			{ keyName = keyName k <> encodeBS ext 			, keyVariety = hashKeyVariety hash (HasExt True) 			} @@ -132,7 +135,7 @@ 			check <$> hashFile hash file 		_ -> return True   where-	expected = keyHash key+	expected = decodeBS (keyHash key) 	check s 		| s == expected = True 		{- A bug caused checksums to be prefixed with \ in some@@ -145,8 +148,8 @@ 		warning $ "hardware fault: " ++ show e 		return False -keyHash :: Key -> String-keyHash key = dropExtensions (keyName key)+keyHash :: Key -> S.ByteString+keyHash = fst . splitKeyNameExtension  validInExtension :: Char -> Bool validInExtension c@@ -163,8 +166,8 @@  -} needsUpgrade :: Key -> Bool needsUpgrade key = or-	[ "\\" `isPrefixOf` keyHash key-	, any (not . validInExtension) (takeExtensions $ keyName key)+	[ "\\" `S8.isPrefixOf` keyHash key+	, any (not . validInExtension) (decodeBS $ snd $ splitKeyNameExtension key) 	, not (hasExt (keyVariety key)) && keyHash key /= keyName key 	] @@ -184,7 +187,7 @@ 		AssociatedFile Nothing -> Nothing 		AssociatedFile (Just file) -> Just $ oldkey 			{ keyName = keyHash oldkey -				++ selectExtension maxextlen file+				<> encodeBS (selectExtension maxextlen file) 			, keyVariety = newvariety 			} 	{- Upgrade to fix bad previous migration that created a@@ -285,5 +288,5 @@ 	let b = genBackendE (SHA2Hash (HashSize 256)) 	in b { getKey = (fmap addE) <$$> getKey b }    where-	addE k = k { keyName = keyName k ++ longext }+	addE k = k { keyName = keyName k <> longext } 	longext = ".this-is-a-test-key"
Backend/Utilities.hs view
@@ -1,6 +1,6 @@ {- git-annex backend utilities  -- - Copyright 2012 Joey Hess <id@joeyh.name>+ - Copyright 2012-2019 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -8,20 +8,21 @@ module Backend.Utilities where  import Annex.Common-import Utility.FileSystemEncoding import Utility.Hash +import qualified Data.ByteString as S+ {- Generates a keyName from an input string. Takes care of sanitizing it.  - If it's not too long, the full string is used as the keyName.  - Otherwise, it's truncated, and its md5 is prepended to ensure a unique  - key. -}-genKeyName :: String -> String+genKeyName :: String -> S.ByteString genKeyName s 	-- Avoid making keys longer than the length of a SHA256 checksum.-	| bytelen > sha256len =+	| bytelen > sha256len = encodeBS' $ 		truncateFilePath (sha256len - md5len - 1) s' ++ "-" ++ -			show (md5 (encodeBS s))-	| otherwise = s'+			show (md5 (encodeBL s))+	| otherwise = encodeBS' s'   where 	s' = preSanitizeKeyName s 	bytelen = length (decodeW8 s')
Backend/WORM.hs view
@@ -14,6 +14,8 @@ import Backend.Utilities import Git.FilePath +import qualified Data.ByteString.Char8 as S8+ backends :: [Backend] backends = [backend] @@ -45,12 +47,12 @@  {- Old WORM keys could contain spaces, and can be upgraded to remove them. -} needsUpgrade :: Key -> Bool-needsUpgrade key = ' ' `elem` keyName key+needsUpgrade key = ' ' `S8.elem` keyName key  removeSpaces :: Key -> Backend -> AssociatedFile -> Annex (Maybe Key) removeSpaces oldkey newbackend _ 	| migratable = return $ Just $ oldkey-		{ keyName = reSanitizeKeyName (keyName oldkey) }+		{ keyName = encodeBS $ reSanitizeKeyName $ decodeBS $ keyName oldkey } 	| otherwise = return Nothing   where 	migratable = oldvariety == newvariety
+ Benchmark.hs view
@@ -0,0 +1,53 @@+{- git-annex benchmark infrastructure+ -+ - Copyright 2019 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module Benchmark where++import Common+import Types.Benchmark+import Types.Command+import CmdLine.Action+import CmdLine+import CmdLine.GitAnnex.Options+import qualified Annex+import qualified Annex.Branch+import Annex.Action++import qualified Options.Applicative as O++{- Given a list of all git-annex Commands, and the user's input,+ - generates an IO action to benchmark that runs the specified+ - commands. -}+mkGenerator :: MkBenchmarkGenerator+mkGenerator cmds userinput = do+	-- Get the git-annex branch updated, to avoid the overhead of doing+	-- so skewing the runtime of the first action that will be+	-- benchmarked.+	Annex.Branch.commit "benchmarking"+	Annex.Branch.update+	l <- mapM parsesubcommand $ split [";"] userinput+	return $ do+		forM_ l $ \(cmd, seek, st) ->+			-- The cmd is run for benchmarking without startup or+			-- shutdown actions.+			Annex.eval st $ performCommandAction cmd seek noop+		-- Since the cmd will be run many times, some zombie+		-- processes that normally only occur once per command+		-- will build up; reap them.+		reapZombies+  where+	-- Simplified versio of CmdLine.dispatch, without support for fuzzy+	-- matching or out-of-repo commands.+	parsesubcommand ps = do+		(cmd, seek, globalconfig) <- liftIO $ O.handleParseResult $+			parseCmd "git-annex" "benchmarking" gitAnnexGlobalOptions ps cmds cmdparser+		-- Make an entirely separate Annex state for each subcommand,+		-- and prepare it to run the cmd.+		st <- liftIO . Annex.new =<< Annex.getState Annex.repo+		((), st') <- liftIO $ Annex.run st $+			prepRunCommand cmd globalconfig+		return (cmd, seek, st')
CHANGELOG view
@@ -1,3 +1,52 @@+git-annex (7.20190122) upstream; urgency=medium++  * sync --content: Fix dropping unwanted content from the local repository.+  * sync --content: Support dropping local content that has reached an+    exporttree remote that is not untrusted (currently only S3 remotes+    with versioning).+  * init: When --version=5 is passed on a crippled filesystem,+    use a v5 direct mode repo as requested, rather than upgrading to v7+    adjusted unlocked. (Fixes test suite on crippled filesystems.)+  * Some optimisations, including a 10x faster timestamp parser,+    a 7x faster key parser, and improved parsing and serialization of+    git-annex branch data. Many commands will run 5-15% faster.+  * Stricter parser for keys doesn't allow doubled fields or out of order fields.+  * The benchmark command, which only had some old benchmarking of the sqlite+    databases before, now allows benchmarking any other git-annex commands.+  * Support being built with ghc 8.6.3 (MonadFail).+  * Removed old code that cleaned up after a bug in git-annex versions+    3.20111105-3.20111110. In the unlikely event that a repo was+    last touched by that ancient git-annex version, the descriptions+    of remotes would appear missing when used with this version of+    git-annex.+  * Improve uuid.log parser to preserve whitespace in repo descriptions.+  * Improve activity.log parser to not remove unknown values,+    allowing for future expansion.+  * addunused, merge, assistant: Avoid creating work tree files in+    subdirectories in an edge case where the key contains "/".+  * testremote: Support testing readonly remotes with the --test-readonly option.+  * Switch to using .git/annex/othertmp for tmp files other than partial+    downloads, and make stale files left in that directory when git-annex+    is interrupted be cleaned up promptly by subsequent git-annex processes.+  * The .git/annex/misctmp directory is no longer used and git-annex will+    delete anything lingering in there after it's 1 week old.+  * Estimated time to completion display shortened from eg "1h1m1s" to "1h1m".+  * Fix doubled progress display when downloading an url when -J is used.+  * unused: Update suggested git log message to see where data was previously+    used so it will also work with v7 unlocked pointer files.+  * importfeed: Better error message when downloading the feed fails.+  * Make test suite work better when the temp directory is on NFS.+  * webapp: Remove configurator for box.com repository, since their+    webdav support is going away at the end of this January.+  * webapp: Remove configurator for gitlab, which stopped supporting git-annex+    some time ago.+  * Android: For armv71 architecture, use the armel build.+  * Windows: If 64 bit git is installed, use it when installing git-annex.+    (However, rsync still won't work and this is still not the documented way+    to install it.)++ -- Joey Hess <id@joeyh.name>  Tue, 22 Jan 2019 12:25:26 -0400+ git-annex (7.20181211) upstream; urgency=medium    * S3: Improve diagnostics when a remote is configured with exporttree and
@@ -2,7 +2,7 @@ Source: native package  Files: *-Copyright: © 2010-2018 Joey Hess <id@joeyh.name>+Copyright: © 2010-2019 Joey Hess <id@joeyh.name> License: GPL-3+  Files: Assistant/WebApp.hs Assistant/WebApp/* templates/* static/*@@ -30,7 +30,7 @@ License: Expat  Files: Utility/*-Copyright: 2012-2018 Joey Hess <id@joeyh.name>+Copyright: 2012-2019 Joey Hess <id@joeyh.name> License: BSD-2-clause  Files: doc/logo* */favicon.ico standalone/osx/git-annex.app/Contents/Resources/git-annex.icns@@ -80,38 +80,6 @@   LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,   OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN   THE SOFTWARE.--Files: Logs/Line.hs-Copyright: 2001, The University Court of the University of Glasgow.-License: ghc-license-  All rights reserved.-  .-  Redistribution and use in source and binary forms, with or without-  modification, are permitted provided that the following conditions are met:-  .-  - Redistributions of source code must retain the above copyright notice,-  this list of conditions and the following disclaimer.-  .-  - Redistributions in binary form must reproduce the above copyright notice,-  this list of conditions and the following disclaimer in the documentation-  and/or other materials provided with the distribution.-  .-  - Neither name of the University nor the names of its contributors may be-  used to endorse or promote products derived from this software without-  specific prior written permission.-  .-  THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF-  GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,-  INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND-  FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE-  UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE-  FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL-  DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR-  SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER-  CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT-  LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY-  OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH-  DAMAGE.  License: GPL-3+  The full text of version 3 of the GPL is distributed as doc/license/GPL in
CmdLine.hs view
@@ -8,6 +8,8 @@ module CmdLine ( 	dispatch, 	usage,+	parseCmd,+	prepRunCommand, ) where  import qualified Options.Applicative as O@@ -39,13 +41,7 @@ 			(cmd, seek, globalconfig) <- parsewith False cmdparser 				(\a -> inRepo $ a . Just) 				(liftIO . O.handleParseResult)-			when (cmdnomessages cmd) $ do-				Annex.setOutput QuietOutput-				Annex.changeState $ \s -> s -					{ Annex.output = (Annex.output s) { implicitMessages = False } }-			getParsed globalconfig-			whenM (annexDebug <$> Annex.getGitConfig) $-				liftIO enableDebugOutput+			prepRunCommand cmd globalconfig 			startup 			performCommandAction cmd seek $ 				shutdown $ cmdnocommit cmd@@ -123,3 +119,13 @@ 	inexactcmds = case name of 		Nothing -> [] 		Just n -> Git.AutoCorrect.fuzzymatches n cmdname cmds++prepRunCommand :: Command -> GlobalSetter -> Annex ()+prepRunCommand cmd globalconfig = do+	when (cmdnomessages cmd) $ do+		Annex.setOutput QuietOutput+		Annex.changeState $ \s -> s +			{ Annex.output = (Annex.output s) { implicitMessages = False } }+	getParsed globalconfig+	whenM (annexDebug <$> Annex.getGitConfig) $+		liftIO enableDebugOutput
CmdLine/GitAnnex.hs view
@@ -1,6 +1,6 @@ {- git-annex main program  -- - Copyright 2010-2015 Joey Hess <id@joeyh.name>+ - Copyright 2010-2019 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -16,6 +16,7 @@ import Annex.Ssh import Annex.Multicast import Types.Test+import Types.Benchmark  import qualified Command.Help import qualified Command.Add@@ -119,12 +120,10 @@ import qualified Command.Test import qualified Command.FuzzTest import qualified Command.TestRemote-#ifdef WITH_BENCHMARK import qualified Command.Benchmark-#endif -cmds :: Parser TestOptions -> TestRunner -> [Command]-cmds testoptparser testrunner = +cmds :: Parser TestOptions -> TestRunner -> MkBenchmarkGenerator -> [Command]+cmds testoptparser testrunner mkbenchmarkgenerator =  	[ Command.Help.cmd 	, Command.Add.cmd 	, Command.Get.cmd@@ -228,16 +227,15 @@ 	, Command.Test.cmd testoptparser testrunner 	, Command.FuzzTest.cmd 	, Command.TestRemote.cmd-#ifdef WITH_BENCHMARK-	, Command.Benchmark.cmd-#endif+	, Command.Benchmark.cmd $+		mkbenchmarkgenerator $ cmds testoptparser testrunner (\_ _ -> return noop) 	] -run :: Parser TestOptions -> TestRunner -> [String] -> IO ()-run testoptparser testrunner args = go envmodes+run :: Parser TestOptions -> TestRunner -> MkBenchmarkGenerator -> [String] -> IO ()+run testoptparser testrunner mkbenchmarkgenerator args = go envmodes   where 	go [] = dispatch True args -		(cmds testoptparser testrunner)+		(cmds testoptparser testrunner mkbenchmarkgenerator) 		gitAnnexGlobalOptions [] Git.CurrentRepo.get 		"git-annex" 		"manage files with git, without checking their contents in"
CmdLine/GitAnnex/Options.hs view
@@ -210,7 +210,7 @@ 	)  parseKey :: Monad m => String -> m Key-parseKey = maybe (fail "invalid key") return . file2key+parseKey = maybe (fail "invalid key") return . deserializeKey  -- Options to match properties of annexed files. annexedMatchingOptions :: [GlobalOption]@@ -410,4 +410,4 @@ 		 completeBackends :: HasCompleter f => Mod f a completeBackends = completeWith $-	map (formatKeyVariety . Backend.backendVariety) Backend.list+	map (decodeBS . formatKeyVariety . Backend.backendVariety) Backend.list
CmdLine/Seek.hs view
@@ -158,7 +158,7 @@ withKeys :: (Key -> CommandSeek) -> CmdParams -> CommandSeek withKeys a l = seekActions $ return $ map (a . parse) l   where-	parse p = fromMaybe (giveup "bad key") $ file2key p+	parse p = fromMaybe (giveup "bad key") $ deserializeKey p  withNothing :: CommandSeek -> CmdParams -> CommandSeek withNothing a [] = a
Command/Add.hs view
@@ -150,7 +150,7 @@  cleanup :: Key -> Bool -> CommandCleanup cleanup key hascontent = do-	maybeShowJSON $ JSONChunk [("key", key2file key)]+	maybeShowJSON $ JSONChunk [("key", serializeKey key)] 	when hascontent $ 		logStatus key InfoPresent 	return True
Command/AddUnused.hs view
@@ -32,7 +32,7 @@ 	addLink file key Nothing 	return True   where-	file = "unused." ++ key2file key+	file = "unused." ++ keyFile key  {- The content is not in the annex, but in another directory, and  - it seems better to error out, rather than moving bad/tmp content into
Command/AddUrl.hs view
@@ -28,7 +28,6 @@ import Annex.FileMatcher import Logs.Location import Utility.Metered-import Utility.FileSystemEncoding import Utility.HtmlDetect import Utility.Path.Max import qualified Annex.Transfer as Transfer@@ -401,7 +400,7 @@ 			else void $ Command.Add.addSmall file   where 	go = do-		maybeShowJSON $ JSONChunk [("key", key2file key)]+		maybeShowJSON $ JSONChunk [("key", serializeKey key)] 		setUrlPresent key url 		logChange key u InfoPresent 		ifM (addAnnexedFile file key mtmp)
Command/Benchmark.hs view
@@ -1,123 +1,49 @@ {- git-annex benchmark  -- - Copyright 2016 Joey Hess <id@joeyh.name>+ - Copyright 2016-2019 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -} -{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE CPP #-}  module Command.Benchmark where  import Command-import Database.Types-import qualified Database.Keys.SQL as SQL-import qualified Database.Queue as H-import Utility.Tmp-import Git.FilePath+import Types.Benchmark +#ifdef WITH_BENCHMARK import Criterion.Main-import Criterion.Internal (runAndAnalyse)-import Criterion.Monad-import Control.Monad.IO.Class (liftIO)-import Control.Monad-import Control.DeepSeq-import System.FilePath-import System.Random--cmd :: Command-cmd = noRepo (withParams benchmark) $-	dontCheck repoExists $-		command "benchmark" SectionTesting-			"run benchmarks"-			paramNothing-			(withParams (liftIO . benchmark))--benchmark :: CmdParams -> IO ()-benchmark _ = withTmpDirIn "." "benchmark" $ \tmpdir -> do-	-- benchmark different sizes of databases-	dbs <- mapM (benchDb tmpdir)-		[ 1000-		, 10000-		-- , 100000-		]-	runCriterion $-		bgroup "keys database" $ flip concatMap dbs $ \db ->-			[ getAssociatedFilesHitBench db-			, getAssociatedFilesMissBench db-			, getAssociatedKeyHitBench db-			, getAssociatedKeyMissBench db-			, addAssociatedFileOldBench db-			, addAssociatedFileNewBench db-			]--getAssociatedFilesHitBench :: BenchDb -> Benchmark-getAssociatedFilesHitBench ( BenchDb h num) = bench ("getAssociatedFiles from " ++ show num ++ " (hit)") $ nfIO $ do-	n <- getStdRandom (randomR (1,num))-	SQL.getAssociatedFiles (keyN n) (SQL.ReadHandle h)--getAssociatedFilesMissBench :: BenchDb -> Benchmark-getAssociatedFilesMissBench ( BenchDb h num) = bench ("getAssociatedFiles from " ++ show num ++ " (miss)") $ nfIO $-	SQL.getAssociatedFiles keyMiss (SQL.ReadHandle h)--getAssociatedKeyHitBench :: BenchDb -> Benchmark-getAssociatedKeyHitBench (BenchDb h num) = bench ("getAssociatedKey from " ++ show num ++ " (hit)") $ nfIO $ do-	n <- getStdRandom (randomR (1,num))-	SQL.getAssociatedKey (fileN n) (SQL.ReadHandle h)--getAssociatedKeyMissBench :: BenchDb -> Benchmark-getAssociatedKeyMissBench (BenchDb h num) = bench ("getAssociatedKey from " ++ show num ++ " (miss)") $ nfIO $-	SQL.getAssociatedKey fileMiss (SQL.ReadHandle h)--addAssociatedFileOldBench :: BenchDb -> Benchmark-addAssociatedFileOldBench ( BenchDb h num) = bench ("addAssociatedFile to " ++ show num ++ " (old)") $ nfIO $ do-	n <- getStdRandom (randomR (1,num))-	SQL.addAssociatedFile (keyN n) (fileN n) (SQL.WriteHandle h)-	H.flushDbQueue h--addAssociatedFileNewBench :: BenchDb -> Benchmark-addAssociatedFileNewBench ( BenchDb h num) = bench ("addAssociatedFile to " ++ show num ++ " (new)") $ nfIO $ do-	n <- getStdRandom (randomR (1,num))-	SQL.addAssociatedFile (keyN n) (fileN (n+1)) (SQL.WriteHandle h)-	H.flushDbQueue h--populateAssociatedFiles :: H.DbQueue -> Int -> IO ()-populateAssociatedFiles h num = do-	forM_ [1..num] $ \n ->-		SQL.addAssociatedFile (keyN n) (fileN n) (SQL.WriteHandle h)-	H.flushDbQueue h--keyN :: Int -> IKey-keyN n = IKey ("key" ++ show n)--fileN :: Int -> TopFilePath-fileN n = asTopFilePath ("file" ++ show n)--keyMiss :: IKey-keyMiss = keyN 0 -- 0 is never stored+import Criterion.Main.Options (parseWith, Mode)+#endif -fileMiss :: TopFilePath-fileMiss = fileN 0 -- 0 is never stored+cmd :: BenchmarkGenerator -> Command+cmd generator = command "benchmark" SectionTesting+	"benchmark git-annex commands"+	paramNothing+	(seek generator <$$> optParser) -data BenchDb = BenchDb H.DbQueue Int+#ifndef WITH_BENCHMARK+type Mode = ()+#endif -benchDb :: FilePath -> Int -> IO BenchDb-benchDb tmpdir num = do-	putStrLn $ "setting up database with " ++ show num-	H.initDb f SQL.createTables-	h <- H.openDbQueue f SQL.containedTable-	populateAssociatedFiles h num-	return (BenchDb h num)-  where-	f = tmpdir </> "db" ++ show num+data BenchmarkOptions = BenchmarkOptions CmdParams Mode -instance NFData TopFilePath where-	rnf = rnf . getTopFilePath+optParser :: CmdParamsDesc -> Parser BenchmarkOptions+optParser desc = BenchmarkOptions+	<$> cmdParams desc+#ifdef WITH_BENCHMARK+	-- parse criterion's options+	<*> parseWith defaultConfig+#else+	<*> pure ()+#endif -instance NFData IKey where-	rnf (IKey s) = rnf s-	--- can't use Criterion's defaultMain here because it looks at--- command-line parameters-runCriterion :: Benchmark -> IO ()-runCriterion = withConfig defaultConfig . runAndAnalyse (const True)+seek :: BenchmarkGenerator -> BenchmarkOptions -> CommandSeek+#ifdef WITH_BENCHMARK+seek generator (BenchmarkOptions ps mode) = do+	runner <- generator ps+	liftIO $ runMode mode [ bench (unwords ps) $ nfIO runner ]+#else+seek _ _ = giveup "git-annex is not built with benchmarking support"+#endif
Command/CalcKey.hs view
@@ -14,13 +14,13 @@ cmd :: Command cmd = noCommit $ noMessages $ dontCheck repoExists $ 	command "calckey" SectionPlumbing -		"calculates the key that would be used to refer to a file"+		"calulate key for a file" 		(paramRepeating paramFile) 		(batchable run (pure ()))  run :: () -> String -> Annex Bool run _ file = genKey (KeySource file file Nothing) Nothing >>= \case 	Just (k, _) -> do-		liftIO $ putStrLn $ key2file k+		liftIO $ putStrLn $ serializeKey k 		return True 	Nothing -> return False
Command/CheckPresentKey.hs view
@@ -69,7 +69,7 @@ batchResult _ = liftIO $ putStrLn "0"  toKey :: String -> Key-toKey = fromMaybe (giveup "Bad key") . file2key+toKey = fromMaybe (giveup "Bad key") . deserializeKey  toRemote :: String -> Annex Remote toRemote rn = maybe (giveup "Unknown remote") return
Command/ContentLocation.hs view
@@ -19,7 +19,7 @@  run :: () -> String -> Annex Bool run _ p = do-	let k = fromMaybe (giveup "bad key") $ file2key p+	let k = fromMaybe (giveup "bad key") $ deserializeKey p 	maybe (return False) (\f -> liftIO (putStrLn f) >> return True) 		=<< inAnnex' (pure True) Nothing check k   where
Command/Dead.hs view
@@ -33,7 +33,7 @@  startKey :: Key -> CommandStart startKey key = do-	showStart' "dead" (Just $ key2file key)+	showStart' "dead" (Just $ serializeKey key) 	keyLocations key >>= \case 		[] -> next $ performKey key 		_ -> giveup "This key is still known to be present in some locations; not marking as dead."
Command/Describe.hs view
@@ -29,5 +29,5 @@  perform :: UUID -> String -> CommandPerform perform u description = do-	describeUUID u description+	describeUUID u (toUUIDDesc description) 	next $ return True
Command/DiffDriver.hs view
@@ -88,7 +88,7 @@ 	check getfile getmode setfile r = case readTreeItemType (getmode r) of 		Just TreeSymlink -> do 			v <- getAnnexLinkTarget' (getfile r) False-			case fileKey . takeFileName =<< v of+			case parseLinkTargetOrPointer =<< v of 				Nothing -> return r 				Just k -> setfile r <$> 					withObjectLoc k
Command/DropKey.hs view
@@ -38,7 +38,7 @@ 		Batch fmt -> batchInput fmt parsekey $ batchCommandAction . start 		NoBatch -> noop   where-	parsekey = maybe (Left "bad key") Right . file2key+	parsekey = maybe (Left "bad key") Right . deserializeKey  start :: Key -> CommandStart start key = do
Command/EnableRemote.hs view
@@ -100,7 +100,9 @@ unknownNameError :: String -> Annex a unknownNameError prefix = do 	m <- Annex.SpecialRemote.specialRemoteMap-	descm <- M.unionWith Remote.addName <$> uuidMap <*> pure m+	descm <- M.unionWith Remote.addName+		<$> uuidDescMap+		<*> pure (M.map toUUIDDesc m) 	specialmsg <- if M.null m 			then pure "(No special remotes are currently known; perhaps use initremote instead?)" 			else Remote.prettyPrintUUIDsDescs
Command/ExamineKey.hs view
@@ -21,6 +21,6 @@  run :: Maybe Utility.Format.Format -> String -> Annex Bool run format p = do-	let k = fromMaybe (giveup "bad key") $ file2key p-	showFormatted format (key2file k) (keyVars k)+	let k = fromMaybe (giveup "bad key") $ deserializeKey p+	showFormatted format (serializeKey k) (keyVars k) 	return True
Command/Expire.hs view
@@ -51,11 +51,11 @@ 	expire <- parseExpire (expireParams o) 	actlog <- lastActivities (activityOption o) 	u <- getUUID-	us <- filter (/= u) . M.keys <$> uuidMap-	descs <- uuidMap+	us <- filter (/= u) . M.keys <$> uuidDescMap+	descs <- uuidDescMap 	commandActions $ map (start expire (noActOption o) actlog descs) us -start :: Expire -> Bool -> Log Activity -> M.Map UUID String -> UUID -> CommandStart+start :: Expire -> Bool -> Log Activity -> UUIDDescMap -> UUID -> CommandStart start (Expire expire) noact actlog descs u = 	case lastact of 		Just ent | notexpired ent -> checktrust (== DeadTrusted) $ do@@ -75,7 +75,7 @@ 			d <- liftIO $ durationSince $ posixSecondsToUTCTime c 			return $ "last active: " ++ fromDuration d ++ " ago" 		_  -> return "no activity"-	desc = fromUUID u ++ " " ++ fromMaybe "" (M.lookup u descs)+	desc = fromUUID u ++ " " ++ fromUUIDDesc (fromMaybe mempty (M.lookup u descs)) 	notexpired ent = case ent of 		Unknown -> False 		VectorClock c -> case lookupexpire of
Command/Export.hs view
@@ -66,7 +66,7 @@ -- to a stable temporary name based on the key. exportTempName :: ExportKey -> ExportLocation exportTempName ek = mkExportLocation $ -	".git-annex-tmp-content-" ++ key2file (asKey (ek))+	".git-annex-tmp-content-" ++ serializeKey (asKey (ek))  seek :: ExportOptions -> CommandSeek seek o = do
Command/Find.hs view
@@ -88,11 +88,11 @@  keyVars :: Key -> [(String, String)] keyVars key =-	[ ("key", key2file key)-	, ("backend", formatKeyVariety $ keyVariety key)+	[ ("key", serializeKey key)+	, ("backend", decodeBS $ formatKeyVariety $ keyVariety key) 	, ("bytesize", size show) 	, ("humansize", size $ roughSize storageUnits True)-	, ("keyname", keyName key)+	, ("keyname", decodeBS $ keyName key) 	, ("hashdirlower", hashDirLower def key) 	, ("hashdirmixed", hashDirMixed def key) 	, ("mtime", whenavail show $ keyMtime key)
Command/FromKey.hs view
@@ -79,7 +79,7 @@ mkKey s = case parseURI s of 	Just u | not (isKeyPrefix (uriScheme u)) -> 		Backend.URL.fromUrl s Nothing-	_ -> case file2key s of+	_ -> case deserializeKey s of 		Just k -> k 		Nothing -> giveup $ "bad key/url " ++ s
Command/Fsck.hs view
@@ -205,8 +205,7 @@ check :: [Annex Bool] -> Annex Bool check cs = and <$> sequence cs -{- Checks that symlinks points correctly to the annexed content.- -}+{- Checks that symlinks points correctly to the annexed content. -} fixLink :: Key -> FilePath -> Annex Bool fixLink key file = do 	want <- calcRepo $ gitAnnexLink file key@@ -215,7 +214,7 @@ 	return True   where 	go want have-		| want /= fromInternalGitPath have = do+		| want /= fromInternalGitPath (fromRawFilePath have) = do 			showNote "fixing link" 			liftIO $ createDirectoryIfMissing True (parentDir file) 			liftIO $ removeFile file@@ -250,7 +249,7 @@ 	 - config was set. -} 	when (present && not (cryptographicallySecure (keyVariety key))) $ 		whenM (annexSecureHashesOnly <$> Annex.getGitConfig) $-			warning $ "** Despite annex.securehashesonly being set, " ++ obj ++ " has content present in the annex using an insecure " ++ formatKeyVariety (keyVariety key) ++ " key"+			warning $ "** Despite annex.securehashesonly being set, " ++ obj ++ " has content present in the annex using an insecure " ++ decodeBS (formatKeyVariety (keyVariety key)) ++ " key"  	{- In direct mode, modified files will show up as not present, 	 - but that is expected and not something to do anything about. -}@@ -424,7 +423,7 @@ 				[ actionItemDesc ai key 				, ": Can be upgraded to an improved key format. " 				, "You can do so by running: git annex migrate --backend="-				, formatKeyVariety (keyVariety key) ++ " "+				, decodeBS (formatKeyVariety (keyVariety key)) ++ " " 				, file 				] 			return True@@ -498,7 +497,7 @@ checkKeyNumCopies :: Key -> AssociatedFile -> NumCopies -> Annex Bool checkKeyNumCopies key afile numcopies = do 	let (desc, hasafile) = case afile of-		AssociatedFile Nothing -> (key2file key, False)+		AssociatedFile Nothing -> (serializeKey key, False) 		AssociatedFile (Just af) -> (af, True) 	locs <- loggedLocations key 	(untrustedlocations, otherlocations) <- trustPartition UnTrusted locs@@ -562,7 +561,7 @@ badContentRemote :: Remote -> FilePath -> Key -> Annex String badContentRemote remote localcopy key = do 	bad <- fromRepo gitAnnexBadDir-	let destbad = bad </> key2file key+	let destbad = bad </> keyFile key 	movedbad <- ifM (inAnnex key <||> liftIO (doesFileExist destbad)) 		( return False 		, do
Command/Group.hs view
@@ -26,11 +26,13 @@ 	allowMessages 	showStart' "group" (Just name) 	u <- Remote.nameToUUID name-	next $ setGroup u g+	next $ setGroup u (toGroup g) start (name:[]) = do 	u <- Remote.nameToUUID name-	liftIO . putStrLn . unwords . S.toList =<< lookupGroups u+	liftIO . putStrLn . unwords . map fmt . S.toList =<< lookupGroups u 	stop+  where+	fmt (Group g) = decodeBS g start _ = giveup "Specify a repository and a group."  setGroup :: UUID -> Group -> CommandPerform
Command/GroupWanted.hs view
@@ -10,6 +10,7 @@ import Command import Logs.PreferredContent import Command.Wanted (performGet, performSet)+import Types.Group  cmd :: Command cmd = noMessages $ command "groupwanted" SectionSetup @@ -21,9 +22,9 @@ seek = withWords (commandAction . start)  start :: [String] -> CommandStart-start (g:[]) = next $ performGet groupPreferredContentMapRaw g+start (g:[]) = next $ performGet groupPreferredContentMapRaw (toGroup g) start (g:expr:[]) = do 	allowMessages 	showStart' "groupwanted" (Just g)-	next $ performSet groupPreferredContentSet expr g+	next $ performSet groupPreferredContentSet expr (toGroup g) start _ = giveup "Specify a group."
Command/Import.hs view
@@ -86,7 +86,7 @@ 		)   where 	deletedup k = do-		showNote $ "duplicate of " ++ key2file k+		showNote $ "duplicate of " ++ serializeKey k 		verifyExisting k destfile 			( do 				liftIO $ removeFile srcfile
Command/ImportFeed.hs view
@@ -6,6 +6,7 @@  -}  {-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}  module Command.ImportFeed where @@ -19,9 +20,7 @@ #if ! MIN_VERSION_time(1,5,0) import System.Locale #endif-#if MIN_VERSION_feed(1,0,0) import qualified Data.Text as T-#endif  import Command import qualified Annex@@ -75,9 +74,10 @@ 	next $ perform opts cache url  perform :: ImportFeedOptions -> Cache -> URLString -> CommandPerform-perform opts cache url = do-	v <- findDownloads url-	case v of+perform opts cache url = go =<< downloadFeed url+  where+	go Nothing = next $ feedProblem url "downloading the feed failed"+	go (Just f) = case findDownloads url f of 		[] -> next $ 			feedProblem url "bad feed content; no enclosures to download" 		l -> do@@ -123,25 +123,23 @@  knownItems :: (Key, URLString) -> Annex ([ItemId], URLString) knownItems (k, u) = do-	itemids <- S.toList . S.filter (/= noneValue) . S.map fromMetaValue +	itemids <- S.toList . S.filter (/= noneValue)+		. S.map (decodeBS . fromMetaValue) 		. currentMetaDataValues itemIdField  		<$> getCurrentMetaData k 	return (itemids, u) -findDownloads :: URLString -> Annex [ToDownload]-findDownloads u = go =<< downloadFeed u+findDownloads :: URLString -> Feed -> [ToDownload]+findDownloads u f = catMaybes $ map mk (feedItems f)   where-	go Nothing = pure []-	go (Just f) = catMaybes <$> mapM (mk f) (feedItems f)--	mk f i = case getItemEnclosure i of-		Just (enclosureurl, _, _) -> return $ +	mk i = case getItemEnclosure i of+		Just (enclosureurl, _, _) -> 			Just $ ToDownload f u i $ Enclosure $  				fromFeed enclosureurl 		Nothing -> case getItemLink i of-			Just link -> return $ Just $ ToDownload f u i $ +			Just link -> Just $ ToDownload f u i $  				MediaLink $ fromFeed link-			Nothing -> return Nothing+			Nothing -> Nothing  {- Feeds change, so a feed download cannot be resumed. -} downloadFeed :: URLString -> Annex (Maybe Feed)@@ -324,14 +322,14 @@ 	Just (Just d) -> unionMetaData meta (dateMetaData d meta) 	_ -> meta   where-	tometa (k, v) = (mkMetaFieldUnchecked k, S.singleton (toMetaValue v))+	tometa (k, v) = (mkMetaFieldUnchecked (T.pack k), S.singleton (toMetaValue (encodeBS v))) 	meta = MetaData $ M.fromList $ map tometa $ extractFields i  minimalMetaData :: ToDownload -> MetaData minimalMetaData i = case getItemId (item i) of 	(Nothing) -> emptyMetaData 	(Just (_, itemid)) -> MetaData $ M.singleton itemIdField -		(S.singleton $ toMetaValue $ fromFeed itemid)+		(S.singleton $ toMetaValue $ encodeBS $ fromFeed itemid)  {- Extract fields from the feed and item, that are both used as metadata,  - and to generate the filename. -}
Command/Info.hs view
@@ -102,7 +102,7 @@ cmd :: Command cmd = noCommit $ withGlobalOptions [jsonOptions, annexedMatchingOptions] $ 	command "info" SectionQuery-		"shows  information about the specified item or the repository as a whole"+		"information about an item or the repository" 		(paramRepeating paramItem) (seek <$$> optParser)  data InfoOptions = InfoOptions@@ -326,7 +326,7 @@ repo_list :: TrustLevel -> Stat repo_list level = stat n $ nojson $ lift $ do 	us <- filter (/= NoUUID) . M.keys -		<$> (M.union <$> uuidMap <*> remoteMap Remote.name)+		<$> (M.union <$> (M.map fromUUIDDesc <$> uuidDescMap) <*> remoteMap Remote.name) 	rs <- fst <$> trustPartition level us 	countRepoList (length rs) 		-- This also handles json display.@@ -410,7 +410,7 @@ key_size k = simpleStat "size" $ showSizeKeys $ foldKeys [k]  key_name :: Key -> Stat-key_name k = simpleStat "key" $ pure $ key2file k+key_name k = simpleStat "key" $ pure $ serializeKey k  content_present :: Key -> Stat content_present k = stat "present" $ json boolConfig $ lift $ inAnnex k@@ -456,7 +456,7 @@ 		[ ("transfer", toJSON' (formatDirection (transferDirection t))) 		, ("key", toJSON' (transferKey t)) 		, ("file", toJSON' afile)-		, ("remote", toJSON' (fromUUID (transferUUID t)))+		, ("remote", toJSON' (fromUUID (transferUUID t) :: String)) 		] 	  where 		AssociatedFile afile = associatedFile i@@ -481,7 +481,7 @@  backend_usage :: Stat backend_usage = stat "backend usage" $ json fmt $-	ObjectMap . (M.mapKeys formatKeyVariety) . backendsKeys+	ObjectMap . (M.mapKeys (decodeBS . formatKeyVariety)) . backendsKeys 		<$> cachedReferencedData   where 	fmt = multiLine . map (\(b, n) -> b ++ ": " ++ show n) . sort . M.toList . fromObjectMap
Command/InitRemote.hs view
@@ -59,6 +59,6 @@  cleanup :: UUID -> String -> R.RemoteConfig -> CommandCleanup cleanup u name c = do-	describeUUID u name+	describeUUID u (toUUIDDesc name) 	Logs.Remote.configSet u c 	return True
Command/List.hs view
@@ -61,10 +61,10 @@ 		let l = (hereu, "here", heretrust) : zip3 (map uuid rs) (map name rs) ts 		return $ filter (\(_, _, t) -> t /= DeadTrusted) l  	getAllUUIDs = do-		rs <- M.toList <$> uuidMap-		rs3 <- forM rs $ \(u, n) -> (,,)+		rs <- M.toList <$> uuidDescMap+		rs3 <- forM rs $ \(u, d) -> (,,) 			<$> pure u-			<*> pure n+			<*> pure (fromUUIDDesc d) 			<*> lookupTrust u 		return $ sortBy (comparing snd3) $ 			filter (\t -> thd3 t /= DeadTrusted) rs3
Command/LockContent.hs view
@@ -32,7 +32,7 @@ 		then exitSuccess 		else exitFailure   where-	k = fromMaybe (giveup "bad key") (file2key ks)+	k = fromMaybe (giveup "bad key") (deserializeKey ks) 	locksuccess = liftIO $ do 		putStrLn contentLockedMarker 		hFlush stdout
Command/Log.hs view
@@ -144,19 +144,19 @@  - as showLogIncremental. -} showLog :: (String -> Outputter) -> [RefChange] -> Annex () showLog outputter cs = forM_ cs $ \c -> do-	let keyname = key2file (changekey c)+	let keyname = serializeKey (changekey c) 	new <- S.fromList <$> loggedLocationsRef (newref c) 	old <- S.fromList <$> loggedLocationsRef (oldref c) 	sequence_ $ compareChanges (outputter keyname) 		[(changetime c, new, old)] -mkOutputter :: M.Map UUID String -> TimeZone -> LogOptions -> FilePath -> Outputter+mkOutputter :: UUIDDescMap -> TimeZone -> LogOptions -> FilePath -> Outputter mkOutputter m zone o file 	| rawDateOption o = normalOutput lookupdescription file show 	| gourceOption o = gourceOutput lookupdescription file 	| otherwise = normalOutput lookupdescription file (showTimeStamp zone)   where-	lookupdescription u = fromMaybe (fromUUID u) $ M.lookup u m+	lookupdescription u = maybe (fromUUID u) (fromUUIDDesc) (M.lookup u m)  normalOutput :: (UUID -> String) -> FilePath -> (POSIXTime -> String) -> Outputter normalOutput lookupdescription file formattime logchange ts us =
Command/LookupKey.hs view
@@ -23,7 +23,7 @@ 	Nothing -> return False 	Just file' -> catKeyFile file' >>= \case 		Just k  -> do-			liftIO $ putStrLn $ key2file k+			liftIO $ putStrLn $ serializeKey k 			return True 		Nothing -> return False
Command/Map.hs view
@@ -43,7 +43,7 @@ start = do 	rs <- combineSame <$> (spider =<< gitRepo) -	umap <- uuidMap+	umap <- uuidDescMap 	trustmap <- trustMapLoad 		 	file <- (</>) <$> fromRepo gitAnnexDir <*> pure "map.dot"@@ -79,7 +79,7 @@  - the repositories first, followed by uuids that were not matched  - to a repository.  -}-drawMap :: [RepoRemotes] -> TrustMap -> M.Map UUID String -> String+drawMap :: [RepoRemotes] -> TrustMap -> UUIDDescMap -> String drawMap rs trustmap umap = Dot.graph $ repos ++ others   where 	repos = map (node umap (map fst rs) trustmap) rs@@ -88,7 +88,9 @@ 		filter (\u -> M.lookup u trustmap /= Just DeadTrusted) $ 		filter (`notElem` ruuids) (M.keys umap) 	uuidnode u = trustDecorate trustmap u $-		Dot.graphNode (fromUUID u) $ M.findWithDefault "" u umap+		Dot.graphNode+			(fromUUID u)+			(fromUUIDDesc $ M.findWithDefault mempty u umap)  hostname :: Git.Repo -> String hostname r@@ -100,10 +102,10 @@  {- A name to display for a repo. Uses the name from uuid.log if available,  - or the remote name if not. -}-repoName :: M.Map UUID String -> Git.Repo -> String+repoName :: UUIDDescMap -> Git.Repo -> String repoName umap r 	| repouuid == NoUUID = fallback-	| otherwise = M.findWithDefault fallback repouuid umap+	| otherwise = maybe fallback fromUUIDDesc $ M.lookup repouuid umap   where 	repouuid = getUncachedUUID r 	fallback = fromMaybe "unknown" $ Git.remoteName r@@ -113,10 +115,10 @@ nodeId r = 	case getUncachedUUID r of 		NoUUID -> Git.repoLocation r-		UUID u -> u+		u@(UUID _) -> fromUUID u  {- A node representing a repo. -}-node :: M.Map UUID String -> [Git.Repo] -> TrustMap -> RepoRemotes -> String+node :: UUIDDescMap -> [Git.Repo] -> TrustMap -> RepoRemotes -> String node umap fullinfo trustmap (r, rs) = unlines $ n:edges   where 	n = Dot.subGraph (hostname r) (basehostname r) "lightblue" $@@ -125,7 +127,7 @@ 	edges = map (edge umap fullinfo r) rs  {- An edge between two repos. The second repo is a remote of the first. -}-edge :: M.Map UUID String -> [Git.Repo] -> Git.Repo -> Git.Repo -> String	+edge :: UUIDDescMap -> [Git.Repo] -> Git.Repo -> Git.Repo -> String	 edge umap fullinfo from to = 	Dot.graphEdge (nodeId from) (nodeId fullto) edgename   where
Command/MetaData.hs view
@@ -20,6 +20,7 @@ import qualified Data.Set as S import qualified Data.Map as M import qualified Data.Text as T+import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy.UTF8 as BU import Control.Concurrent @@ -45,7 +46,7 @@ 	<*> optional parseKeyOptions 	<*> parseBatchOption   where-	getopt = option (eitherReader mkMetaField)+	getopt = option (eitherReader (mkMetaField . T.pack)) 		( long "get" <> short 'g' <> metavar paramField 		<> help "get single metadata field" 		)@@ -53,15 +54,15 @@ 		( long "set" <> short 's' <> metavar "FIELD[+-]=VALUE" 		<> help "set or unset metadata value" 		)-		<|> (AddMeta tagMetaField . toMetaValue <$> strOption+		<|> (AddMeta tagMetaField . toMetaValue . encodeBS <$> strOption 			( long "tag" <> short 't' <> metavar "TAG" 			<> help "set a tag" 			))-		<|> (DelMeta tagMetaField . Just . toMetaValue <$> strOption+		<|> (DelMeta tagMetaField . Just . toMetaValue . encodeBS <$> strOption 			( long "untag" <> short 'u' <> metavar "TAG" 			<> help "remove a tag" 			))-		<|> option (eitherReader (\f -> DelMeta <$> mkMetaField f <*> pure Nothing))+		<|> option (eitherReader (\f -> DelMeta <$> mkMetaField (T.pack f) <*> pure Nothing)) 			( long "remove"  <> short 'r' <> metavar "FIELD" 			<> help "remove all values of a field" 			)@@ -101,7 +102,7 @@ 	Get f -> do 		l <- S.toList . currentMetaDataValues f <$> getCurrentMetaData k 		liftIO $ forM_ l $-			putStrLn . fromMetaValue+			B8.putStrLn . fromMetaValue 		stop 	_ -> do 		showStartKey "metadata" k ai@@ -126,7 +127,7 @@ 	return True   where 	unwrapmeta (f, v) = (fromMetaField f, map fromMetaValue (S.toList v))-	showmeta (f, vs) = map ((f ++ "=") ++) vs+	showmeta (f, vs) = map ((T.unpack f ++ "=") ++) (map decodeBS vs)  -- Metadata serialized to JSON in the field named "fields" of -- a larger object.
Command/Multicast.hs view
@@ -208,7 +208,7 @@  storeReceived :: FilePath -> Annex () storeReceived f = do-	case file2key (takeFileName f) of+	case deserializeKey (takeFileName f) of 		Nothing -> do 			warning $ "Received a file " ++ f ++ " that is not a git-annex key. Deleting this file." 			liftIO $ nukeFile f
Command/PreCommit.hs view
@@ -29,6 +29,7 @@ import qualified Git.LsFiles as Git  import qualified Data.Set as S+import qualified Data.Text as T  cmd :: Command cmd = command "pre-commit" SectionPlumbing@@ -111,7 +112,7 @@ showMetaDataChange = showLongNote . unlines . concatMap showmeta . fromMetaData   where 	showmeta (f, vs) = map (showmetavalue f) $ S.toList vs-	showmetavalue f v = fromMetaField f ++ showset v ++ "=" ++ fromMetaValue v+	showmetavalue f v = T.unpack (fromMetaField f) <> showset v <> "=" <> decodeBS (fromMetaValue v) 	showset v 		| isSet v = "+" 		| otherwise = "-"
Command/Proxy.hs view
@@ -12,6 +12,7 @@ import Utility.Tmp.Dir import Utility.Env import Annex.Direct+import Annex.Tmp import qualified Git import qualified Git.Sha import qualified Git.Ref@@ -32,9 +33,7 @@ start :: [String] -> CommandStart start [] = giveup "Did not specify command to run." start (c:ps) = liftIO . exitWith =<< ifM isDirect-	( do-		tmp <- gitAnnexTmpMiscDir <$> gitRepo-		withTmpDirIn tmp "proxy" go+	( withOtherTmp $ \tmp -> withTmpDirIn tmp "proxy" go 	, liftIO $ safeSystem c (map Param ps) 	)   where
Command/ReKey.hs view
@@ -43,7 +43,7 @@ batchParser s = case separate (== ' ') (reverse s) of 	(rk, rf) 		| null rk || null rf -> Left "Expected: \"file key\""-		| otherwise -> case file2key (reverse rk) of+		| otherwise -> case deserializeKey (reverse rk) of 			Nothing -> Left "bad key" 			Just k -> Right (reverse rf, k) @@ -53,7 +53,7 @@ 	NoBatch -> withPairs (commandAction . start . parsekey) (reKeyThese o)   where 	parsekey (file, skey) =-		(file, fromMaybe (giveup "bad key") (file2key skey))+		(file, fromMaybe (giveup "bad key") (deserializeKey skey))  start :: (FilePath, Key) -> CommandStart start (file, newkey) = ifAnnexed file go stop
Command/ReadPresentKey.hs view
@@ -27,5 +27,5 @@ 		then liftIO exitSuccess 		else liftIO exitFailure   where-	k = fromMaybe (giveup "bad key") (file2key ks)+	k = fromMaybe (giveup "bad key") (deserializeKey ks) start _ = giveup "Wrong number of parameters"
Command/SetKey.hs view
@@ -26,7 +26,7 @@ start _ = giveup "specify a key and a content file"  mkKey :: String -> Key-mkKey = fromMaybe (giveup "bad key") . file2key+mkKey = fromMaybe (giveup "bad key") . deserializeKey  perform :: FilePath -> Key -> CommandPerform perform file key = do
Command/SetPresentKey.hs view
@@ -40,7 +40,7 @@  parseKeyStatus :: [String] -> Either String KeyStatus parseKeyStatus (ks:us:vs:[]) = do-	k <- maybe (Left "bad key") Right (file2key ks)+	k <- maybe (Left "bad key") Right (deserializeKey ks) 	let u = toUUID us 	s <- maybe (Left "bad value") Right (parseStatus vs) 	return $ KeyStatus k u s
Command/Smudge.hs view
@@ -22,7 +22,8 @@ import qualified Git.Ref import Backend -import qualified Data.ByteString.Lazy as B+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L  cmd :: Command cmd = noCommit $ noMessages $@@ -62,14 +63,14 @@ --   smudge filter in memory, which is a problem with large files. smudge :: FilePath -> CommandStart smudge file = do-	b <- liftIO $ B.hGetContents stdin-	case parseLinkOrPointer b of+	b <- liftIO $ L.hGetContents stdin+	case parseLinkTargetOrPointerLazy b of 		Nothing -> noop 		Just k -> do 			topfile <- inRepo (toTopFilePath file) 			Database.Keys.addAssociatedFile k topfile 			void $ smudgeLog k topfile-	liftIO $ B.putStr b+	liftIO $ L.putStr b 	stop  -- Clean filter is fed file content on stdin, decides if a file@@ -77,13 +78,13 @@ -- injested content if so. Otherwise, the original content. clean :: FilePath -> CommandStart clean file = do-	b <- liftIO $ B.hGetContents stdin+	b <- liftIO $ L.hGetContents stdin 	ifM fileoutsiderepo-		( liftIO $ B.hPut stdout b-		, case parseLinkOrPointer b of+		( liftIO $ L.hPut stdout b+		, case parseLinkTargetOrPointerLazy b of 			Just k -> do 				getMoveRaceRecovery k file-				liftIO $ B.hPut stdout b+				liftIO $ L.hPut stdout b 			Nothing -> go b =<< catKeyFile file 		) 	stop@@ -97,7 +98,7 @@ 			-- to free memory when sending the file, so the 			-- less we let it send, the less memory it will waste.) 			if Git.BuildVersion.older "2.5"-				then B.length b `seq` return ()+				then L.length b `seq` return () 				else liftIO $ hClose stdin  			-- Optimization for the case when the file is already@@ -108,7 +109,7 @@ 					( liftIO $ emitPointer ko 					, doingest oldkey 					)-		, liftIO $ B.hPut stdout b+		, liftIO $ L.hPut stdout b 		) 	 	doingest oldkey = do@@ -158,7 +159,7 @@ 		Nothing -> isNothing <$> catObjectMetaData (Git.Ref.fileRef file)  emitPointer :: Key -> IO ()-emitPointer = putStr . formatPointer+emitPointer = S.putStr . formatPointer  -- Recover from a previous race between eg git mv and git-annex get. -- That could result in the file remaining a pointer file, while
Command/Sync.hs view
@@ -166,9 +166,9 @@  	remotes <- syncRemotes (syncWith o) 	let gitremotes = filter Remote.gitSyncableRemote remotes-	(exportremotes, dataremotes) <- partition (exportTree . Remote.config)-		. filter (\r -> Remote.uuid r /= NoUUID)+	dataremotes <- filter (\r -> Remote.uuid r /= NoUUID) 		<$> filterM (not <$$> liftIO . getDynamicConfig . remoteAnnexIgnore . Remote.gitconfig) remotes+	let exportremotes = filter (exportTree . Remote.config) dataremotes  	if cleanupOption o 		then do@@ -187,8 +187,11 @@ 				] 			 			whenM shouldsynccontent $ do-				syncedcontent <- withbranch $ seekSyncContent o dataremotes+				-- Send content to any exports first, in +				-- case that lets content be dropped from+				-- other repositories. 				exportedcontent <- withbranch $ seekExportContent exportremotes+				syncedcontent <- withbranch $ seekSyncContent o dataremotes 				-- Transferring content can take a while, 				-- and other changes can be pushed to the 				-- git-annex branch on the remotes in the@@ -293,8 +296,8 @@ commitMsg :: Annex String commitMsg = do 	u <- getUUID-	m <- uuidMap-	return $ "git-annex in " ++ fromMaybe "unknown" (M.lookup u m)+	m <- uuidDescMap+	return $ "git-annex in " ++ maybe "unknown" fromUUIDDesc (M.lookup u m)  commitStaged :: Git.Branch.CommitMode -> String -> Annex Bool commitStaged commitmode commitmessage = do@@ -618,14 +621,15 @@  -} syncFile :: Either (Maybe (Bloom Key)) (Key -> Annex ()) -> [Remote] -> AssociatedFile -> Key -> Annex Bool syncFile ebloom rs af k = onlyActionOn' k $ do+	inhere <- inAnnex k 	locs <- map Remote.uuid <$> Remote.keyPossibilities k 	let (have, lack) = partition (\r -> Remote.uuid r `elem` locs) rs -	got <- anyM id =<< handleget have+	got <- anyM id =<< handleget have inhere 	putrs <- handleput lack  	u <- getUUID-	let locs' = concat [[u | got], putrs, locs]+	let locs' = concat [if inhere || got then [u] else [], putrs, locs]  	-- A bloom filter is populated with all the keys in the first pass. 	-- On the second pass, avoid dropping keys that were seen in the@@ -649,12 +653,12 @@ 	 	return (got || not (null putrs))   where-	wantget have = allM id +	wantget have inhere = allM id  		[ pure (not $ null have)-		, not <$> inAnnex k+		, pure (not inhere) 		, wantGet True (Just k) af 		]-	handleget have = ifM (wantget have)+	handleget have inhere = ifM (wantget have inhere) 		( return [ get have ] 		, return [] 		)
Command/TestRemote.hs view
@@ -1,6 +1,6 @@ {- git-annex command  -- - Copyright 2014 Joey Hess <id@joeyh.name>+ - Copyright 2014-2019 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -14,7 +14,9 @@ import qualified Types.Backend as Backend import Types.KeySource import Annex.Content+import Annex.WorkTree import Backend+import Logs.Location import qualified Backend.Hash import Utility.Tmp import Utility.Metered@@ -42,6 +44,7 @@ data TestRemoteOptions = TestRemoteOptions 	{ testRemote :: RemoteName 	, sizeOption :: ByteSize+	, testReadonlyFile :: [FilePath] 	}  optParser :: CmdParamsDesc -> Parser TestRemoteOptions@@ -52,22 +55,43 @@ 		<> value (1024 * 1024) 		<> help "base key size (default 1MiB)" 		)+	<*> many testreadonly+  where+	testreadonly = option str+		( long "test-readonly" <> metavar paramFile+		<> help "readonly test object"+		)  seek :: TestRemoteOptions -> CommandSeek-seek o = commandAction $ start (fromInteger $ sizeOption o) (testRemote o) +seek = commandAction . start  -start :: Int -> RemoteName -> CommandStart-start basesz name = do-	showStart' "testremote" (Just name)+start :: TestRemoteOptions -> CommandStart+start o = do+	showStart' "testremote" (Just (testRemote o)) 	fast <- Annex.getState Annex.fast-	r <- either giveup disableExportTree =<< Remote.byName' name-	rs <- catMaybes <$> mapM (adjustChunkSize r) (chunkSizes basesz fast)-	rs' <- concat <$> mapM encryptionVariants rs-	unavailrs  <- catMaybes <$> mapM Remote.mkUnavailable [r]-	exportr <- exportTreeVariant r-	showAction "generating test keys"-	ks <- mapM randKey (keySizes basesz fast)-	next $ perform rs' unavailrs exportr ks+	r <- either giveup disableExportTree =<< Remote.byName' (testRemote o)+	ks <- case testReadonlyFile o of+		[] -> if Remote.readonly r+			then giveup "This remote is readonly, so you need to use the --test-readonly option."+			else do+				showAction "generating test keys"+				mapM randKey (keySizes basesz fast)+		fs -> mapM (getReadonlyKey r) fs+	let r' = if null (testReadonlyFile o)+		then r+		else r { Remote.readonly = True }+	rs <- if Remote.readonly r'+		then return [r']+		else do+			rs <- catMaybes <$> mapM (adjustChunkSize r') (chunkSizes basesz fast)+			concat <$> mapM encryptionVariants rs+	unavailrs  <- catMaybes <$> mapM Remote.mkUnavailable [r']+	exportr <- if Remote.readonly r'+		then return Nothing+		else exportTreeVariant r'+	next $ perform rs unavailrs exportr ks+  where+	basesz = fromInteger $ sizeOption o  perform :: [Remote] -> [Remote] -> Maybe Remote -> [Key] -> CommandPerform perform rs unavailrs exportr ks = do@@ -132,18 +156,18 @@ 		(Remote.gitconfig r)  test :: Annex.AnnexState -> Remote -> Key -> [TestTree]-test st r k =-	[ check "removeKey when not present" remove-	, present False-	, check "storeKey" store-	, present True-	, check "storeKey when already present" store-	, present True-	, check "retrieveKeyFile" $ do+test st r k = catMaybes+	[ whenwritable $ check "removeKey when not present" remove+	, whenwritable $ present False+	, whenwritable $ check "storeKey" store+	, whenwritable $ present True+	, whenwritable $ check "storeKey when already present" store+	, Just $ present True+	, Just $ check "retrieveKeyFile" $ do 		lockContentForRemoval k removeAnnex 		get-	, check "fsck downloaded object" fsck-	, check "retrieveKeyFile resume from 33%" $ do+	, Just $ check "fsck downloaded object" fsck+	, Just $ check "retrieveKeyFile resume from 33%" $ do 		loc <- Annex.calcRepo (gitAnnexLocation k) 		tmp <- prepTmp k 		partial <- liftIO $ bracket (openBinaryFile loc ReadMode) hClose $ \h -> do@@ -152,24 +176,25 @@ 		liftIO $ L.writeFile tmp partial 		lockContentForRemoval k removeAnnex 		get-	, check "fsck downloaded object" fsck-	, check "retrieveKeyFile resume from 0" $ do+	, Just $ check "fsck downloaded object" fsck+	, Just $ check "retrieveKeyFile resume from 0" $ do 		tmp <- prepTmp k 		liftIO $ writeFile tmp "" 		lockContentForRemoval k removeAnnex 		get-	, check "fsck downloaded object" fsck-	, check "retrieveKeyFile resume from end" $ do+	, Just $ check "fsck downloaded object" fsck+	, Just $ check "retrieveKeyFile resume from end" $ do 		loc <- Annex.calcRepo (gitAnnexLocation k) 		tmp <- prepTmp k 		void $ liftIO $ copyFileExternal CopyAllMetaData loc tmp 		lockContentForRemoval k removeAnnex 		get-	, check "fsck downloaded object" fsck-	, check "removeKey when present" remove-	, present False+	, Just $ check "fsck downloaded object" fsck+	, whenwritable $ check "removeKey when present" remove+	, whenwritable $ present False 	]   where+	whenwritable a = if Remote.readonly r then Nothing else Just a 	check desc a = testCase desc $ 		Annex.eval st (Annex.setOutput QuietOutput >> a) @? "failed" 	present b = check ("present " ++ show b) $@@ -178,7 +203,7 @@ 		Nothing -> return True 		Just b -> case Backend.verifyKeyContent b of 			Nothing -> return True-			Just verifier -> verifier k (key2file k)+			Just verifier -> verifier k (serializeKey k) 	get = getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k $ \dest -> 		Remote.retrieveKeyFile r k (AssociatedFile Nothing) 			dest nullMeterUpdate@@ -252,10 +277,12 @@ 		checkval v  @? ("(got: " ++ show v ++ ")")  cleanup :: [Remote] -> [Key] -> Bool -> CommandCleanup-cleanup rs ks ok = do-	forM_ rs $ \r -> forM_ ks (Remote.removeKey r)-	forM_ ks $ \k -> lockContentForRemoval k removeAnnex-	return ok+cleanup rs ks ok+	| all Remote.readonly rs = return ok+	| otherwise = do+		forM_ rs $ \r -> forM_ ks (Remote.removeKey r)+		forM_ ks $ \k -> lockContentForRemoval k removeAnnex+		return ok  chunkSizes :: Int -> Bool -> [Int] chunkSizes base False =@@ -297,3 +324,13 @@ 		<$> Backend.getKey Backend.Hash.testKeyBackend ks 	_ <- moveAnnex k f 	return k++getReadonlyKey :: Remote -> FilePath -> Annex Key+getReadonlyKey r f = lookupFile f >>= \case+	Nothing -> giveup $ f ++ " is not an annexed file"+	Just k -> do+		unlessM (inAnnex k) $+			giveup $ f ++ " does not have its content locally present, cannot test it"+		unlessM ((Remote.uuid r `elem`) <$> loggedLocations k) $+			giveup $ f ++ " is not stored in the remote being tested, cannot test it"+		return k
Command/TransferInfo.hs view
@@ -38,7 +38,7 @@  -} start :: [String] -> CommandStart start (k:[]) = do-	case file2key k of+	case deserializeKey k of 		Nothing -> error "bad key" 		(Just key) -> whenM (inAnnex key) $ do 			afile <- AssociatedFile <$> Fields.getField Fields.associatedFile
Command/TransferKeys.hs view
@@ -82,7 +82,7 @@ sendRequest t tinfo h = do 	hPutStr h $ intercalate fieldSep 		[ serialize (transferDirection t)-		, maybe (serialize (fromUUID (transferUUID t)))+		, maybe (serialize ((fromUUID (transferUUID t)) :: String)) 			(serialize . Remote.name) 			(transferRemote tinfo) 		, serialize (transferKey t)@@ -126,5 +126,5 @@ 	deserialize n = Just n  instance TCSerialized Key where-	serialize = key2file-	deserialize = file2key+	serialize = serializeKey+	deserialize = deserializeKey
Command/Unannex.hs view
@@ -70,7 +70,8 @@ 	showStart "unannex" file 	next $ ifM isDirect 		( performDirect file key-		, performIndirect file key)+		, performIndirect file key+		)  performIndirect :: FilePath -> Key -> CommandPerform performIndirect file key = do
Command/Ungroup.hs view
@@ -25,7 +25,7 @@ start (name:g:[]) = do 	showStart' "ungroup" (Just name) 	u <- Remote.nameToUUID name-	next $ perform u g+	next $ perform u (toGroup g) start _ = giveup "Specify a repository and a group."  perform :: UUID -> Group -> CommandPerform
Command/Unused.hs view
@@ -118,7 +118,7 @@ table :: [(Int, Key)] -> [String] table l = "  NUMBER  KEY" : map cols l   where-	cols (n,k) = "  " ++ pad 6 (show n) ++ "  " ++ key2file k+	cols (n,k) = "  " ++ pad 6 (show n) ++ "  " ++ serializeKey k 	pad n s = s ++ replicate (n - length s) ' '  staleTmpMsg :: [(Int, Key)] -> String@@ -139,7 +139,7 @@ unusedMsg' u mheader mtrailer = unlines $ 	mheader ++ 	table u ++-	["(To see where data was previously used, try: git log --stat -S'KEY')"] +++	["(To see where data was previously used, try: git log --stat --no-textconv -S'KEY')"] ++ 	mtrailer  remoteUnusedMsg :: Maybe Remote -> RemoteName -> [(Int, Key)] -> String
Command/Version.hs view
@@ -59,7 +59,7 @@ 	vinfo "build flags" $ unwords buildFlags 	vinfo "dependency versions" $ unwords dependencyVersions 	vinfo "key/value backends" $ unwords $-		map (formatKeyVariety . B.backendVariety) Backend.list+		map (decodeBS . formatKeyVariety . B.backendVariety) Backend.list 	vinfo "remote types" $ unwords $ map R.typename Remote.remoteTypes 	vinfo "operating system" $ unwords [os, arch] 	vinfo "supported repository versions" $
Command/Vicfg.hs view
@@ -129,7 +129,7 @@ 	diff f = M.differenceWith (\x y -> if x == y then Nothing else Just x) 		(f newcfg) (f curcfg) -genCfg :: Cfg -> M.Map UUID String -> String+genCfg :: Cfg -> UUIDDescMap -> String genCfg cfg descs = unlines $ intercalate [""] 	[ intro 	, trust@@ -167,10 +167,10 @@ 		, com $ "(Standard groups: " ++ grouplist ++ ")" 		, com "(Separate group names with spaces)" 		]-		(\(s, u) -> line "group" u $ unwords $ S.toList s)+		(\(s, u) -> line "group" u $ unwords $ map fromGroup $ S.toList s) 		(\u -> lcom $ line "group" u "") 	  where-		grouplist = unwords $ map fromStandardGroup [minBound..]+		grouplist = unwords $ map (fromGroup . fromStandardGroup) [minBound..]  	preferredcontent = settings cfg descs cfgPreferredContentMap 		[ com "Repository preferred contents"@@ -191,7 +191,7 @@ 		(\(s, g) -> gline g s) 		(\g -> gline g "") 	  where-		gline g val = [ unwords ["groupwanted", g, "=", val] ]+		gline g val = [ unwords ["groupwanted", fromGroup g, "=", val] ] 		allgroups = S.unions $ stdgroups : M.elems (cfgGroupMap cfg) 		stdgroups = S.fromList $ map fromStandardGroup [minBound..maxBound] @@ -204,7 +204,7 @@ 	  where 		gline g = com $ unwords 			[ "standard"-			, fromStandardGroup g, "=", standardPreferredContent g+			, fromGroup (fromStandardGroup g), "=", standardPreferredContent g 			] 	 	schedule = settings cfg descs cfgScheduleMap@@ -223,7 +223,7 @@ 		gline g val = [ unwords ["config", g, "=", val] ]  	line setting u val =-		[ com $ "(for " ++ fromMaybe "" (M.lookup u descs) ++ ")"+		[ com $ "(for " ++ fromUUIDDesc (fromMaybe mempty (M.lookup u descs)) ++ ")" 		, unwords [setting, fromUUID u, "=", val] 		] @@ -235,7 +235,7 @@ 		, line' "numcopies" (show . fromNumCopies <$> cfgNumCopies cfg) 		] 	-settings :: Ord v => Cfg -> M.Map UUID String -> (Cfg -> M.Map UUID v) -> [String] -> ((v, UUID) -> [String]) -> (UUID -> [String]) -> [String]+settings :: Ord v => Cfg -> UUIDDescMap -> (Cfg -> M.Map UUID v) -> [String] -> ((v, UUID) -> [String]) -> (UUID -> [String]) -> [String] settings cfg descs = settings' cfg (M.keysSet descs)  settings' :: (Ord v, Ord f) => Cfg -> S.Set f -> (Cfg -> M.Map f v) -> [String] -> ((v, f) -> [String]) -> (f -> [String]) -> [String]@@ -282,7 +282,7 @@ 				let m = M.insert u (Down t) (cfgTrustMap cfg) 				in Right $ cfg { cfgTrustMap = m } 		| setting == "group" =-			let m = M.insert u (S.fromList $ words val) (cfgGroupMap cfg)+			let m = M.insert u (S.fromList $ map toGroup $ words val) (cfgGroupMap cfg) 			in Right $ cfg { cfgGroupMap = m } 		| setting == "wanted" =  			case checkPreferredContentExpression val of@@ -300,7 +300,7 @@ 			case checkPreferredContentExpression val of 				Just e -> Left e 				Nothing ->-					let m = M.insert f val (cfgGroupPreferredContentMap cfg)+					let m = M.insert (toGroup f) val (cfgGroupPreferredContentMap cfg) 					in Right $ cfg { cfgGroupPreferredContentMap = m } 		| setting == "schedule" = case parseScheduledActivities val of 			Left e -> Left e
Common.hs view
@@ -30,5 +30,6 @@ import Utility.FileSize as X import Utility.Network as X import Utility.Split as X+import Utility.FileSystemEncoding as X  import Utility.PartialPrelude as X
Crypto.hs view
@@ -9,6 +9,7 @@  -}  {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-}  module Crypto (@@ -33,6 +34,7 @@ 	prop_HmacSha1WithCipher_sane ) where +import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import Data.ByteString.UTF8 (fromString) import qualified Data.Map as M@@ -159,16 +161,17 @@  - on content. It does need to be repeatable. -} encryptKey :: Mac -> Cipher -> EncKey encryptKey mac c k = stubKey-	{ keyName = macWithCipher mac c (key2file k)-	, keyVariety = OtherKey (encryptedBackendNamePrefix ++ showMac mac)+	{ keyName = encodeBS (macWithCipher mac c (serializeKey k))+	, keyVariety = OtherKey $+		encryptedBackendNamePrefix <> encodeBS (showMac mac) 	} -encryptedBackendNamePrefix :: String+encryptedBackendNamePrefix :: S.ByteString encryptedBackendNamePrefix = "GPG"  isEncKey :: Key -> Bool isEncKey k = case keyVariety k of-	OtherKey s ->  encryptedBackendNamePrefix `isPrefixOf` s+	OtherKey s -> encryptedBackendNamePrefix `S.isPrefixOf` s 	_ -> False  type Feeder = Handle -> IO ()
Database/Types.hs view
@@ -23,10 +23,10 @@ 	deriving (Show, Read)  toSKey :: Key -> SKey-toSKey = SKey . key2file+toSKey = SKey . serializeKey  fromSKey :: SKey -> Key-fromSKey (SKey s) = fromMaybe (error $ "bad serialized Key " ++ s) (file2key s)+fromSKey (SKey s) = fromMaybe (error $ "bad serialized Key " ++ s) (deserializeKey s)  derivePersistField "SKey" @@ -41,10 +41,10 @@ 	show (IKey s) = s  toIKey :: Key -> IKey-toIKey = IKey . key2file+toIKey = IKey . serializeKey  fromIKey :: IKey -> Key-fromIKey (IKey s) = fromMaybe (error $ "bad serialized Key " ++ s) (file2key s)+fromIKey (IKey s) = fromMaybe (error $ "bad serialized Key " ++ s) (deserializeKey s)  derivePersistField "IKey"
Git/CatFile.hs view
@@ -38,7 +38,6 @@ import Git.FilePath import Git.HashObject import qualified Utility.CoProcess as CoProcess-import Utility.FileSystemEncoding import Utility.Tuple  data CatFileHandle = CatFileHandle @@ -207,7 +206,7 @@ 	dropsha = L.drop 21  	parsemodefile b = -		let (modestr, file) = separate (== ' ') (decodeBS b)+		let (modestr, file) = separate (== ' ') (decodeBL b) 		in (file, readmode modestr) 	readmode = fromMaybe 0 . fmap fst . headMaybe . readOct
Git/HashObject.hs view
@@ -1,6 +1,6 @@ {- git hash-object interface  -- - Copyright 2011-2014 Joey Hess <id@joeyh.name>+ - Copyright 2011-2019 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -17,6 +17,10 @@ import qualified Utility.CoProcess as CoProcess import Utility.Tmp +import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L+import Data.ByteString.Builder+ type HashObjectHandle = CoProcess.CoProcessHandle  hashObjectStart :: Repo -> IO HashObjectHandle@@ -37,14 +41,23 @@ 	send to = hPutStrLn to =<< absPath file 	receive from = getSha "hash-object" $ hGetLine from +class HashableBlob t where+	hashableBlobToHandle :: Handle -> t -> IO ()++instance HashableBlob L.ByteString where+	hashableBlobToHandle = L.hPut++instance HashableBlob S.ByteString where+	hashableBlobToHandle = S.hPut++instance HashableBlob Builder where+	hashableBlobToHandle = hPutBuilder+ {- Injects a blob into git. Unfortunately, the current git-hash-object  - interface does not allow batch hashing without using temp files. -}-hashBlob :: HashObjectHandle -> String -> IO Sha-hashBlob h s = withTmpFile "hash" $ \tmp tmph -> do-#ifdef mingw32_HOST_OS-	hSetNewlineMode tmph noNewlineTranslation-#endif-	hPutStr tmph s+hashBlob :: HashableBlob b => HashObjectHandle -> b -> IO Sha+hashBlob h b = withTmpFile "hash" $ \tmp tmph -> do+	hashableBlobToHandle tmph b 	hClose tmph 	hashFile h tmp
Git/UnionMerge.hs view
@@ -10,7 +10,7 @@ 	mergeIndex ) where -import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Lazy.Char8 as L8 import qualified Data.Set as S  import Common@@ -22,7 +22,6 @@ import Git.HashObject import Git.Types import Git.FilePath-import Utility.FileSystemEncoding  {- Performs a union merge between two branches, staging it in the index.  - Any previously staged changes in the index will be lost.@@ -86,26 +85,25 @@ 	[] -> return Nothing 	(sha:[]) -> use sha 	shas -> use-		=<< either return (\s -> hashBlob hashhandle (unlines s))+		=<< either return (hashBlob hashhandle . L8.unlines) 		=<< calcMerge . zip shas <$> mapM getcontents shas   where 	[_colonmode, _bmode, asha, bsha, _status] = words info 	use sha = return $ Just $ 		updateIndexLine sha TreeFile $ asTopFilePath file-	-- We don't know how the file is encoded, but need to-	-- split it into lines to union merge. Using the-	-- FileSystemEncoding for this is a hack, but ensures there-	-- are no decoding errors.-	getcontents s = lines . encodeW8NUL . L.unpack <$> catObject h s+	-- Get file and split into lines to union merge.+	-- The encoding of the file is assumed to be either ASCII or utf-8;+	-- in either case it's safe to split on \n+	getcontents s = L8.lines <$> catObject h s  {- Calculates a union merge between a list of refs, with contents.  -  - When possible, reuses the content of an existing ref, rather than  - generating new content.  -}-calcMerge :: [(Ref, [String])] -> Either Ref [String]+calcMerge :: [(Ref, [L8.ByteString])] -> Either Ref [L8.ByteString] calcMerge shacontents-	| null reuseable = Right $ new+	| null reuseable = Right new 	| otherwise = Left $ fst $ Prelude.head reuseable   where 	reuseable = filter (\c -> sorteduniq (snd c) == new) shacontents
Key.hs view
@@ -1,6 +1,6 @@ {- git-annex Keys  -- - Copyright 2011-2017 Joey Hess <id@joeyh.name>+ - Copyright 2011-2019 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -11,19 +11,30 @@ 	Key(..), 	AssociatedFile(..), 	stubKey,-	key2file,-	file2key,+	buildKey,+	keyParser,+	serializeKey,+	serializeKey',+	deserializeKey,+	deserializeKey', 	nonChunkKey, 	chunkKeyOffset, 	isChunkKey, 	isKeyPrefix,+	splitKeyNameExtension, -	prop_isomorphic_key_encode,-	prop_isomorphic_key_decode+	prop_isomorphic_key_encode ) where -import Data.Char import qualified Data.Text as T+import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8+import qualified Data.ByteString.Lazy as L+import Data.ByteString.Builder+import Data.ByteString.Builder.Extra+import qualified Data.Attoparsec.ByteString as A+import qualified Data.Attoparsec.ByteString.Char8 as A8+import Foreign.C.Types  import Common import Types.Key@@ -34,8 +45,8 @@  stubKey :: Key stubKey = Key-	{ keyName = ""-	, keyVariety = OtherKey ""+	{ keyName = mempty+	, keyVariety = OtherKey mempty 	, keySize = Nothing 	, keyMtime = Nothing 	, keyChunkSize = Nothing@@ -65,117 +76,123 @@ fieldSep :: Char fieldSep = '-' -{- Converts a key to a string that is suitable for use as a filename.+{- Builds a ByteString from a Key.+ -  - The name field is always shown last, separated by doubled fieldSeps,- - and is the only field allowed to contain the fieldSep. -}-key2file :: Key -> FilePath-key2file Key { keyVariety = kv, keySize = s, keyMtime = m, keyChunkSize = cs, keyChunkNum = cn, keyName = n } =-	formatKeyVariety kv +++ ('s' ?: s) +++ ('m' ?: m) +++ ('S' ?: cs) +++ ('C' ?: cn) +++ (fieldSep : n)+ - and is the only field allowed to contain the fieldSep.+ -}+buildKey :: Key -> Builder+buildKey k = byteString (formatKeyVariety (keyVariety k))+	<> 's' ?: (integerDec <$> keySize k)+	<> 'm' ?: (integerDec . (\(CTime t) -> fromIntegral t) <$> keyMtime k)+	<> 'S' ?: (integerDec <$> keyChunkSize k)+	<> 'C' ?: (integerDec <$> keyChunkNum k)+	<> sepbefore (sepbefore (byteString (keyName k)))   where-	"" +++ y = y-	x +++ "" = x-	x +++ y = x ++ fieldSep:y-	f ?: (Just v) = f : show v-	_ ?: _ = ""+	sepbefore s = char7 fieldSep <> s+	c ?: (Just b) = sepbefore (char7 c <> b)+	_ ?: Nothing = mempty -file2key :: FilePath -> Maybe Key-file2key s-	| key == Just stubKey || (keyName <$> key) == Just "" || (keyVariety <$> key) == Just (OtherKey "") = Nothing-	| otherwise = key-  where-	key = startbackend stubKey s+serializeKey :: Key -> String+serializeKey = decodeBL' . serializeKey' -	startbackend k v = sepfield k v addvariety-		-	sepfield k v a = case span (/= fieldSep) v of-		(v', _:r) -> findfields r $ a k v'-		_ -> Nothing+serializeKey' :: Key -> L.ByteString+serializeKey' = toLazyByteStringWith (safeStrategy 128 smallChunkSize) L.empty . buildKey -	findfields (c:v) (Just k)-		| c == fieldSep = addkeyname k v-		| otherwise = sepfield k v $ addfield c-	findfields _ v = v+{- This is a strict parser for security reasons; a key+ - can contain only 4 fields, which all consist only of numbers.+ - Any key containing other fields, or non-numeric data will fail+ - to parse.+ -+ - If a key contained non-numeric fields, they could be used to+ - embed data used in a SHA1 collision attack, which would be a+ - problem since the keys are committed to git.+ -}+keyParser :: A.Parser Key+keyParser = do+	-- key variety cannot be empty+	v <- (parseKeyVariety <$> A8.takeWhile1 (/= fieldSep))+	s <- parsesize+	m <- parsemtime+	cs <- parsechunksize+	cn <- parsechunknum+	_ <- A8.char fieldSep+	_ <- A8.char fieldSep+	n <- A.takeByteString+	if validKeyName v n+		then return $ Key+			{ keyName = n+			, keyVariety = v+			, keySize = s+			, keyMtime = m+			, keyChunkSize = cs+			, keyChunkNum = cn+			}+		else fail "invalid keyName"+  where+	parseopt p = (Just <$> (A8.char fieldSep *> p)) <|> pure Nothing+	parsesize = parseopt $ A8.char 's' *> A8.decimal+	parsemtime = parseopt $ CTime <$> (A8.char 'm' *> A8.decimal)+	parsechunksize = parseopt $ A8.char 'S' *> A8.decimal+	parsechunknum = parseopt $ A8.char 'C' *> A8.decimal -	addvariety k v = Just k { keyVariety = parseKeyVariety v }+deserializeKey :: String -> Maybe Key+deserializeKey = deserializeKey' . encodeBS' -	-- This is a strict parser for security reasons; a key-	-- can contain only 4 fields, which all consist only of numbers.-	-- Any key containing other fields, or non-numeric data is-	-- rejected with Nothing.-	---	-- If a key contained non-numeric fields, they could be used to-	-- embed data used in a SHA1 collision attack, which would be a-	-- problem since the keys are committed to git.-	addfield _ _ v | not (all isDigit v) = Nothing-	addfield 's' k v = do-		sz <- readish v-		return $ k { keySize = Just sz }-	addfield 'm' k v = do-		mtime <- readish v-		return $ k { keyMtime = Just mtime }-	addfield 'S' k v = do-		chunksize <- readish v-		return $ k { keyChunkSize = Just chunksize }-	addfield 'C' k v = case readish v of-		Just chunknum | chunknum > 0 ->-			return $ k { keyChunkNum = Just chunknum }-		_ -> Nothing-	addfield _ _ _ = Nothing+deserializeKey' :: S.ByteString -> Maybe Key+deserializeKey' b = eitherToMaybe $ A.parseOnly keyParser b -	addkeyname k v-		| validKeyName k v = Just $ k { keyName = v }-		| otherwise = Nothing+{- This splits any extension out of the keyName, returning the + - keyName minus extension, and the extension (including leading dot).+ -}+splitKeyNameExtension :: Key -> (S.ByteString, S.ByteString)+splitKeyNameExtension = splitKeyNameExtension' . keyName -{- When a key HasExt, the length of the extension is limited in order to- - mitigate against SHA1 collision attacks.+splitKeyNameExtension' :: S.ByteString -> (S.ByteString, S.ByteString)+splitKeyNameExtension' keyname = S8.span (/= '.') keyname++{- Limits the length of the extension in the keyName to mitigate against+ - SHA1 collision attacks.  -  - In such an attack, the extension of the key could be made to contain  - the collision generation data, with the result that a signed git commit  - including such keys would not be secure.  -  - The maximum extension length ever generated for such a key was 8- - characters; 20 is used here to give a little future wiggle-room. + - characters, but they may be unicode which could use up to 4 bytes each,+ - so 32 bytes. 64 bytes is used here to give a little future wiggle-room.   - The SHA1 common-prefix attack needs 128 bytes of data.  -}-validKeyName :: Key -> String -> Bool-validKeyName k name-	| hasExt (keyVariety k) = length (takeExtensions name) <= 20+validKeyName :: KeyVariety -> S.ByteString -> Bool+validKeyName kv name+	| hasExt kv = +		let ext = snd $ splitKeyNameExtension' name+		in S.length ext <= 64 	| otherwise = True  instance Arbitrary Key where 	arbitrary = Key-		<$> (listOf1 $ elements $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "-_\r\n \t")-		<*> (parseKeyVariety <$> (listOf1 $ elements ['A'..'Z'])) -- BACKEND+		<$> (encodeBS <$> (listOf1 $ elements $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "-_\r\n \t"))+		<*> (parseKeyVariety . encodeBS <$> (listOf1 $ elements ['A'..'Z'])) -- BACKEND 		<*> ((abs <$>) <$> arbitrary) -- size cannot be negative 		<*> ((abs . fromInteger <$>) <$> arbitrary) -- mtime cannot be negative 		<*> ((abs <$>) <$> arbitrary) -- chunksize cannot be negative 		<*> ((succ . abs <$>) <$> arbitrary) -- chunknum cannot be 0 or negative  instance Hashable Key where-	hashIO32 = hashIO32 . key2file-	hashIO64 = hashIO64 . key2file+	hashIO32 = hashIO32 . serializeKey'+	hashIO64 = hashIO64 . serializeKey'  instance ToJSON' Key where-	toJSON' = toJSON' . key2file+	toJSON' = toJSON' . serializeKey  instance FromJSON Key where-	parseJSON (String t) = maybe mempty pure $ file2key $ T.unpack t+	parseJSON (String t) = maybe mempty pure $ deserializeKey $ T.unpack t 	parseJSON _ = mempty  instance Proto.Serializable Key where-	serialize = key2file-	deserialize = file2key+	serialize = serializeKey+	deserialize = deserializeKey  prop_isomorphic_key_encode :: Key -> Bool-prop_isomorphic_key_encode k = Just k == (file2key . key2file) k--prop_isomorphic_key_decode :: FilePath -> Bool-prop_isomorphic_key_decode f-	| normalfieldorder = maybe True (\k -> key2file k == f) (file2key f)-	| otherwise = True-  where-	-- file2key will accept the fields in any order, so don't-	-- try the test unless the fields are in the normal order-	normalfieldorder = fields `isPrefixOf` "smSC"-	fields = map (f !!) $ filter (< length f) $ map succ $-		elemIndices fieldSep f+prop_isomorphic_key_encode k = Just k == (deserializeKey . serializeKey) k
Limit.hs view
@@ -169,7 +169,7 @@ 	-- level, it's parsed as a trust level, not as a group. 	[v, n] -> case parsetrustspec v of 		Just checker -> go n $ checktrust checker-		Nothing -> go n $ checkgroup v+		Nothing -> go n $ checkgroup (toGroup v) 	[n] -> go n $ const $ return True 	_ -> Left "bad value for copies"   where@@ -237,7 +237,7 @@ limitInAllGroup :: Annex GroupMap -> MkLimit Annex limitInAllGroup getgroupmap groupname = Right $ \notpresent mi -> do 	m <- getgroupmap-	let want = fromMaybe S.empty $ M.lookup groupname $ uuidsByGroup m+	let want = fromMaybe S.empty $ M.lookup (toGroup groupname) $ uuidsByGroup m 	if S.null want 		then return True 		-- optimisation: Check if a wanted uuid is notpresent.@@ -257,7 +257,7 @@ limitInBackend name = Right $ const $ checkKey check   where 	check key = pure $ keyVariety key == variety-	variety = parseKeyVariety name+	variety = parseKeyVariety (encodeBS name)  {- Adds a limit to skip files not using a secure hash. -} addSecureHash :: Annex ()
Logs.hs view
@@ -124,7 +124,7 @@ {- Old versions stored the urls elsewhere. -} oldurlLogs :: GitConfig -> Key -> [FilePath] oldurlLogs config key =-	[ "remote/web" </> hdir </> key2file key ++ ".log"+	[ "remote/web" </> hdir </> serializeKey key ++ ".log" 	, "remote/web" </> hdir </> keyFile key ++ ".log" 	]   where
Logs/Activity.hs view
@@ -1,6 +1,6 @@ {- git-annex activity log  -- - Copyright 2015 Joey Hess <id@joeyh.name>+ - Copyright 2015-2019 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -17,19 +17,36 @@ import Logs import Logs.UUIDBased -data Activity = Fsck+import qualified Data.ByteString as S+import qualified Data.Attoparsec.ByteString as A+import Data.ByteString.Builder++data Activity +	= Fsck 	deriving (Eq, Read, Show, Enum, Bounded)  recordActivity :: Activity -> UUID -> Annex () recordActivity act uuid = do 	c <- liftIO currentVectorClock 	Annex.Branch.change activityLog $-		showLog show . changeLog c uuid act . parseLog readish+		buildLog buildActivity+			. changeLog c uuid (Right act)+			. parseLog parseActivity  lastActivities :: Maybe Activity -> Annex (Log Activity)-lastActivities wantact = parseLog onlywanted <$> Annex.Branch.get activityLog+lastActivities wantact = parseLog (onlywanted =<< parseActivity)+	<$> Annex.Branch.get activityLog   where-	onlywanted s = case readish s of-		Just a | wanted a -> Just a-		_ -> Nothing+	onlywanted (Right a) | wanted a = pure a+	onlywanted _ = fail "unwanted activity" 	wanted a = maybe True (a ==) wantact++buildActivity :: Either S.ByteString Activity -> Builder+buildActivity (Right a) = byteString $ encodeBS $ show a+buildActivity (Left b) = byteString b++-- Allow for unknown activities to be added later by preserving them.+parseActivity :: A.Parser (Either S.ByteString Activity)+parseActivity = go <$> A.takeByteString+  where+	go b = maybe (Left b) Right $ readish $ decodeBS b
Logs/Chunk.hs view
@@ -38,7 +38,7 @@ 	c <- liftIO currentVectorClock 	config <- Annex.getGitConfig 	Annex.Branch.change (chunkLogFile config k) $-		showLog . changeMapLog c (u, chunkmethod) chunkcount . parseLog+		buildLog . changeMapLog c (u, chunkmethod) chunkcount . parseLog  chunksRemoved :: UUID -> Key -> ChunkMethod -> Annex () chunksRemoved u k chunkmethod = chunksStored u k chunkmethod 0
Logs/Chunk/Pure.hs view
@@ -1,6 +1,6 @@ {- Chunk logs, pure operations.  -- - Copyright 2014 Joey Hess <id@joeyh.name>+ - Copyright 2014, 2019 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -11,16 +11,22 @@ 	, ChunkCount 	, ChunkLog 	, parseLog-	, showLog+	, buildLog 	) where  import Annex.Common import Logs.MapLog import Data.Int +import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L+import qualified Data.Attoparsec.ByteString.Lazy as A+import qualified Data.Attoparsec.ByteString.Char8 as A8+import Data.ByteString.Builder+ -- Currently chunks are all fixed size, but other chunking methods -- may be added.-data ChunkMethod = FixedSizeChunks ChunkSize | UnknownChunks String+data ChunkMethod = FixedSizeChunks ChunkSize | UnknownChunks S.ByteString 	deriving (Ord, Eq, Show)  type ChunkSize = Int64@@ -30,26 +36,27 @@  type ChunkLog = MapLog (UUID, ChunkMethod) ChunkCount -parseChunkMethod :: String -> ChunkMethod-parseChunkMethod s = maybe (UnknownChunks s) FixedSizeChunks (readish s)+buildChunkMethod :: ChunkMethod -> Builder+buildChunkMethod (FixedSizeChunks sz) = int64Dec sz+buildChunkMethod (UnknownChunks s) = byteString s -showChunkMethod :: ChunkMethod -> String-showChunkMethod (FixedSizeChunks sz) = show sz-showChunkMethod (UnknownChunks s) = s+chunkMethodParser :: A.Parser ChunkMethod+chunkMethodParser =+	(FixedSizeChunks <$> A8.decimal) <|> (UnknownChunks <$> A.takeByteString) -parseLog :: String -> ChunkLog-parseLog = parseMapLog fieldparser valueparser+buildLog :: ChunkLog -> Builder+buildLog = buildMapLog fieldbuilder valuebuilder   where-	fieldparser s =-		let (u,m) = separate (== sep) s-		in Just (toUUID u, parseChunkMethod m)-	valueparser = readish+	fieldbuilder (u, m) = buildUUID u <> sep <> buildChunkMethod m+	valuebuilder = integerDec+	sep = charUtf8 ':' -showLog :: ChunkLog -> String-showLog = showMapLog fieldshower valueshower+parseLog :: L.ByteString -> ChunkLog+parseLog = parseMapLog fieldparser valueparser   where-	fieldshower (u, m) = fromUUID u ++ sep : showChunkMethod m-	valueshower = show--sep :: Char-sep = ':'+	fieldparser = (,)+		<$> (toUUID <$> A8.takeTill (== ':'))+		<* A8.char ':'+		<*> chunkMethodParser+		<* A.endOfInput+	valueparser = A8.decimal
Logs/Config.hs view
@@ -1,6 +1,6 @@ {- git-annex repository-global config log  -- - Copyright 2017 Joey Hess <id@joeyh.name>+ - Copyright 2017-2019 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -20,6 +20,9 @@ import qualified Annex.Branch  import qualified Data.Map as M+import qualified Data.ByteString.Lazy as L+import qualified Data.Attoparsec.ByteString.Lazy as A+import Data.ByteString.Builder  type ConfigName = String type ConfigValue = String@@ -34,7 +37,7 @@ setGlobalConfig' name new = do 	c <- liftIO currentVectorClock 	Annex.Branch.change configLog $ -		showMapLog id id . changeMapLog c name new . parseGlobalConfig+		buildGlobalConfig . changeMapLog c name new . parseGlobalConfig  unsetGlobalConfig :: ConfigName -> Annex () unsetGlobalConfig name = do@@ -46,8 +49,16 @@ getGlobalConfig :: ConfigName -> Annex (Maybe ConfigValue) getGlobalConfig name = M.lookup name <$> loadGlobalConfig -parseGlobalConfig :: String -> MapLog ConfigName ConfigValue-parseGlobalConfig = parseMapLog Just Just+buildGlobalConfig :: MapLog ConfigName ConfigValue -> Builder+buildGlobalConfig = buildMapLog fieldbuilder valuebuilder+  where+	fieldbuilder = byteString . encodeBS+	valuebuilder = byteString . encodeBS++parseGlobalConfig :: L.ByteString -> MapLog ConfigName ConfigValue+parseGlobalConfig = parseMapLog string string+  where+	string = decodeBS <$> A.takeByteString  loadGlobalConfig :: Annex (M.Map ConfigName ConfigValue) loadGlobalConfig = M.filter (not . null) . simpleMap . parseGlobalConfig
Logs/Difference.hs view
@@ -13,6 +13,8 @@ ) where  import qualified Data.Map as M+import qualified Data.Attoparsec.ByteString as A+import Data.ByteString.Builder  import Annex.Common import Types.Difference@@ -25,7 +27,9 @@ recordDifferences ds@(Differences {}) uuid = do 	c <- liftIO currentVectorClock 	Annex.Branch.change differenceLog $-		showLog id . changeLog c uuid (showDifferences ds) . parseLog Just+		buildLog byteString +			. changeLog c uuid (encodeBS $ showDifferences ds) +			. parseLog A.takeByteString recordDifferences UnknownDifferences _ = return ()  -- Map of UUIDs that have Differences recorded.@@ -35,5 +39,4 @@ recordedDifferences = parseDifferencesLog <$> Annex.Branch.get differenceLog  recordedDifferencesFor :: UUID -> Annex Differences-recordedDifferencesFor u = fromMaybe mempty . M.lookup u -	<$> recordedDifferences+recordedDifferencesFor u = fromMaybe mempty . M.lookup u <$> recordedDifferences
Logs/Difference/Pure.hs view
@@ -11,13 +11,16 @@ ) where  import qualified Data.Map as M+import qualified Data.ByteString.Lazy as L+import qualified Data.Attoparsec.ByteString as A  import Annex.Common import Types.Difference import Logs.UUIDBased -parseDifferencesLog :: String -> (M.Map UUID Differences)-parseDifferencesLog = simpleMap . parseLog (Just . readDifferences)+parseDifferencesLog :: L.ByteString -> (M.Map UUID Differences)+parseDifferencesLog = simpleMap+	. parseLog (readDifferences . decodeBS <$> A.takeByteString)  -- The sum of all recorded differences, across all UUIDs. allDifferences :: M.Map UUID Differences -> Differences
Logs/Export.hs view
@@ -18,6 +18,11 @@ import Logs.MapLog import Annex.UUID +import qualified Data.ByteString.Lazy as L+import qualified Data.Attoparsec.ByteString.Lazy as A+import qualified Data.Attoparsec.ByteString.Char8 as A8+import Data.ByteString.Builder+ data Exported = Exported 	{ exportedTreeish :: Git.Ref 	, incompleteExportedTreeish :: [Git.Ref]@@ -28,7 +33,7 @@ 	{ exportFrom :: UUID 	, exportTo :: UUID 	}-	deriving (Eq, Ord)+	deriving (Eq, Ord, Show)  data ExportChange = ExportChange 	{ oldTreeish :: [Git.Ref]@@ -68,7 +73,7 @@ 	let ep = ExportParticipants { exportFrom = u, exportTo = remoteuuid } 	let exported = Exported (newTreeish ec) [] 	Annex.Branch.change exportLog $-		showExportLog+		buildExportLog 			. changeMapLog c ep exported  			. M.mapWithKey (updateothers c u) 			. parseExportLog@@ -92,34 +97,38 @@ 		<$> Annex.Branch.get exportLog 	let new = old { incompleteExportedTreeish = nub (newtree:incompleteExportedTreeish old) } 	Annex.Branch.change exportLog $-		showExportLog +		buildExportLog  			. changeMapLog c ep new 			. parseExportLog 	Annex.Branch.graftTreeish newtree (asTopFilePath "export.tree") -parseExportLog :: String -> MapLog ExportParticipants Exported-parseExportLog = parseMapLog parseExportParticipants parseExported+parseExportLog :: L.ByteString -> MapLog ExportParticipants Exported+parseExportLog = parseMapLog exportParticipantsParser exportedParser -showExportLog :: MapLog ExportParticipants Exported -> String-showExportLog = showMapLog formatExportParticipants formatExported+buildExportLog :: MapLog ExportParticipants Exported -> Builder+buildExportLog = buildMapLog buildExportParticipants buildExported -formatExportParticipants :: ExportParticipants -> String-formatExportParticipants ep = -	fromUUID (exportFrom ep) ++ ':' : fromUUID (exportTo ep)+buildExportParticipants :: ExportParticipants -> Builder+buildExportParticipants ep = +	buildUUID (exportFrom ep) <> sep <> buildUUID (exportTo ep)+  where+	sep = charUtf8 ':' -parseExportParticipants :: String -> Maybe ExportParticipants-parseExportParticipants s = case separate (== ':') s of-	("",_) -> Nothing-	(_,"") -> Nothing-	(f,t) -> Just $ ExportParticipants-		{ exportFrom = toUUID f-		, exportTo = toUUID t-		}-formatExported :: Exported -> String-formatExported exported = unwords $ map Git.fromRef $-	exportedTreeish exported : incompleteExportedTreeish exported+exportParticipantsParser :: A.Parser ExportParticipants+exportParticipantsParser = ExportParticipants+	<$> (toUUID <$> A8.takeWhile1 (/= ':'))+	<* A8.char ':'+	<*> (toUUID <$> A8.takeWhile1 (const True)) -parseExported :: String -> Maybe Exported-parseExported s = case words s of-	(et:it) -> Just $ Exported (Git.Ref et) (map Git.Ref it)-	_ -> Nothing+buildExported :: Exported -> Builder+buildExported exported = go (exportedTreeish exported : incompleteExportedTreeish exported)+  where+	go [] = mempty+	go (r:rs) = rref r <> mconcat [ charUtf8 ' ' <> rref r' | r' <- rs ]+	rref r = byteString (encodeBS' (Git.fromRef r))++exportedParser :: A.Parser Exported+exportedParser = Exported <$> refparser <*> many refparser+  where+	refparser = (Git.Ref . decodeBS <$> A8.takeWhile1 (/= ' ') )+		<* ((const () <$> A8.char ' ') <|> A.endOfInput)
Logs/Group.hs view
@@ -1,6 +1,6 @@ {- git-annex group log  -- - Copyright 2012 Joey Hess <id@joeyh.name>+ - Copyright 2012, 2019 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -18,6 +18,9 @@  import qualified Data.Map as M import qualified Data.Set as S+import qualified Data.Attoparsec.ByteString as A+import qualified Data.Attoparsec.ByteString.Char8 as A8+import Data.ByteString.Builder  import Annex.Common import Logs@@ -37,9 +40,7 @@ 	curr <- lookupGroups uuid 	c <- liftIO currentVectorClock 	Annex.Branch.change groupLog $-		showLog (unwords . S.toList) .-			changeLog c uuid (modifier curr) .-				parseLog (Just . S.fromList . words)+		buildLog buildGroup . changeLog c uuid (modifier curr) . parseLog parseGroup 	 	-- The changed group invalidates the preferred content cache. 	Annex.changeState $ \s -> s@@ -48,6 +49,23 @@ 		} groupChange NoUUID _ = error "unknown UUID; cannot modify" +buildGroup :: S.Set Group -> Builder+buildGroup = go . S.toList+  where+	go [] = mempty+	go (g:gs) = bld g <> mconcat [ charUtf8 ' ' <> bld g' | g' <- gs ]+	bld (Group g) = byteString g++parseGroup :: A.Parser (S.Set Group)+parseGroup = S.fromList <$> go []+  where+	go l = (A.endOfInput *> pure l)+		<|> ((getgroup <* A8.char ' ') >>= go . (:l))+		<|> ((:l) <$> getgroup)+		-- allow extra writespace before or after a group name+		<|> (A8.char ' ' >>= const (go l))+	getgroup = Group <$> A8.takeWhile1 (/= ' ')+ groupSet :: UUID -> S.Set Group -> Annex () groupSet u g = groupChange u (const g) @@ -58,9 +76,7 @@ {- Loads the map, updating the cache. -} groupMapLoad :: Annex GroupMap groupMapLoad = do-	m <- makeGroupMap . simpleMap .-		parseLog (Just . S.fromList . words) <$>-			Annex.Branch.get groupLog+	m <- makeGroupMap . simpleMap . parseLog parseGroup <$> Annex.Branch.get groupLog 	Annex.changeState $ \s -> s { Annex.groupmap = Just m } 	return m
Logs/Line.hs view
@@ -1,51 +1,38 @@-{- --The Glasgow Haskell Compiler License--Copyright 2001, The University Court of the University of Glasgow.-All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:--- Redistributions of source code must retain the above copyright notice,-this list of conditions and the following disclaimer.--- Redistributions in binary form must reproduce the above copyright notice,-this list of conditions and the following disclaimer in the documentation-and/or other materials provided with the distribution.--- Neither name of the University nor the names of its contributors may be-used to endorse or promote products derived from this software without-specific prior written permission.+{- line based log files+ -+ - Copyright 2019 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -} -THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF-GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,-INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND-FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE-UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE-FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL-DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR-SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER-CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT-LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY-OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH-DAMAGE.+module Logs.Line where --}+import Common -module Logs.Line where+import qualified Data.Attoparsec.ByteString.Lazy as A+import Data.Attoparsec.ByteString.Char8 (isEndOfLine)+import qualified Data.DList as D --- This is the same as Data.List.lines, with \r added.--- This works around some versions of git-annex which wrote \r--- into git-annex branch files on Windows. Those \r's sometimes--- accumulated over time, so a single line could end with multiple \r's--- before the \n.-splitLines :: String -> [String]-splitLines "" =  []-splitLines s =  cons (case break (\c -> c == '\n' || c == '\r') s of-	(l, s') -> (l, case s' of-		[]      -> []-		_:s''   -> splitLines s''))+{- Applies a parser to each line of a log file.+ -+ - If the parser fails to parse a line, that line is skipped, instead of+ - the overall parse failing. This is generally a good idea in case a newer+ - version of git-annex somehow changed the format of the log file.+ -+ - Any combination of \r and \n are taken to be the end of the line.+ - (Some versions of git-annex on Windows wrote \r into git-annex branch+ - files, and multiple \r's sometimes accumulated.)+ -+ - The parser does not itself need to avoid parsing beyond the end of line;+ - this is implemented only pass the content of a line to the parser.+ -}+parseLogLines :: A.Parser a -> A.Parser [a]+parseLogLines parser = go D.empty   where-	cons ~(h, t) = h : t+	go dl = do+		line <- A.takeTill isEndOfLine+		A.skipWhile isEndOfLine+		let dl' = case A.parseOnly parser line of+			Left _ -> dl+			Right v -> D.snoc dl v+		(A.endOfInput *> return (D.toList dl')) <|> go dl'
Logs/Location.hs view
@@ -41,7 +41,6 @@ import qualified Annex  import Data.Time.Clock-import qualified Data.ByteString.Lazy.Char8 as L  {- Log a change in the presence of a key's value in current repository. -} logStatus :: Key -> LogStatus -> Annex ()@@ -53,10 +52,10 @@ logChange :: Key -> UUID -> LogStatus -> Annex () logChange = logChange' logNow -logChange' :: (LogStatus -> String -> Annex LogLine) -> Key -> UUID -> LogStatus -> Annex ()-logChange' mklog key (UUID u) s = do+logChange' :: (LogStatus -> LogInfo -> Annex LogLine) -> Key -> UUID -> LogStatus -> Annex ()+logChange' mklog key u@(UUID _) s = do 	config <- Annex.getGitConfig-	maybeAddLog (locationLogFile config key) =<< mklog s u+	maybeAddLog (locationLogFile config key) =<< mklog s (LogInfo (fromUUID u)) logChange' _ _ NoUUID _ = noop  {- Returns a list of repository UUIDs that, according to the log, have@@ -70,12 +69,12 @@  {- Gets the locations contained in a git ref. -} loggedLocationsRef :: Ref -> Annex [UUID]-loggedLocationsRef ref = map toUUID . getLog . L.unpack <$> catObject ref+loggedLocationsRef ref = map (toUUID . fromLogInfo) . getLog <$> catObject ref -getLoggedLocations :: (FilePath -> Annex [String]) -> Key -> Annex [UUID]+getLoggedLocations :: (FilePath -> Annex [LogInfo]) -> Key -> Annex [UUID] getLoggedLocations getter key = do 	config <- Annex.getGitConfig-	map toUUID <$> getter (locationLogFile config key)+	map (toUUID . fromLogInfo) <$> getter (locationLogFile config key)  {- Is there a location log for the key? True even for keys with no  - remaining locations. -}
Logs/MapLog.hs view
@@ -1,13 +1,13 @@-{-# LANGUAGE CPP #-}- {- git-annex Map log  -  - This is used to store a Map, in a way that can be union merged.  -  - A line of the log will look like: "timestamp field value"  -- - Copyright 2014 Joey Hess <id@joeyh.name>+ - The field names cannot contain whitespace.  -+ - Copyright 2014, 2019 Joey Hess <id@joeyh.name>+ -  - Licensed under the GNU GPL version 3 or higher.  -} @@ -21,34 +21,46 @@ import Annex.VectorClock import Logs.Line +import qualified Data.ByteString.Lazy as L import qualified Data.Map.Strict as M+import qualified Data.Attoparsec.ByteString.Lazy as A+import qualified Data.Attoparsec.ByteString.Char8 as A8+import Data.ByteString.Builder  data LogEntry v = LogEntry 	{ changed :: VectorClock 	, value :: v-	} deriving (Eq)+	} deriving (Eq, Show)  type MapLog f v = M.Map f (LogEntry v) -showMapLog :: (f -> String) -> (v -> String) -> MapLog f v -> String-showMapLog fieldshower valueshower = unlines . map showpair . M.toList+buildMapLog :: (f -> Builder) -> (v -> Builder) -> MapLog f v -> Builder+buildMapLog fieldbuilder valuebuilder = mconcat . map genline . M.toList   where-	showpair (f, LogEntry (VectorClock c) v) =-		unwords [show c, fieldshower f, valueshower v]-	showpair (f, LogEntry Unknown v) =-		unwords ["0", fieldshower f, valueshower v]+	genline (f, LogEntry c v) = +		buildVectorClock c <> sp +			<> fieldbuilder f <> sp +			<> valuebuilder v <> nl+	sp = charUtf8 ' '+	nl = charUtf8 '\n' -parseMapLog :: Ord f => (String -> Maybe f) -> (String -> Maybe v) -> String -> MapLog f v-parseMapLog fieldparser valueparser = M.fromListWith best . mapMaybe parse . splitLines+parseMapLog :: Ord f => A.Parser f -> A.Parser v -> L.ByteString -> MapLog f v+parseMapLog fieldparser valueparser = fromMaybe M.empty . A.maybeResult +	. A.parse (mapLogParser fieldparser valueparser)++mapLogParser :: Ord f => A.Parser f -> A.Parser v -> A.Parser (MapLog f v)+mapLogParser fieldparser valueparser = M.fromListWith best <$> parseLogLines go   where-	parse line = do-		let (sc, rest) = splitword line-		    (sf, sv) = splitword rest-		c <- parseVectorClock sc-		f <- fieldparser sf-		v <- valueparser sv-		Just (f, LogEntry c v)-	splitword = separate (== ' ')+	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)  changeMapLog :: Ord f => VectorClock -> f -> v -> MapLog f v -> MapLog f v changeMapLog c f v = M.insert f $ LogEntry c v
Logs/MetaData.hs view
@@ -78,7 +78,7 @@ 		let MetaData m = value l 		    ts = lastchangedval l 		in M.map (const ts) m-	lastchangedval l = S.singleton $ toMetaValue $ showts $ +	lastchangedval l = S.singleton $ toMetaValue $ encodeBS $ showts $  		case changed l of 			VectorClock t -> t 			Unknown -> 0@@ -110,7 +110,7 @@ 	| otherwise = do 		config <- Annex.getGitConfig 		Annex.Branch.change (getlogfile config k) $-			showLog . simplifyLog +			buildLog . simplifyLog  				. S.insert (LogEntry c metadata) 				. parseLog   where@@ -145,7 +145,7 @@ 			else do 				config <- Annex.getGitConfig 				Annex.Branch.change (metaDataLogFile config newkey) $-					const $ showLog l+					const $ buildLog l 				return True  readLog :: FilePath -> Annex (Log MetaData)
Logs/MetaData/Pure.hs view
@@ -11,7 +11,7 @@ 	Log, 	LogEntry(..), 	parseLog,-	showLog,+	buildLog, 	logToCurrentMetaData, 	simplifyLog, 	filterRemoteMetaData,
Logs/Multicast.hs view
@@ -1,6 +1,6 @@ {- git-annex multicast fingerprint log  -- - Copyright 2017 Joey Hess <id@joeyh.name>+ - Copyright 2017, 2019 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -17,6 +17,8 @@ import Logs.UUIDBased  import qualified Data.Map as M+import qualified Data.Attoparsec.ByteString.Lazy as A+import Data.ByteString.Builder  newtype Fingerprint = Fingerprint String 	deriving (Eq, Read, Show)@@ -25,7 +27,17 @@ recordFingerprint fp uuid = do 	c <- liftIO currentVectorClock 	Annex.Branch.change multicastLog $-		showLog show . changeLog c uuid fp . parseLog readish+		buildLog buildFindgerPrint+			. changeLog c uuid fp+			. parseLog fingerprintParser  knownFingerPrints :: Annex (M.Map UUID Fingerprint)-knownFingerPrints = simpleMap . parseLog readish <$> Annex.Branch.get activityLog+knownFingerPrints = simpleMap . parseLog fingerprintParser+	<$> Annex.Branch.get activityLog++fingerprintParser :: A.Parser Fingerprint+fingerprintParser = maybe (fail "fingerprint parse failed") pure +	. readish . decodeBS =<< A.takeByteString++buildFindgerPrint :: Fingerprint -> Builder+buildFindgerPrint = byteString . encodeBS . show
Logs/NumCopies.hs view
@@ -20,8 +20,8 @@ import Logs.SingleValue  instance SingleValueSerializable NumCopies where-	serialize (NumCopies n) = show n-	deserialize = NumCopies <$$> readish+	serialize (NumCopies n) = encodeBS (show n)+	deserialize = NumCopies <$$> readish . decodeBS  setGlobalNumCopies :: NumCopies -> Annex () setGlobalNumCopies new = do
Logs/PreferredContent.hs view
@@ -1,6 +1,6 @@ {- git-annex preferred content matcher configuration  -- - Copyright 2012-2014 Joey Hess <id@joeyh.name>+ - Copyright 2012-2019 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -26,6 +26,7 @@ import qualified Data.Map as M import qualified Data.Set as S import Data.Either+import qualified Data.Attoparsec.ByteString.Lazy as A  import Annex.Common import Logs.PreferredContent.Raw@@ -73,7 +74,7 @@ 	groupmap <- groupMap 	configmap <- readRemoteLog 	let genmap l gm = simpleMap-		. parseLogWithUUID ((Just .) . makeMatcher groupmap configmap gm)+		. parseLogWithUUID (\u -> makeMatcher groupmap configmap gm u . decodeBS <$> A.takeByteString) 		<$> Annex.Branch.get l 	pc <- genmap preferredContentLog =<< groupPreferredContentMapRaw 	rc <- genmap requiredContentLog M.empty
Logs/PreferredContent/Raw.hs view
@@ -1,6 +1,6 @@ {- unparsed preferred content expressions  -- - Copyright 2012-2014 Joey Hess <id@joeyh.name>+ - Copyright 2012-2019 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -17,6 +17,9 @@ import Types.Group  import qualified Data.Map as M+import qualified Data.ByteString.Lazy as L+import qualified Data.Attoparsec.ByteString.Lazy as A+import Data.ByteString.Builder  {- Changes the preferred content configuration of a remote. -} preferredContentSet :: UUID -> PreferredContentExpression -> Annex ()@@ -29,9 +32,9 @@ setLog logfile uuid@(UUID _) val = do 	c <- liftIO currentVectorClock 	Annex.Branch.change logfile $-		showLog id+		buildLog buildPreferredContentExpression 		. changeLog c uuid val-		. parseLog Just+		. parseLog parsePreferredContentExpression 	Annex.changeState $ \s -> s  		{ Annex.preferredcontentmap = Nothing 		, Annex.requiredcontentmap = Nothing@@ -43,19 +46,37 @@ groupPreferredContentSet g val = do 	c <- liftIO currentVectorClock 	Annex.Branch.change groupPreferredContentLog $-		showMapLog id id +		buildGroupPreferredContent 		. changeMapLog c g val -		. parseMapLog Just Just+		. parseGroupPreferredContent 	Annex.changeState $ \s -> s { Annex.preferredcontentmap = Nothing } +parseGroupPreferredContent :: L.ByteString -> MapLog Group String+parseGroupPreferredContent = parseMapLog parsegroup parsestring+  where+	parsegroup = Group <$> A.takeByteString+	parsestring = decodeBS <$> A.takeByteString++buildGroupPreferredContent :: MapLog Group PreferredContentExpression -> Builder+buildGroupPreferredContent = buildMapLog buildgroup buildexpr+  where+	buildgroup (Group g) = byteString g+	buildexpr = byteString . encodeBS++parsePreferredContentExpression :: A.Parser PreferredContentExpression+parsePreferredContentExpression = decodeBS <$> A.takeByteString++buildPreferredContentExpression :: PreferredContentExpression -> Builder+buildPreferredContentExpression = byteString . encodeBS+ preferredContentMapRaw :: Annex (M.Map UUID PreferredContentExpression)-preferredContentMapRaw = simpleMap . parseLog Just+preferredContentMapRaw = simpleMap . parseLog parsePreferredContentExpression 	<$> Annex.Branch.get preferredContentLog  requiredContentMapRaw :: Annex (M.Map UUID PreferredContentExpression)-requiredContentMapRaw = simpleMap . parseLog Just+requiredContentMapRaw = simpleMap . parseLog parsePreferredContentExpression 	<$> Annex.Branch.get requiredContentLog  groupPreferredContentMapRaw :: Annex (M.Map Group PreferredContentExpression)-groupPreferredContentMapRaw = simpleMap . parseMapLog Just Just+groupPreferredContentMapRaw = simpleMap . parseGroupPreferredContent 	<$> Annex.Branch.get groupPreferredContentLog
Logs/Presence.hs view
@@ -31,8 +31,8 @@ {- Adds a LogLine to the log, removing any LogLines that are obsoleted by  - adding it. -} addLog :: FilePath -> LogLine -> Annex ()-addLog file line = Annex.Branch.change file $ \s ->-	showLog $ compactLog (line : parseLog s)+addLog file line = Annex.Branch.change file $ \b ->+	buildLog $ compactLog (line : parseLog b)  {- When a LogLine already exists with the same status and info, but an  - older timestamp, that LogLine is preserved, rather than updating the log@@ -41,7 +41,7 @@ maybeAddLog :: FilePath -> LogLine -> Annex () maybeAddLog file line = Annex.Branch.maybeChange file $ \s -> do 	m <- insertNewStatus line $ logMap $ parseLog s-	return $ showLog $ mapLog m+	return $ buildLog $ mapLog m  {- Reads a log file.  - Note that the LogLines returned may be in any order. -}@@ -49,13 +49,13 @@ readLog = parseLog <$$> Annex.Branch.get  {- Generates a new LogLine with the current time. -}-logNow :: LogStatus -> String -> Annex LogLine+logNow :: LogStatus -> LogInfo -> Annex LogLine logNow s i = do 	c <- liftIO currentVectorClock 	return $ LogLine c s i  {- Reads a log and returns only the info that is still in effect. -}-currentLogInfo :: FilePath -> Annex [String]+currentLogInfo :: FilePath -> Annex [LogInfo] currentLogInfo file = map info <$> currentLog file  currentLog :: FilePath -> Annex [LogLine]@@ -66,6 +66,6 @@  -  - The date is formatted as shown in gitrevisions man page.  -}-historicalLogInfo :: RefDate -> FilePath -> Annex [String]+historicalLogInfo :: RefDate -> FilePath -> Annex [LogInfo] historicalLogInfo refdate file = map info . filterPresent . parseLog 	<$> Annex.Branch.getHistorical refdate file
Logs/Presence/Pure.hs view
@@ -1,6 +1,6 @@ {- git-annex presence log, pure operations  -- - Copyright 2010-2013 Joey Hess <id@joeyh.name>+ - Copyright 2010-2019 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -13,48 +13,64 @@ import Utility.QuickCheck  import qualified Data.Map as M+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as C8+import qualified Data.Attoparsec.ByteString.Lazy as A+import Data.Attoparsec.ByteString.Char8 (char, anyChar)+import Data.ByteString.Builder +newtype LogInfo = LogInfo { fromLogInfo :: S.ByteString }+	deriving (Show, Eq, Ord)+ data LogLine = LogLine 	{ date :: VectorClock 	, status :: LogStatus-	, info :: String-	} deriving (Eq)--instance Show LogLine where-	show l = "LogLine " ++ formatVectorClock (date l) ++ show (status l) ++ " " ++ show (info l)+	, info :: LogInfo+	} deriving (Eq, Show)  data LogStatus = InfoPresent | InfoMissing | InfoDead 	deriving (Eq, Show, Bounded, Enum) -{- Parses a log file. Unparseable lines are ignored. -}-parseLog :: String -> [LogLine]-parseLog = mapMaybe parseline . splitLines-  where-	parseline l = LogLine-		<$> parseVectorClock c-		<*> parseStatus s-		<*> pure rest-	  where-		(c, pastc) = separate (== ' ') l-		(s, rest) = separate (== ' ') pastc+parseLog :: L.ByteString -> [LogLine]+parseLog = fromMaybe [] . A.maybeResult . A.parse logParser +logParser :: A.Parser [LogLine]+logParser = parseLogLines $ LogLine+	<$> vectorClockParser+	<* char ' '+	<*> statusParser+	<* char ' '+	<*> (LogInfo <$> A.takeByteString)++statusParser :: A.Parser LogStatus+statusParser = do+	c <- anyChar+	case c of+		'1' -> return InfoPresent+		'0' -> return InfoMissing+		'X' -> return InfoDead+		_ -> fail "unknown status character"+ parseStatus :: String -> Maybe LogStatus parseStatus "1" = Just InfoPresent parseStatus "0" = Just InfoMissing parseStatus "X" = Just InfoDead parseStatus _ = Nothing -{- Generates a log file. -}-showLog :: [LogLine] -> String-showLog = unlines . map genline+buildLog :: [LogLine] -> Builder+buildLog = mconcat . map genline   where-	genline (LogLine c s i) = unwords [formatVectorClock c, genstatus s, i]-	genstatus InfoPresent = "1"-	genstatus InfoMissing = "0"-	genstatus InfoDead = "X"+	genline (LogLine c s (LogInfo i)) = +		buildVectorClock c <> sp <> genstatus s <> sp <> byteString i <> nl+	sp = charUtf8 ' '+	nl = charUtf8 '\n'+	genstatus InfoPresent = charUtf8 '1'+	genstatus InfoMissing = charUtf8 '0'+	genstatus InfoDead = charUtf8 'X'  {- Given a log, returns only the info that is are still in effect. -}-getLog :: String -> [String]+getLog :: L.ByteString -> [LogInfo] getLog = map info . filterPresent . parseLog  {- Returns the info from LogLines that are in effect. -}@@ -66,7 +82,7 @@ compactLog :: [LogLine] -> [LogLine] compactLog = mapLog . logMap -type LogMap = M.Map String LogLine+type LogMap = M.Map LogInfo LogLine  mapLog :: LogMap -> [LogLine] mapLog = M.elems@@ -101,9 +117,11 @@ 	arbitrary = LogLine 		<$> arbitrary 		<*> elements [minBound..maxBound]-		<*> arbitrary `suchThat`-			(\c -> '\n' `notElem` c && '\r' `notElem` c)+		<*> (LogInfo <$> arbinfo)+	  where+		arbinfo = (encodeBS <$> arbitrary) `suchThat`+			(\b -> C8.notElem '\n' b && C8.notElem '\r' b) -prop_parse_show_log :: [LogLine] -> Bool-prop_parse_show_log l = parseLog (showLog l) == l+prop_parse_build_log :: [LogLine] -> Bool+prop_parse_build_log l = parseLog (toLazyByteString (buildLog l)) == l
Logs/Remote.hs view
@@ -12,7 +12,6 @@ 	keyValToConfig, 	configToKeyVal, 	showConfig,-	parseConfig,  	prop_isomorphic_configEscape, 	prop_parse_show_Config,@@ -26,20 +25,25 @@  import qualified Data.Map as M import Data.Char+import qualified Data.Attoparsec.ByteString.Lazy as A+import Data.ByteString.Builder  {- Adds or updates a remote's config in the log. -} configSet :: UUID -> RemoteConfig -> Annex () configSet u cfg = do 	c <- liftIO currentVectorClock 	Annex.Branch.change remoteLog $-		showLog showConfig . changeLog c u cfg . parseLog parseConfig+		buildLog (byteString . encodeBS . showConfig)+			. changeLog c u cfg+			. parseLog remoteConfigParser  {- Map of remotes by uuid containing key/value config maps. -} readRemoteLog :: Annex (M.Map UUID RemoteConfig)-readRemoteLog = simpleMap . parseLog parseConfig <$> Annex.Branch.get remoteLog+readRemoteLog = simpleMap . parseLog remoteConfigParser+	<$> Annex.Branch.get remoteLog -parseConfig :: String -> Maybe RemoteConfig-parseConfig = Just . keyValToConfig . words+remoteConfigParser :: A.Parser RemoteConfig+remoteConfigParser = keyValToConfig . words . decodeBS <$> A.takeByteString  showConfig :: RemoteConfig -> String showConfig = unwords . configToKeyVal@@ -88,9 +92,16 @@  prop_parse_show_Config :: RemoteConfig -> Bool prop_parse_show_Config c-	-- whitespace and '=' are not supported in keys+	-- whitespace and '=' are not supported in config keys 	| any (\k -> any isSpace k || elem '=' k) (M.keys c) = True-	| otherwise = parseConfig (showConfig c) ~~ Just c+	| any (any excluded) (M.keys c) = True+	| any (any excluded) (M.elems c) = True+	| otherwise = A.parseOnly remoteConfigParser (encodeBS $ showConfig c) ~~ Right c   where 	normalize v = sort . M.toList <$> v 	a ~~ b = normalize a == normalize b+	-- limit to ascii alphanumerics for simplicity; characters not+	-- allowed by the current character set in the config may not+	-- round-trip in an identical representation due to the use of the+	-- filesystem encoding.+	excluded ch = not (isAlphaNum ch) || not (isAscii ch)
Logs/RemoteState.hs view
@@ -1,6 +1,6 @@ {- Remote state logs.  -- - Copyright 2014 Joey Hess <id@joeyh.name>+ - Copyright 2014, 2019 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -17,6 +17,9 @@ import qualified Annex  import qualified Data.Map as M+import qualified Data.ByteString.Lazy as L+import qualified Data.Attoparsec.ByteString.Lazy as A+import Data.ByteString.Builder  type RemoteState = String @@ -25,12 +28,18 @@ 	c <- liftIO currentVectorClock 	config <- Annex.getGitConfig 	Annex.Branch.change (remoteStateLogFile config k) $-		showLogNew id . changeLog c u s . parseLogNew Just+		buildRemoteState . changeLog c u s . parseRemoteState +buildRemoteState :: Log RemoteState -> Builder+buildRemoteState = buildLogNew (byteString . encodeBS)+ getRemoteState :: UUID -> Key -> Annex (Maybe RemoteState) getRemoteState u k = do 	config <- Annex.getGitConfig-	extract . parseLogNew Just+	extract . parseRemoteState 		<$> Annex.Branch.get (remoteStateLogFile config k)   where 	extract m = value <$> M.lookup u m++parseRemoteState :: L.ByteString -> Log RemoteState+parseRemoteState = parseLogNew (decodeBS <$> A.takeByteString)
Logs/Schedule.hs view
@@ -20,6 +20,8 @@ import qualified Data.Map as M import qualified Data.Set as S import Data.Time.LocalTime+import qualified Data.Attoparsec.ByteString.Lazy as A+import Data.ByteString.Builder  import Annex.Common import Types.ScheduledActivity@@ -32,17 +34,18 @@ scheduleSet uuid@(UUID _) activities = do 	c <- liftIO currentVectorClock 	Annex.Branch.change scheduleLog $-		showLog id . changeLog c uuid val . parseLog Just+		buildLog byteString +			. changeLog c uuid (encodeBS val)+			. parseLog A.takeByteString   where 	val = fromScheduledActivities activities scheduleSet NoUUID _ = error "unknown UUID; cannot modify"  scheduleMap :: Annex (M.Map UUID [ScheduledActivity])-scheduleMap = simpleMap-	. parseLogWithUUID parser-	<$> Annex.Branch.get scheduleLog+scheduleMap = simpleMap . parseLog parser <$> Annex.Branch.get scheduleLog   where-	parser _uuid = eitherToMaybe . parseScheduledActivities+	parser = either fail pure . parseScheduledActivities . decodeBS +		=<< A.takeByteString  scheduleGet :: UUID -> Annex (S.Set ScheduledActivity) scheduleGet u = do
Logs/SingleValue.hs view
@@ -35,4 +35,4 @@ setLog f v = do 	c <- liftIO currentVectorClock 	let ent = LogEntry c v-	Annex.Branch.change f $ \_old -> showLog (S.singleton ent)+	Annex.Branch.change f $ \_old -> buildLog (S.singleton ent)
Logs/SingleValue/Pure.hs view
@@ -1,6 +1,6 @@ {- git-annex single-value log, pure operations  -- - Copyright 2014 Joey Hess <id@joeyh.name>+ - Copyright 2014-2019 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -12,10 +12,15 @@ import Annex.VectorClock  import qualified Data.Set as S+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import qualified Data.Attoparsec.ByteString.Lazy as A+import Data.Attoparsec.ByteString.Char8 (char)+import Data.ByteString.Builder  class SingleValueSerializable v where-	serialize :: v -> String-	deserialize :: String -> Maybe v+	serialize :: v -> B.ByteString+	deserialize :: B.ByteString -> Maybe v  data LogEntry v = LogEntry 	{ changed :: VectorClock@@ -24,20 +29,25 @@  type Log v = S.Set (LogEntry v) -showLog :: (SingleValueSerializable v) => Log v -> String-showLog = unlines . map showline . S.toList+buildLog :: (SingleValueSerializable v) => Log v -> Builder+buildLog = mconcat . map genline . S.toList   where-	showline (LogEntry c v) = unwords [formatVectorClock c, serialize v]+	genline (LogEntry c v) =+		buildVectorClock c <> sp <> byteString (serialize v) <> nl+	sp = charUtf8 ' '+	nl = charUtf8 '\n' -parseLog :: (Ord v, SingleValueSerializable v) => String -> Log v-parseLog = S.fromList . mapMaybe parse . splitLines+parseLog :: (Ord v, SingleValueSerializable v) => L.ByteString -> Log v+parseLog = S.fromList . fromMaybe [] +	. A.maybeResult . A.parse (logParser <* A.endOfInput)++logParser :: SingleValueSerializable v => A.Parser [LogEntry v]+logParser = parseLogLines $ LogEntry+	<$> vectorClockParser+	<* char ' '+	<*> (parsevalue =<< A.takeByteString)   where-	parse line = do-		let (sc, s) = splitword line-		c <- parseVectorClock sc-		v <- deserialize s-		Just (LogEntry c v)-	splitword = separate (== ' ')+	parsevalue = maybe (fail "log line parse failure") return . deserialize  newestValue :: Log v -> Maybe v newestValue s
Logs/Smudge.hs view
@@ -16,7 +16,7 @@ smudgeLog k f = do 	logf <- fromRepo gitAnnexSmudgeLog 	appendLogFile logf gitAnnexSmudgeLock $ -		key2file k ++ " " ++ getTopFilePath f+		serializeKey k ++ " " ++ getTopFilePath f  -- | Streams all smudged files, and then empties the log at the end. --@@ -36,5 +36,5 @@ 	parse l =  		let (ks, f) = separate (== ' ') l 		in do-			k <- file2key ks+			k <- deserializeKey ks 			return (k, asTopFilePath f)
Logs/Transitions.hs view
@@ -7,7 +7,7 @@  - done that is listed in the remote branch by checking that the local  - branch contains the same transition, with the same or newer start time.  -- - Copyright 2013 Joey Hess <id@joeyh.name>+ - Copyright 2013-2019 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -19,6 +19,12 @@ import Logs.Line  import qualified Data.Set as S+import Data.Either+import Data.ByteString (ByteString)+import Data.ByteString.Builder+import qualified Data.ByteString.Lazy as L+import qualified Data.Attoparsec.ByteString.Lazy as A+import qualified Data.Attoparsec.ByteString.Char8 as A8  transitionsLog :: FilePath transitionsLog = "transitions.log"@@ -30,7 +36,8 @@  data TransitionLine = TransitionLine 	{ transitionStarted :: VectorClock-	, transition :: Transition+	-- New transitions that we don't know about yet are preserved.+	, transition :: Either ByteString Transition 	} deriving (Ord, Eq)  type Transitions = S.Set TransitionLine@@ -43,44 +50,50 @@ noTransitions = S.empty  addTransition :: VectorClock -> Transition -> Transitions -> Transitions-addTransition c t = S.insert $ TransitionLine c t--showTransitions :: Transitions -> String-showTransitions = unlines . map showTransitionLine . S.elems+addTransition c t = S.insert $ TransitionLine c (Right t) -{- If the log contains new transitions we don't support, returns Nothing. -}-parseTransitions :: String -> Maybe Transitions-parseTransitions = check . map parseTransitionLine . splitLines+buildTransitions :: Transitions -> Builder+buildTransitions = mconcat . map genline . S.elems   where-	check l-		| all isJust l = Just $ S.fromList $ catMaybes l-		| otherwise = Nothing+	genline tl = buildt (transition tl) <> charUtf8 ' '+		<> buildVectorClock (transitionStarted tl) <> charUtf8 '\n'+	buildt (Left b) = byteString b+	buildt (Right t) = byteString (encodeBS (show t)) -parseTransitionsStrictly :: String -> String -> Transitions-parseTransitionsStrictly source = fromMaybe badsource . parseTransitions-  where-	badsource = giveup $ "unknown transitions listed in " ++ source ++ "; upgrade git-annex!"+parseTransitions :: L.ByteString -> Transitions+parseTransitions = fromMaybe S.empty . A.maybeResult . A.parse+	(S.fromList <$> parseLogLines transitionLineParser) +parseTransitionsStrictly :: String -> L.ByteString -> Transitions+parseTransitionsStrictly source b =+	let ts = parseTransitions b+	in if S.null $ S.filter (isLeft . transition) ts+		then ts+		else giveup $ "unknown transitions listed in " ++ source ++ "; upgrade git-annex!"+ showTransitionLine :: TransitionLine -> String showTransitionLine (TransitionLine c t) = unwords [show t, formatVectorClock c] -parseTransitionLine :: String -> Maybe TransitionLine-parseTransitionLine s = TransitionLine-	<$> parseVectorClock cs-	<*> readish ts+transitionLineParser :: A.Parser TransitionLine+transitionLineParser = do+	t <- (parsetransition <$> A.takeByteString)+	_ <- A8.char ' '+	c <- vectorClockParser+	return $ TransitionLine c t   where-	ws = words s-	ts = Prelude.head ws-	cs = unwords $ Prelude.tail ws+	parsetransition b = case readish (decodeBS b) of+		Just t -> Right t+		Nothing -> Left b  combineTransitions :: [Transitions] -> Transitions combineTransitions = S.unions -transitionList :: Transitions -> [Transition]-transitionList = nub . map transition . S.elems+{- Unknown types of transitions are omitted. -}+knownTransitionList :: Transitions -> [Transition]+knownTransitionList = nub . rights . map transition . S.elems  {- Typically ran with Annex.Branch.change, but we can't import Annex.Branch  - here since it depends on this module. -}-recordTransitions :: (FilePath -> (String -> String) -> Annex ()) -> Transitions -> Annex ()+recordTransitions :: (FilePath -> (L.ByteString -> Builder) -> Annex ()) -> Transitions -> Annex () recordTransitions changer t = changer transitionsLog $-	showTransitions . S.union t . parseTransitionsStrictly "local"+	buildTransitions . S.union t . parseTransitionsStrictly "local"
Logs/Trust/Basic.hs view
@@ -24,9 +24,9 @@ trustSet uuid@(UUID _) level = do 	c <- liftIO currentVectorClock 	Annex.Branch.change trustLog $-		showLog showTrustLog .+		buildLog buildTrustLevel . 			changeLog c uuid level .-				parseLog (Just . parseTrustLog)+				parseLog trustLevelParser 	Annex.changeState $ \s -> s { Annex.trustmap = Nothing } trustSet NoUUID _ = error "unknown UUID; cannot modify"
Logs/Trust/Pure.hs view
@@ -1,36 +1,49 @@ {- git-annex trust log, pure operations  -- - Copyright 2010-2013 Joey Hess <id@joeyh.name>+ - Copyright 2010-2018 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Logs.Trust.Pure where  import Annex.Common import Types.TrustLevel import Logs.UUIDBased -calcTrustMap :: String -> TrustMap-calcTrustMap = simpleMap . parseLog (Just . parseTrustLog)+import qualified Data.ByteString.Lazy as L+import qualified Data.Attoparsec.ByteString.Lazy as A+import qualified Data.Attoparsec.ByteString.Char8 as A8+import Data.ByteString.Builder -{- The trust.log used to only list trusted repos, without a field for the- - trust status, which is why this defaults to Trusted. -}-parseTrustLog :: String -> TrustLevel-parseTrustLog s = maybe Trusted parse $ headMaybe $ words s+calcTrustMap :: L.ByteString -> TrustMap+calcTrustMap = simpleMap . parseLog trustLevelParser++trustLevelParser :: A.Parser TrustLevel+trustLevelParser = (totrust <$> A8.anyChar <* A.endOfInput)+	-- The trust log used to only list trusted repos, without a +	-- value for the trust status+	<|> (const Trusted <$> A.endOfInput)   where-	parse "1" = Trusted-	parse "0" = UnTrusted-	parse "X" = DeadTrusted-	parse _ = SemiTrusted+	totrust '1' = Trusted+	totrust '0' = UnTrusted+	totrust 'X' = DeadTrusted+	-- Allow for future expansion by treating unknown trust levels as+	-- semitrusted.+	totrust _ = SemiTrusted -showTrustLog :: TrustLevel -> String-showTrustLog Trusted = "1"-showTrustLog UnTrusted = "0"-showTrustLog DeadTrusted = "X"-showTrustLog SemiTrusted = "?"+buildTrustLevel :: TrustLevel -> Builder+buildTrustLevel Trusted = byteString "1"+buildTrustLevel UnTrusted = byteString "0"+buildTrustLevel DeadTrusted = byteString "X"+buildTrustLevel SemiTrusted = byteString "?" -prop_parse_show_TrustLog :: Bool-prop_parse_show_TrustLog = all check [minBound .. maxBound]+prop_parse_build_TrustLevelLog :: Bool+prop_parse_build_TrustLevelLog = all check [minBound .. maxBound]   where-	check l = parseTrustLog (showTrustLog l) == l+	check l = +		let v = A.parseOnly trustLevelParser $ L.toStrict $+			toLazyByteString $ buildTrustLevel l+		in v == Right l
Logs/UUID.hs view
@@ -1,14 +1,8 @@-{- git-annex uuids- -- - Each git repository used by git-annex has an annex.uuid setting that- - uniquely identifies that repository.- -- - UUIDs of remotes are cached in git config, using keys named- - remote.<name>.annex-uuid+{- git-annex uuid log  -  - uuid.log stores a list of known uuids, and their descriptions.  -- - Copyright 2010-2012 Joey Hess <id@joeyh.name>+ - Copyright 2010-2019 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -16,8 +10,8 @@ module Logs.UUID ( 	uuidLog, 	describeUUID,-	uuidMap,-	uuidMapLoad+	uuidDescMap,+	uuidDescMapLoad ) where  import Types.UUID@@ -30,57 +24,33 @@ import qualified Annex.UUID  import qualified Data.Map.Strict as M+import qualified Data.ByteString.Lazy as L+import qualified Data.Attoparsec.ByteString.Lazy as A  {- Records a description for a uuid in the log. -}-describeUUID :: UUID -> String -> Annex ()+describeUUID :: UUID -> UUIDDesc -> Annex () describeUUID uuid desc = do 	c <- liftIO currentVectorClock 	Annex.Branch.change uuidLog $-		showLog id . changeLog c uuid desc . fixBadUUID . parseLog Just--{- Temporarily here to fix badly formatted uuid logs generated by- - versions 3.20111105 and 3.20111025. - -- - Those logs contain entries with the UUID and description flipped.- - Due to parsing, if the description is multiword, only the first- - will be taken to be the UUID. So, if the UUID of an entry does- - not look like a UUID, and the last word of the description does,- - flip them back.- -}-fixBadUUID :: Log String -> Log String-fixBadUUID = M.fromList . map fixup . M.toList-  where-	fixup (k, v)-		| isbad = (fixeduuid, LogEntry (newertime v) fixedvalue)-		| otherwise = (k, v)-	  where-		kuuid = fromUUID k-		isbad = not (isuuid kuuid) && not (null ws) && isuuid lastword-		ws = words $ value v-		lastword = Prelude.last ws-		fixeduuid = toUUID lastword-		fixedvalue = unwords $ kuuid: Prelude.init ws-	-- For the fixed line to take precidence, it should be-	-- slightly newer, but only slightly.-	newertime (LogEntry (VectorClock c) _) = VectorClock (c + minimumPOSIXTimeSlice)-	newertime (LogEntry Unknown _) = VectorClock minimumPOSIXTimeSlice-	minimumPOSIXTimeSlice = 0.000001-	isuuid s = length s == 36 && length (splitc '-' s) == 5+		buildLog buildUUIDDesc . changeLog c uuid desc . parseUUIDLog  {- The map is cached for speed. -}-uuidMap :: Annex UUIDMap-uuidMap = maybe uuidMapLoad return =<< Annex.getState Annex.uuidmap+uuidDescMap :: Annex UUIDDescMap+uuidDescMap = maybe uuidDescMapLoad return =<< Annex.getState Annex.uuiddescmap  {- Read the uuidLog into a simple Map.  -  - The UUID of the current repository is included explicitly, since- - it may not have been described and so otherwise would not appear. -}-uuidMapLoad :: Annex UUIDMap-uuidMapLoad = do-	m <- (simpleMap . parseLog Just) <$> Annex.Branch.get uuidLog+ - it may not have been described and otherwise would not appear. -}+uuidDescMapLoad :: Annex UUIDDescMap+uuidDescMapLoad = do+	m <- simpleMap . parseUUIDLog <$> Annex.Branch.get uuidLog 	u <- Annex.UUID.getUUID-	let m' = M.insertWith preferold u "" m-	Annex.changeState $ \s -> s { Annex.uuidmap = Just m' }+	let m' = M.insertWith preferold u mempty m+	Annex.changeState $ \s -> s { Annex.uuiddescmap = Just m' } 	return m'   where 	preferold = flip const++parseUUIDLog :: L.ByteString -> Log UUIDDesc+parseUUIDLog = parseLog (UUIDDesc <$> A.takeByteString)
Logs/UUIDBased.hs view
@@ -9,11 +9,13 @@  -  - New uuid based logs instead use the form: "timestamp UUID INFO"  - - - Copyright 2011-2013 Joey Hess <id@joeyh.name>+ - Copyright 2011-2019 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings, TupleSections #-}+ module Logs.UUIDBased ( 	Log, 	LogEntry(..),@@ -22,8 +24,8 @@ 	parseLog, 	parseLogNew, 	parseLogWithUUID,-	showLog,-	showLogNew,+	buildLog,+	buildLogNew, 	changeLog, 	addLog, 	simpleMap,@@ -37,54 +39,57 @@ import Logs.MapLog import Logs.Line +import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L+import qualified Data.Attoparsec.ByteString.Lazy as A+import qualified Data.Attoparsec.ByteString.Char8 as A8+import Data.ByteString.Builder+import qualified Data.DList as D+ type Log v = MapLog UUID v -showLog :: (v -> String) -> Log v -> String-showLog shower = unlines . map showpair . M.toList+buildLog :: (v -> Builder) -> Log v -> Builder+buildLog builder = mconcat . map genline . M.toList   where-	showpair (k, LogEntry (VectorClock c) v) =-		unwords [fromUUID k, shower v, tskey ++ show c]-	showpair (k, LogEntry Unknown v) =-		unwords [fromUUID k, shower v]+	genline (u, LogEntry c@(VectorClock {}) v) =+		buildUUID u <> sp <> builder v <> sp <>+			byteString "timestamp=" <> buildVectorClock c <> nl+	genline (u, LogEntry Unknown v) =+		buildUUID u <> sp <> builder v <> nl+	sp = charUtf8 ' '+	nl = charUtf8 '\n' -parseLog :: (String -> Maybe a) -> String -> Log a+parseLog :: A.Parser a -> L.ByteString -> Log a parseLog = parseLogWithUUID . const -parseLogWithUUID :: (UUID -> String -> Maybe a) -> String -> Log a-parseLogWithUUID parser = M.fromListWith best . mapMaybe parse . splitLines+parseLogWithUUID :: (UUID -> A.Parser a) -> L.ByteString -> Log a+parseLogWithUUID parser = fromMaybe M.empty . A.maybeResult+	. A.parse (logParser parser)++logParser :: (UUID -> A.Parser a) -> A.Parser (Log a)+logParser parser = M.fromListWith best <$> parseLogLines go   where-	parse line-		-- This is a workaround for a bug that caused-		-- NoUUID items to be stored in the log.-		-- It can be removed at any time; is just here to clean-		-- up logs where that happened temporarily.-		| " " `isPrefixOf` line = Nothing-		| null ws = Nothing-		| otherwise = parser u (unwords info) >>= makepair-	  where-		makepair v = Just (u, LogEntry ts v)-		ws = words line-		u = toUUID $ Prelude.head ws-		t = Prelude.last ws-		ts-			| tskey `isPrefixOf` t = fromMaybe Unknown $-				parseVectorClock $ drop 1 $ dropWhile (/= '=') t-			| otherwise = Unknown-		info-			| ts == Unknown = drop 1 ws-			| otherwise = drop 1 $ beginning ws+	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)+	parsetimestamp = +		(A8.string " timestamp=" *> vectorClockParser <* A.endOfInput)+		<|> (const Unknown <$> A.endOfInput) -showLogNew :: (v -> String) -> Log v -> String-showLogNew = showMapLog fromUUID+buildLogNew :: (v -> Builder) -> Log v -> Builder+buildLogNew = buildMapLog buildUUID -parseLogNew :: (String -> Maybe v) -> String -> Log v-parseLogNew = parseMapLog (Just . toUUID)+parseLogNew :: A.Parser v -> L.ByteString -> Log v+parseLogNew = parseMapLog (toUUID <$> A.takeByteString)  changeLog :: VectorClock -> UUID -> v -> Log v -> Log v changeLog = changeMapLog  addLog :: UUID -> LogEntry v -> Log v -> Log v addLog = addMapLog--tskey :: String-tskey = "timestamp="
Logs/Unused.hs view
@@ -66,8 +66,8 @@ 	logfile <- fromRepo $ gitAnnexUnusedLog prefix 	writeLogFile logfile $ unlines $ map format $ M.toList l   where-	format (k, (i, Just t)) = show i ++ " " ++ key2file k ++ " " ++ show t-	format (k, (i, Nothing)) = show i ++ " " ++ key2file k+	format (k, (i, Just t)) = show i ++ " " ++ serializeKey k ++ " " ++ show t+	format (k, (i, Nothing)) = show i ++ " " ++ serializeKey k  readUnusedLog :: FilePath -> Annex UnusedLog readUnusedLog prefix = do@@ -78,7 +78,7 @@ 		, return M.empty 		)   where-	parse line = case (readish sint, file2key skey, parsePOSIXTime ts) of+	parse line = case (readish sint, deserializeKey skey, parsePOSIXTime ts) of 		(Just int, Just key, mtimestamp) -> Just (key, (int, mtimestamp)) 		_ -> Nothing 	  where
Logs/View.hs view
@@ -28,6 +28,7 @@ import Git.Types import Logs.File +import qualified Data.Text as T import qualified Data.Set as S import Data.Char @@ -74,15 +75,15 @@ 	branchcomp c 		| viewVisible c = branchcomp' c 		| otherwise = "(" ++ branchcomp' c ++ ")"-	branchcomp' (ViewComponent metafield viewfilter _) =concat-		[ forcelegal (fromMetaField metafield)+	branchcomp' (ViewComponent metafield viewfilter _) = concat+		[ forcelegal (T.unpack (fromMetaField metafield)) 		, branchvals viewfilter 		] 	branchvals (FilterValues set) = '=' : branchset set 	branchvals (FilterGlob glob) = '=' : forcelegal glob 	branchvals (ExcludeValues set) = "!=" ++ branchset set 	branchset = intercalate ","-		. map (forcelegal . fromMetaValue)+		. map (forcelegal . decodeBS . fromMetaValue) 		. S.toList 	forcelegal s 		| Git.Ref.legal True s = s
Logs/Web.hs view
@@ -20,7 +20,6 @@ 	removeTempUrl, ) where -import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.Map as M  import Annex.Common@@ -49,7 +48,7 @@ 		us <- currentLogInfo l 		if null us 			then go ls-			else return us+			else return $ map (decodeBS  . fromLogInfo) us  getUrlsWithPrefix :: Key -> String -> Annex [URLString] getUrlsWithPrefix key prefix = filter (prefix `isPrefixOf`) @@ -61,7 +60,8 @@ 	us <- getUrls key 	unless (url `elem` us) $ do 		config <- Annex.getGitConfig-		addLog (urlLogFile config key) =<< logNow InfoPresent url+		addLog (urlLogFile config key)+			=<< logNow InfoPresent (LogInfo (encodeBS url)) 	-- If the url does not have an OtherDownloader, it must be present 	-- in the web. 	case snd (getDownloader url) of@@ -71,7 +71,8 @@ setUrlMissing :: Key -> URLString -> Annex () setUrlMissing key url = do 	config <- Annex.getGitConfig-	addLog (urlLogFile config key) =<< logNow InfoMissing url+	addLog (urlLogFile config key)+		=<< logNow InfoMissing (LogInfo (encodeBS url)) 	-- If the url was a web url (not OtherDownloader) and none of 	-- the remaining urls for the key are web urls, the key must not 	-- be present in the web.@@ -102,7 +103,9 @@ 		Just k -> zip (repeat k) <$> geturls s 		Nothing -> return [] 	geturls Nothing = return []-	geturls (Just logsha) = getLog . L.unpack <$> catObject logsha+	geturls (Just logsha) =+		map (decodeBS . fromLogInfo) . getLog +			<$> catObject logsha  setTempUrl :: Key -> URLString -> Annex () setTempUrl key url = Annex.changeState $ \s ->
Remote.hs view
@@ -1,10 +1,12 @@ {- git-annex remotes  -- - Copyright 2011-2018 Joey Hess <id@joeyh.name>+ - Copyright 2011-2019 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Remote ( 	Remote, 	uuid,@@ -57,6 +59,7 @@ ) where  import Data.Ord+import Data.String import qualified Data.Map as M import qualified Data.Vector as V @@ -92,13 +95,16 @@ {- Map of UUIDs of repositories and their descriptions.  - The names of Remotes are added to suppliment any description that has  - been set for a repository.  -}-uuidDescriptions :: Annex (M.Map UUID String)-uuidDescriptions = M.unionWith addName <$> uuidMap <*> remoteMap name+uuidDescriptions :: Annex UUIDDescMap+uuidDescriptions = M.unionWith addName+	<$> uuidDescMap+	<*> remoteMap (UUIDDesc . encodeBS . name) -addName :: String -> RemoteName -> String+{- Add a remote name to its description. -}+addName :: (IsString t, Monoid t, Eq t) => t -> t -> t addName desc n-	| desc == n || null desc = "[" ++ n ++ "]"-	| otherwise = desc ++ " [" ++ n ++ "]"+	| desc == n || desc == mempty = "[" <> n <> "]"+	| otherwise = desc <> " [" <> n <> "]"  byUUID :: UUID -> Annex (Maybe Remote) byUUID u = headMaybe . filter matching <$> remoteList@@ -170,8 +176,9 @@ 		NoUUID -> Left $ noRemoteUUIDMsg r 		u -> Right u 	go (Left e) = do-		m <- uuidMap-		return $ case M.keys (M.filter (== n) m) of+		m <- uuidDescMap+		let descn = UUIDDesc (encodeBS n)+		return $ case M.keys (M.filter (== descn) m) of 			[u] -> Right u 			[] -> let u = toUUID n 				in case M.keys (M.filterWithKey (\k _ -> k == u) m) of@@ -189,7 +196,7 @@ 	descm <- uuidDescriptions 	prettyPrintUUIDsDescs header descm uuids -prettyPrintUUIDsDescs :: String -> M.Map UUID RemoteName -> [UUID] -> Annex String+prettyPrintUUIDsDescs :: String -> UUIDDescMap -> [UUID] -> Annex String prettyPrintUUIDsDescs header descm uuids = 	prettyPrintUUIDsWith Nothing header descm 		(const Nothing)@@ -200,7 +207,7 @@ 	:: ToJSON' v 	=> Maybe String  	-> String -	-> M.Map UUID RemoteName+	-> UUIDDescMap 	-> (v -> Maybe String) 	-> [(UUID, Maybe v)]  	-> Annex String@@ -209,7 +216,7 @@ 	maybeShowJSON $ JSONChunk [(header, V.fromList $ map (jsonify hereu) uuidvals)] 	return $ unwords $ map (\u -> "\t" ++ prettify hereu u ++ "\n") uuidvals   where-	finddescription u = M.findWithDefault "" u descm+	finddescription u = fromUUIDDesc $ M.findWithDefault mempty u descm 	prettify hereu (u, optval) 		| not (null d) = addoptval $ fromUUID u ++ " -- " ++ d 		| otherwise = addoptval $ fromUUID u@@ -224,7 +231,7 @@ 			Nothing -> s 			Just val -> val ++ ": " ++ s 	jsonify hereu (u, optval) = object $ catMaybes-		[ Just (packString "uuid", toJSON' $ fromUUID u)+		[ Just (packString "uuid", toJSON' (fromUUID u :: String)) 		, Just (packString "description", toJSON' $ finddescription u) 		, Just (packString "here", toJSON' $ hereu == u) 		, case (optfield, optval) of@@ -237,9 +244,9 @@ prettyListUUIDs uuids = do 	hereu <- getUUID 	m <- uuidDescriptions-	return $ map (prettify m hereu) uuids+	return $ map (fromUUIDDesc . prettify m hereu) uuids   where-	finddescription m u = M.findWithDefault "" u m+	finddescription m u = M.findWithDefault mempty u m 	prettify m hereu u 		| u == hereu = addName n "here" 		| otherwise = n
Remote/Adb.hs view
@@ -186,7 +186,7 @@  androidLocation :: AndroidPath -> Key -> AndroidPath androidLocation adir k = AndroidPath $-	fromAndroidPath (androidHashDir adir k) ++ key2file k+	fromAndroidPath (androidHashDir adir k) ++ serializeKey k  androidHashDir :: AndroidPath -> Key -> AndroidPath androidHashDir adir k = AndroidPath $
Remote/BitTorrent.hs view
@@ -22,9 +22,9 @@ import Messages.Progress import Utility.Metered import Utility.Tmp-import Utility.FileSystemEncoding import Backend.URL import Annex.Perms+import Annex.Tmp import Annex.UUID import qualified Annex.Url as Url import Remote.Helper.Export@@ -166,29 +166,20 @@ torrentUrlKey :: URLString -> Annex Key torrentUrlKey u = return $ fromUrl (fst $ torrentUrlNum u) Nothing -{- Temporary directory used to download a torrent. -}-tmpTorrentDir :: URLString -> Annex FilePath-tmpTorrentDir u = do-	d <- fromRepo gitAnnexTmpMiscDir-	f <- keyFile <$> torrentUrlKey u-	return (d </> f)- {- Temporary filename to use to store the torrent file. -} tmpTorrentFile :: URLString -> Annex FilePath tmpTorrentFile u = fromRepo . gitAnnexTmpObjectLocation =<< torrentUrlKey u -{- A cleanup action is registered to delete the torrent file and its- - associated temp directory when git-annex exits.+{- A cleanup action is registered to delete the torrent file+ - when git-annex exits.  -- - This allows multiple actions that use the same torrent file and temp- - directory to run in a single git-annex run.+ - This allows multiple actions that use the same torrent file+ - directory to run in a single git-annex run, and only download the+ - torrent file once.  -} registerTorrentCleanup :: URLString -> Annex ()-registerTorrentCleanup u = Annex.addCleanup (TorrentCleanup u) $ do+registerTorrentCleanup u = Annex.addCleanup (TorrentCleanup u) $ 	liftIO . nukeFile =<< tmpTorrentFile u-	d <- tmpTorrentDir u-	liftIO $ whenM (doesDirectoryExist d) $-		removeDirectoryRecursive d  {- Downloads the torrent file. (Not its contents.) -} downloadTorrentFile :: URLString -> Annex Bool@@ -200,17 +191,16 @@ 			showAction "downloading torrent file" 			createAnnexDirectory (parentDir torrent) 			if isTorrentMagnetUrl u-				then do-					tmpdir <- tmpTorrentDir u-					let metadir = tmpdir </> "meta"+				then withOtherTmp $ \othertmp -> do+					kf <- keyFile <$> torrentUrlKey u+					let metadir = othertmp </> "torrentmeta" </> kf 					createAnnexDirectory metadir 					showOutput 					ok <- downloadMagnetLink u metadir torrent 					liftIO $ removeDirectoryRecursive metadir 					return ok-				else do-					misctmp <- fromRepo gitAnnexTmpMiscDir-					withTmpFileIn misctmp "torrent" $ \f h -> do+				else withOtherTmp $ \othertmp -> do+					withTmpFileIn othertmp "torrent" $ \f h -> do 						liftIO $ hClose h 						ok <- Url.withUrlOptions $  							liftIO . Url.download nullMeterUpdate u f@@ -245,16 +235,25 @@ downloadTorrentContent :: Key -> URLString -> FilePath -> Int -> MeterUpdate -> Annex Bool downloadTorrentContent k u dest filenum p = do 	torrent <- tmpTorrentFile u-	tmpdir <- tmpTorrentDir u-	createAnnexDirectory tmpdir-	f <- wantedfile torrent-	showOutput-	ifM (download torrent tmpdir <&&> liftIO (doesFileExist (tmpdir </> f)))-		( do-			liftIO $ renameFile (tmpdir </> f) dest-			return True-		, return False-		)+	withOtherTmp $ \othertmp -> do+		kf <- keyFile <$> torrentUrlKey u+		let downloaddir = othertmp </> "torrent" </> kf+		createAnnexDirectory downloaddir+		f <- wantedfile torrent+		showOutput+		ifM (download torrent downloaddir <&&> liftIO (doesFileExist (downloaddir </> f)))+			( do+				liftIO $ renameFile (downloaddir </> f) dest+				-- The downloaddir is not removed here,+				-- so if aria downloaded parts of other+				-- files, and this is called again, it will+				-- resume where it left off.+				-- withOtherTmp registers a cleanup action+				-- that will clean up leftover files when+				-- git-annex terminates.+				return True+			, return False+			)   where 	download torrent tmpdir = ariaProgress (keySize k) p 		[ Param $ "--select-file=" ++ show filenum@@ -350,7 +349,7 @@ torrentFileSizes :: FilePath -> IO [(FilePath, Integer)] torrentFileSizes torrent = do #ifdef WITH_TORRENTPARSER-	let mkfile = joinPath . map (scrub . decodeBS)+	let mkfile = joinPath . map (scrub . decodeBL) 	b <- B.readFile torrent 	return $ case readTorrent b of 		Left e -> giveup $ "failed to parse torrent: " ++ e
Remote/Bup.hs view
@@ -280,7 +280,7 @@ 	| Git.Ref.legal True shown = shown 	| otherwise = "git-annex-" ++ show (sha2_256 (fromString shown))   where-	shown = key2file k+	shown = serializeKey k  bupLocal :: BupRepo -> Bool bupLocal = notElem ':'
Remote/Ddar.hs view
@@ -110,7 +110,7 @@ 	let params = 		[ Param "c" 		, Param "-N"-		, Param $ key2file k+		, Param $ serializeKey k 		, Param $ ddarRepoLocation ddarrepo 		, File src 		]@@ -138,7 +138,7 @@ {- Specialized ddarRemoteCall that includes extraction command and flags -} ddarExtractRemoteCall :: ConsumeStdin -> DdarRepo -> Key -> Annex (String, [CommandParam]) ddarExtractRemoteCall cs ddarrepo k =-	ddarRemoteCall cs ddarrepo 'x' [Param "--force-stdout", Param $ key2file k]+	ddarRemoteCall cs ddarrepo 'x' [Param "--force-stdout", Param $ serializeKey k]  retrieve :: DdarRepo -> Retriever retrieve ddarrepo = byteRetriever $ \k sink -> do@@ -154,7 +154,7 @@ remove :: DdarRepo -> Remover remove ddarrepo key = do 	(cmd, params) <- ddarRemoteCall NoConsumeStdin ddarrepo 'd'-		[Param $ key2file key]+		[Param $ serializeKey key] 	liftIO $ boolSystem cmd params  ddarDirectoryExists :: DdarRepo -> Annex (Either String Bool)@@ -188,7 +188,7 @@ 		contents <- hGetContents h 		return $ elem k' $ lines contents   where-	k' = key2file k+	k' = serializeKey k  checkKey :: DdarRepo -> CheckPresent checkKey ddarrepo key = do
Remote/Directory/LegacyChunked.hs view
@@ -16,7 +16,7 @@ import Utility.FileMode import Remote.Helper.Special import qualified Remote.Helper.Chunked.Legacy as Legacy-import Annex.Perms+import Annex.Tmp import Utility.Metered  withCheckedFiles :: (FilePath -> IO Bool) -> FilePath -> (FilePath -> Key -> [FilePath]) -> Key -> ([FilePath] -> IO Bool) -> IO Bool@@ -89,10 +89,8 @@  - :/ This is legacy code..  -} retrieve :: (FilePath -> Key -> [FilePath]) -> FilePath -> Preparer Retriever-retrieve locations d basek a = do+retrieve locations d basek a = withOtherTmp $ \tmpdir -> do 	showLongNote "This remote uses the deprecated chunksize setting. So this will be quite slow."-	tmpdir <- fromRepo $ gitAnnexTmpMiscDir-	createAnnexDirectory tmpdir 	let tmp = tmpdir </> keyFile basek ++ ".directorylegacy.tmp" 	a $ Just $ byteRetriever $ \k sink -> do 		liftIO $ void $ withStoredFiles d locations k $ \fs -> do
Remote/External/Types.hs view
@@ -99,10 +99,10 @@  mkSafeKey :: Key -> Either String SafeKey mkSafeKey k -	| any isSpace (keyName k) = Left $ concat+	| any isSpace (decodeBS $ keyName k) = Left $ concat 		[ "Sorry, this file cannot be stored on an external special remote because its key's name contains a space. " 		, "To avoid this problem, you can run: git-annex migrate --backend="-		, formatKeyVariety (keyVariety k)+		, decodeBS (formatKeyVariety (keyVariety k)) 		, " and pass it the name of the file" 		] 	| otherwise = Right (SafeKey k)
Remote/Git.hs view
@@ -427,7 +427,7 @@ 	fallback = do 		Just (cmd, params) <- Ssh.git_annex_shell ConsumeStdin 			repo "lockcontent"-			[Param $ key2file key] []+			[Param $ serializeKey key] [] 		(Just hin, Just hout, Nothing, p) <- liftIO $  			withFile devNull WriteMode $ \nullh -> 				createProcess $@@ -530,7 +530,7 @@ 			: maybe [] (\f -> [(Fields.associatedFile, f)]) afile 		Just (cmd, params) <- Ssh.git_annex_shell ConsumeStdin 			repo "transferinfo" -			[Param $ key2file key] fields+			[Param $ serializeKey key] fields 		v <- liftIO (newEmptySV :: IO (MSampleVar Integer)) 		pidv <- liftIO $ newEmptyMVar 		tid <- liftIO $ forkIO $ void $ tryIO $ do
Remote/Glacier.hs view
@@ -197,7 +197,7 @@ 		{- glacier checkpresent outputs the archive name to stdout if 		 - it's present. -} 		s <- liftIO $ readProcessEnv "glacier" (toCommand params) (Just e)-		let probablypresent = key2file k `elem` lines s+		let probablypresent = serializeKey k `elem` lines s 		if probablypresent 			then ifM (Annex.getFlag "trustglacier") 				( return True, giveup untrusted )@@ -253,7 +253,7 @@ 	. M.lookup "vault"  archive :: Remote -> Key -> Archive-archive r k = fileprefix ++ key2file k+archive r k = fileprefix ++ serializeKey k   where 	fileprefix = M.findWithDefault "" "fileprefix" $ config r @@ -306,7 +306,7 @@ 	parse c [] = c 	parse c@(succeeded, failed) ((status:_date:vault:key:[]):rest) 		| vault == myvault =-			case file2key key of+			case deserializeKey key of 				Nothing -> parse c rest 				Just k 					| "a/d" `isPrefixOf` status ->
Remote/Helper/Encryptable.hs view
@@ -29,7 +29,6 @@ import Crypto import Types.Crypto import qualified Annex-import Utility.FileSystemEncoding  -- 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
Remote/Helper/Export.hs view
@@ -208,5 +208,5 @@ 						ea <- exportActions r 						retrieveExport ea k l dest p 			else do-				warning $ "exported content cannot be verified due to using the " ++ formatKeyVariety (keyVariety k) ++ " backend"+				warning $ "exported content cannot be verified due to using the " ++ decodeBS (formatKeyVariety (keyVariety k)) ++ " backend" 				return False
Remote/Helper/Ssh.hs view
@@ -67,7 +67,7 @@ 			else params 		return (Param command : File dir : params') 	uuidcheck NoUUID = []-	uuidcheck (UUID u) = ["--uuid", u]+	uuidcheck u@(UUID _) = ["--uuid", fromUUID u] 	fieldopts 		| null fields = [] 		| otherwise = fieldsep : map fieldopt fields ++ [fieldsep]@@ -98,7 +98,7 @@ inAnnex :: Git.Repo -> Key -> Annex Bool inAnnex r k = do 	showChecking r-	onRemote NoConsumeStdin r (runcheck, cantCheck r) "inannex" [Param $ key2file k] []+	onRemote NoConsumeStdin r (runcheck, cantCheck r) "inannex" [Param $ serializeKey k] []   where 	runcheck c p = dispatch =<< safeSystem c p 	dispatch ExitSuccess = return True@@ -109,7 +109,7 @@ dropKey :: Git.Repo -> Key -> Annex Bool dropKey r key = onRemote NoConsumeStdin r (boolSystem, return False) "dropkey" 	[ Param "--quiet", Param "--force"-	, Param $ key2file key+	, Param $ serializeKey key 	] 	[] @@ -141,7 +141,7 @@ 	repo <- getRepo r 	Just (shellcmd, shellparams) <- git_annex_shell ConsumeStdin repo 		(if direction == Download then "sendkey" else "recvkey")-		[ Param $ key2file key ]+		[ Param $ serializeKey key ] 		fields 	-- Convert the ssh command into rsync command line. 	let eparam = rsyncShell (Param shellcmd:shellparams)
Remote/Hook.hs view
@@ -92,7 +92,7 @@ 	mergeenv l = addEntries l <$> getEnvironment 	envvar s v = ("ANNEX_" ++ s, v) 	keyenv = catMaybes-		[ Just $ envvar "KEY" (key2file k)+		[ Just $ envvar "KEY" (serializeKey k) 		, Just $ envvar "ACTION" action 		, envvar "HASH_1" <$> headMaybe hashbits 		, envvar "HASH_2" <$> headMaybe (drop 1 hashbits)@@ -151,7 +151,7 @@ 	liftIO $ check v   where 	action = "checkpresent"-	findkey s = key2file k `elem` lines s+	findkey s = serializeKey k `elem` lines s 	check Nothing = giveup $ action ++ " hook misconfigured" 	check (Just hook) = do 		environ <- hookEnv action k Nothing
Remote/S3.hs view
@@ -19,6 +19,7 @@ import qualified Data.Text.Encoding as T import qualified Data.ByteString.Lazy as L import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as B8 import qualified Data.Map as M import qualified Data.Set as S import qualified System.FilePath.Posix as Posix@@ -52,7 +53,6 @@ import Utility.Metered import qualified Annex.Url as Url import Utility.DataUnits-import Utility.FileSystemEncoding import Annex.Content import Annex.Url (withUrlOptions) import Utility.Url (checkBoth, UrlOptions(..))@@ -278,7 +278,7 @@ 	let req = case loc of 		Left o -> S3.getObject (bucket info) o 		Right (S3VersionID o vid) -> (S3.getObject (bucket info) o)-			{ S3.goVersionId = Just (T.pack vid) }+			{ S3.goVersionId = Just vid } 	S3.GetObjectResponse { S3.gorResponse = rsp } <- sendS3Handle' h req 	Url.sinkResponseFile p zeroBytesProcessed f WriteMode rsp @@ -328,7 +328,7 @@ 	req = case loc of 		Left o -> S3.headObject (bucket info) o 		Right (S3VersionID o vid) -> (S3.headObject (bucket info) o)-			{ S3.hoVersionId = Just (T.pack vid) }+			{ S3.hoVersionId = Just vid }  #if ! MIN_VERSION_aws(0,10,0) 	{- Catch exception headObject returns when an object is not present@@ -433,13 +433,14 @@ 			Right _ -> noop 			Left _ -> do 				showAction $ "creating bucket in " ++ datacenter-				void $ sendS3Handle h $ S3.PutBucket-					(bucket info)-					(acl info)-					locconstraint+				void $ sendS3Handle h $ +					(S3.putBucket (bucket info))+						{ S3.pbCannedAcl = acl info+						, S3.pbLocationConstraint = locconstraint #if MIN_VERSION_aws(0,13,0)-					storageclass+						, S3.pbXStorageClass = storageclass #endif+						} 		writeUUIDFile c u info h 	 	locconstraint = mkLocationConstraint $ T.pack datacenter@@ -652,7 +653,7 @@ getFilePrefix = M.findWithDefault "" "fileprefix"  getBucketObject :: RemoteConfig -> Key -> BucketObject-getBucketObject c = munge . key2file+getBucketObject c = munge . serializeKey   where 	munge s = case M.lookup "mungekeys" c of 		Just "ia" -> iaMunge $ getFilePrefix c ++ s@@ -775,36 +776,34 @@ 		_ -> Nothing  -data S3VersionID = S3VersionID S3.Object String+data S3VersionID = S3VersionID S3.Object T.Text 	deriving (Show)  -- smart constructor mkS3VersionID :: S3.Object -> Maybe T.Text -> Maybe S3VersionID-mkS3VersionID o = mkS3VersionID' o . fmap T.unpack--mkS3VersionID' :: S3.Object -> Maybe String -> Maybe S3VersionID-mkS3VersionID' o (Just s)-	| null s = Nothing+mkS3VersionID o (Just t)+	| T.null t = Nothing 	-- AWS documentation says a version ID is at most 1024 bytes long. 	-- Since they are stored in the git-annex branch, prevent them from 	-- being very much larger than that.-	| length s < 2048 = Just (S3VersionID o s)+	| T.length t < 2048 = Just (S3VersionID o t) 	| otherwise = Nothing-mkS3VersionID' _ Nothing = Nothing+mkS3VersionID _ Nothing = Nothing  -- Format for storage in per-remote metadata. -- -- A S3 version ID is "url ready" so does not contain '#' and so we'll use -- that to separate it from the object id. (Could use a space, but spaces -- in metadata values lead to an inefficient encoding.)-formatS3VersionID :: S3VersionID -> String-formatS3VersionID (S3VersionID o v) = v ++ '#' : T.unpack o+formatS3VersionID :: S3VersionID -> BS.ByteString+formatS3VersionID (S3VersionID o v) = T.encodeUtf8 v <> "#" <> T.encodeUtf8 o  -- Parse from value stored in per-remote metadata.-parseS3VersionID :: String -> Maybe S3VersionID-parseS3VersionID s = -	let (v, o) = separate (== '#') s-	in mkS3VersionID' (T.pack o) (Just v)+parseS3VersionID :: BS.ByteString -> Maybe S3VersionID+parseS3VersionID b = do+	let (v, rest) = B8.break (== '#') b+	o <- eitherToMaybe $ T.decodeUtf8' $ BS.drop 1 rest+	mkS3VersionID o (eitherToMaybe $ T.decodeUtf8' v)  setS3VersionID :: S3Info -> UUID -> Key -> Maybe S3VersionID -> Annex () setS3VersionID info u k vid@@ -843,7 +842,7 @@ s3VersionIDPublicUrl mk info (S3VersionID obj vid) = mk info $ concat 	[ T.unpack obj 	, "?versionId="-	, vid -- version ID is "url ready" so no escaping needed+	, T.unpack vid -- version ID is "url ready" so no escaping needed 	]  getS3VersionIDPublicUrls :: (S3Info -> BucketObject -> URLString) -> S3Info -> UUID -> Key -> Annex [URLString]
Remote/Web.hs view
@@ -18,7 +18,6 @@ import Config import Logs.Web import Annex.UUID-import Messages.Progress import Utility.Metered import qualified Annex.Url as Url import Annex.YoutubeDl@@ -87,8 +86,7 @@ 			YoutubeDownloader -> do 				showOutput 				youtubeDlTo key u' dest-			_ -> metered (Just p) key (pure Nothing) $ \_ p' -> -				downloadUrl key p' [u'] dest+			_ -> downloadUrl key p [u'] dest  downloadKeyCheap :: Key -> AssociatedFile -> FilePath -> Annex Bool downloadKeyCheap _ _ _ = return False
Test.hs view
@@ -158,9 +158,7 @@ properties = localOption (QuickCheckTests 1000) $ testGroup "QuickCheck" 	[ testProperty "prop_encode_decode_roundtrip" Git.Filename.prop_encode_decode_roundtrip 	, testProperty "prop_encode_c_decode_c_roundtrip" Utility.Format.prop_encode_c_decode_c_roundtrip-	, testProperty "prop_isomorphic_fileKey" Annex.Locations.prop_isomorphic_fileKey 	, testProperty "prop_isomorphic_key_encode" Key.prop_isomorphic_key_encode-	, testProperty "prop_isomorphic_key_decode" Key.prop_isomorphic_key_decode 	, testProperty "prop_isomorphic_shellEscape" Utility.SafeCommand.prop_isomorphic_shellEscape 	, testProperty "prop_isomorphic_shellEscape_multiword" Utility.SafeCommand.prop_isomorphic_shellEscape_multiword 	, testProperty "prop_isomorphic_configEscape" Logs.Remote.prop_isomorphic_configEscape@@ -177,9 +175,9 @@ 	, testProperty "prop_segment_regressionTest" Utility.Misc.prop_segment_regressionTest 	, testProperty "prop_read_write_transferinfo" Logs.Transfer.prop_read_write_transferinfo 	, testProperty "prop_read_show_inodecache" Utility.InodeCache.prop_read_show_inodecache-	, testProperty "prop_parse_show_log" Logs.Presence.prop_parse_show_log+	, testProperty "prop_parse_build_log" Logs.Presence.prop_parse_build_log 	, testProperty "prop_read_show_TrustLevel" Types.TrustLevel.prop_read_show_TrustLevel-	, testProperty "prop_parse_show_TrustLog" Logs.Trust.prop_parse_show_TrustLog+	, testProperty "prop_parse_build_TrustLevelLog" Logs.Trust.prop_parse_build_TrustLevelLog 	, testProperty "prop_hashes_stable" Utility.Hash.prop_hashes_stable 	, testProperty "prop_mac_stable" Utility.Hash.prop_mac_stable 	, testProperty "prop_schedule_roundtrips" Utility.Scheduled.QuickCheck.prop_schedule_roundtrips@@ -275,9 +273,7 @@ test_init :: Assertion test_init = innewrepo $ do 	ver <- annexVersion <$> getTestMode-	if ver == Annex.Version.defaultVersion-		then git_annex "init" [reponame] @? "init failed"-		else git_annex "init" [reponame, "--version", show (fromRepoVersion ver)] @? "init failed"+	git_annex "init" [reponame, "--version", show (fromRepoVersion ver)] @? "init failed" 	setupTestMode   where 	reponame = "test repo"@@ -399,7 +395,7 @@ 	git_annex "drop" ["--force", sha1annexedfile] @? "drop failed" 	annexed_notpresent sha1annexedfile 	writecontent tmp $ content sha1annexedfile-	key <- Key.key2file <$> getKey backendSHA1 tmp+	key <- Key.serializeKey <$> getKey backendSHA1 tmp 	git_annex "reinject" [tmp, sha1annexedfile] @? "reinject failed" 	annexed_present sha1annexedfile 	-- fromkey can't be used on a crippled filesystem, since it makes a@@ -869,9 +865,9 @@ 	checkunused [annexedfilekey, sha1annexedfilekey] "after rm sha1annexedfile"  	-- good opportunity to test dropkey also-	git_annex "dropkey" ["--force", Key.key2file annexedfilekey]+	git_annex "dropkey" ["--force", Key.serializeKey annexedfilekey] 		@? "dropkey failed"-	checkunused [sha1annexedfilekey] ("after dropkey --force " ++ Key.key2file annexedfilekey)+	checkunused [sha1annexedfilekey] ("after dropkey --force " ++ Key.serializeKey annexedfilekey)  	git_annex_shouldfail "dropunused" ["1"] @? "dropunused failed to fail without --force" 	git_annex "dropunused" ["--force", "1"] @? "dropunused failed"@@ -1455,18 +1451,21 @@ 			checkmerge "r2" r2   where 	conflictor = "conflictor"-	setup r = indir r $ do+	setup r = indir r $ whensupported $ do 		disconnectOrigin 		git_annex "upgrade" [] @? "upgrade failed" 		git_annex "adjust" ["--unlock", "--force"] @? "adjust failed" 		writecontent conflictor "conflictor" 		git_annex "add" [conflictor] @? "add conflicter failed" 		git_annex "sync" [] @? "sync failed"-	checkmerge what d = indir d $ do+	checkmerge what d = indir d $ whensupported $ do 		git_annex "sync" [] @? ("sync failed in " ++ what) 		l <- getDirectoryContents "." 		conflictor `elem` l 			@? ("conflictor not present after merge in " ++ what)+	-- Currently this fails on FAT, for unknown reasons not to+	-- do with what it's intended to test.+	whensupported = unlessM (annexeval Config.crippledFileSystem)  {- Regression test for a bug in adjusted branch syncing code, where adding  - a subtree to an existing tree lost files. -}@@ -1619,10 +1618,14 @@ 	testscheme "pubkey"   where 	gpgcmd = Utility.Gpg.mkGpgCmd Nothing-	testscheme scheme = intmpclonerepo $ whenM (Utility.Path.inPath (Utility.Gpg.unGpgCmd gpgcmd)) $ do-		Utility.Gpg.testTestHarness gpgcmd +	testscheme scheme = do+		gpgtmp <- (</> "gpgtest") <$> absPath tmpdir+		createDirectoryIfMissing False gpgtmp+		testscheme' scheme gpgtmp+	testscheme' scheme gpgtmp = intmpclonerepo $ whenM (Utility.Path.inPath (Utility.Gpg.unGpgCmd gpgcmd)) $ do+		Utility.Gpg.testTestHarness gpgtmp gpgcmd  			@? "test harness self-test failed"-		Utility.Gpg.testHarness gpgcmd $ do+		Utility.Gpg.testHarness gpgtmp gpgcmd $ do 			createDirectory "dir" 			let a cmd = git_annex cmd $ 				[ "foo"@@ -1678,12 +1681,12 @@ 			let encparams = (mempty :: Types.Remote.RemoteConfig, dummycfg) 			cipher <- Crypto.decryptCipher gpgcmd encparams cip 			files <- filterM doesFileExist $-				map ("dir" </>) $ concatMap (key2files cipher) keys+				map ("dir" </>) $ concatMap (serializeKeys cipher) keys 			return (not $ null files) <&&> allM (checkFile mvariant) files 		checkFile mvariant filename = 			Utility.Gpg.checkEncryptionFile gpgcmd filename $ 				if mvariant == Just Types.Crypto.PubKey then ks else Nothing-		key2files cipher = Annex.Locations.keyPaths .+		serializeKeys cipher = Annex.Locations.keyPaths . 			Crypto.encryptKey Types.Crypto.HmacSha1 cipher #else test_crypto = putStrLn "gpg testing not implemented on Windows"@@ -1699,7 +1702,7 @@ 	 - calculated correctly for files in subdirs. -} 	unlessM (unlockedFiles <$> getTestMode) $ do 		git_annex "sync" [] @? "sync failed"-		l <- annexeval $ Utility.FileSystemEncoding.decodeBS+		l <- annexeval $ Utility.FileSystemEncoding.decodeBL 			<$> Annex.CatFile.catObject (Git.Types.Ref "HEAD:dir/foo") 		"../.git/annex/" `isPrefixOf` l @? ("symlink from subdir to .git/annex is wrong: " ++ l)
Test/Framework.hs view
@@ -17,7 +17,6 @@  import qualified Annex import qualified Annex.UUID-import qualified Annex.Version import qualified Types.RepoVersion import qualified Backend import qualified Git.CurrentRepo@@ -65,8 +64,13 @@ 	-- catch all errors, including normally fatal errors 	try run ::IO (Either SomeException ())   where-	run = GitAnnex.run dummyTestOptParser (\_ -> noop) (command:"-q":params)+	run = GitAnnex.run dummyTestOptParser+		dummyTestRunner+		dummyBenchmarkGenerator+		(command:"-q":params) 	dummyTestOptParser = pure mempty+	dummyTestRunner _ = noop+	dummyBenchmarkGenerator _ _ = return noop  {- Runs git-annex and returns its output. -} git_annex_output :: String -> [String] -> IO String@@ -214,9 +218,7 @@ 	configrepo new 	indir new $ do 		ver <- annexVersion <$> getTestMode-		if ver == Annex.Version.defaultVersion-			then git_annex "init" ["-q", new] @? "git annex init failed"-			else git_annex "init" ["-q", new, "--version", show (Types.RepoVersion.fromRepoVersion ver)] @? "git annex init failed"+		git_annex "init" ["-q", new, "--version", show (Types.RepoVersion.fromRepoVersion ver)] @? "git annex init failed" 	unless (bareClone cfg) $ 		indir new $ 			setupTestMode@@ -339,7 +341,7 @@ 	case r of 		Just k -> do 			uuids <- annexeval $ Remote.keyLocations k-			assertEqual ("bad content in location log for " ++ f ++ " key " ++ Key.key2file k ++ " uuid " ++ show thisuuid)+			assertEqual ("bad content in location log for " ++ f ++ " key " ++ Key.serializeKey k ++ " uuid " ++ show thisuuid) 				expected (thisuuid `elem` uuids) 		_ -> assertFailure $ f ++ " failed to look up key" @@ -560,7 +562,7 @@ backendWORM = backend_ "WORM"  backend_ :: String -> Types.Backend-backend_ = Backend.lookupBackendVariety . Types.Key.parseKeyVariety+backend_ = Backend.lookupBackendVariety . Types.Key.parseKeyVariety . encodeBS  getKey :: Types.Backend -> FilePath -> IO Types.Key getKey b f = fromJust <$> annexeval go
Types/ActionItem.hs view
@@ -36,8 +36,8 @@  actionItemDesc :: ActionItem -> Key -> String actionItemDesc (ActionItemAssociatedFile (AssociatedFile (Just f))) _ = f-actionItemDesc (ActionItemAssociatedFile (AssociatedFile Nothing)) k = key2file k-actionItemDesc ActionItemKey k = key2file k+actionItemDesc (ActionItemAssociatedFile (AssociatedFile Nothing)) k = serializeKey k+actionItemDesc ActionItemKey k = serializeKey k actionItemDesc (ActionItemBranchFilePath bfp) _ = descBranchFilePath bfp actionItemDesc (ActionItemFailedTransfer _ i) k = 	actionItemDesc (ActionItemAssociatedFile (associatedFile i)) k
Types/Backend.hs view
@@ -12,6 +12,8 @@ import Types.Key import Types.KeySource +import Utility.FileSystemEncoding+ data BackendA a = Backend 	{ backendVariety :: KeyVariety 	, getKey :: KeySource -> a (Maybe Key) @@ -28,7 +30,7 @@ 	}  instance Show (BackendA a) where-	show backend = "Backend { name =\"" ++ formatKeyVariety (backendVariety backend) ++ "\" }"+	show backend = "Backend { name =\"" ++ decodeBS (formatKeyVariety (backendVariety backend)) ++ "\" }"  instance Eq (BackendA a) where 	a == b = backendVariety a == backendVariety b
+ Types/Benchmark.hs view
@@ -0,0 +1,15 @@+{- git-annex benchmark data types.+ -+ - Copyright 2019 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Types.Benchmark where++import Annex+import Types.Command++type BenchmarkGenerator = [String] -> Annex (IO ())++type MkBenchmarkGenerator = [Command] -> BenchmarkGenerator
Types/CleanupActions.hs view
@@ -17,4 +17,5 @@ 	| FsckCleanup 	| SshCachingCleanup 	| TorrentCleanup URLString+	| OtherTmpCleanup 	deriving (Eq, Ord)
Types/Distribution.hs view
@@ -46,7 +46,7 @@ formatGitAnnexDistribution :: GitAnnexDistribution -> String formatGitAnnexDistribution d = unlines 	[ distributionUrl d-	, key2file (distributionKey d)+	, serializeKey (distributionKey d) 	, distributionVersion d 	, show (distributionReleasedate d) 	, maybe "" show (distributionUrgentUpgrade d)@@ -56,7 +56,7 @@ parseGitAnnexDistribution s = case lines s of 	(u:k:v:d:uu:_) -> GitAnnexDistribution 		<$> pure u-		<*> file2key k+		<*> deserializeKey k 		<*> pure v 		<*> readish d 		<*> pure (readish uu)
Types/Group.hs view
@@ -1,22 +1,33 @@ {- git-annex repo groups  -- - Copyright 2012 Joey Hess <id@joeyh.name>+ - Copyright 2012, 2019 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}  module Types.Group (-	Group,+	Group(..),+	fromGroup,+	toGroup, 	GroupMap(..), 	emptyGroupMap ) where  import Types.UUID+import Utility.FileSystemEncoding  import qualified Data.Map as M import qualified Data.Set as S+import qualified Data.ByteString as S -type Group = String+newtype Group = Group S.ByteString+	deriving (Eq, Ord, Show)++fromGroup :: Group -> String+fromGroup (Group g) = decodeBS g++toGroup :: String -> Group+toGroup = Group . encodeBS  data GroupMap = GroupMap 	{ groupsByUUID :: M.Map UUID (S.Set Group)
Types/Key.hs view
@@ -1,22 +1,25 @@ {- git-annex Key data type  -- - Copyright 2011-2018 Joey Hess <id@joeyh.name>+ - Copyright 2011-2019 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}  {-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}  module Types.Key where -import Utility.PartialPrelude-+import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8 import System.Posix.Types+import Data.Monoid+import Prelude  {- A Key has a unique name, which is derived from a particular backend,  - and may contain other optional metadata. -} data Key = Key-	{ keyName :: String+	{ keyName :: S.ByteString 	, keyVariety :: KeyVariety 	, keySize :: Maybe Integer 	, keyMtime :: Maybe EpochTime@@ -42,7 +45,7 @@ 	| URLKey  	-- Some repositories may contain keys of other varieties, 	-- which can still be processed to some extent.-	| OtherKey String+	| OtherKey S.ByteString 	deriving (Eq, Ord, Read, Show)  {- Some varieties of keys may contain an extension at the end of the@@ -64,7 +67,7 @@ hasExt (MD5Key (HasExt b)) = b hasExt WORMKey = False hasExt URLKey = False-hasExt (OtherKey s) =  end s == "E"+hasExt (OtherKey s) = (snd <$> S8.unsnoc s) == Just 'E'  sameExceptExt :: KeyVariety -> KeyVariety -> Bool sameExceptExt (SHA2Key sz1 _) (SHA2Key sz2 _) = sz1 == sz2@@ -103,9 +106,9 @@ isVerifiable (MD5Key _) = True isVerifiable WORMKey = False isVerifiable URLKey = False-isVerifiable (OtherKey _) =  False+isVerifiable (OtherKey  _) =  False -formatKeyVariety :: KeyVariety -> String+formatKeyVariety :: KeyVariety -> S.ByteString formatKeyVariety v = case v of 	SHA2Key sz e -> adde e (addsz sz "SHA") 	SHA3Key sz e -> adde e (addsz sz "SHA3_")@@ -120,10 +123,18 @@ 	OtherKey s -> s   where 	adde (HasExt False) s = s-	adde (HasExt True) s = s ++ "E"-	addsz (HashSize n) s =  s ++ show n+	adde (HasExt True) s = s <> "E"+	addsz (HashSize n) s = s <> case n of+		256 -> "256"+		512 -> "512"+		224 -> "224"+		384 -> "384"+		160 -> "160"+		-- This is relatively slow, which is why the common hash+		-- sizes are hardcoded above.+		_ -> S8.pack (show n) -parseKeyVariety :: String -> KeyVariety+parseKeyVariety :: S.ByteString -> KeyVariety parseKeyVariety "SHA256"       = SHA2Key (HashSize 256) (HasExt False) parseKeyVariety "SHA256E"      = SHA2Key (HashSize 256) (HasExt True) parseKeyVariety "SHA512"       = SHA2Key (HashSize 512) (HasExt False)@@ -172,4 +183,4 @@ parseKeyVariety "MD5E"        = MD5Key (HasExt True) parseKeyVariety "WORM"        = WORMKey parseKeyVariety "URL"         = URLKey-parseKeyVariety s             = OtherKey s+parseKeyVariety b             = OtherKey b
Types/MetaData.hs view
@@ -1,11 +1,12 @@ {- git-annex general metadata  -- - Copyright 2014-2018 Joey Hess <id@joeyh.name>+ - Copyright 2014-2019 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}  {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}  module Types.MetaData ( 	MetaData(..),@@ -51,11 +52,14 @@ import Types.UUID  import qualified Data.Text as T+import qualified Data.Text.Encoding as E import qualified Data.Set as S import qualified Data.Map.Strict as M import qualified Data.HashMap.Strict as HM import Data.Char import qualified Data.CaseInsensitive as CI+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8  newtype MetaData = MetaData (M.Map MetaField (S.Set MetaValue)) 	deriving (Show, Eq, Ord)@@ -63,14 +67,14 @@ instance ToJSON' MetaData where 	toJSON' (MetaData m) = object $ map go (M.toList m) 	  where-		go (MetaField f, s) = (packString (CI.original f), toJSON' s)+		go (MetaField f, s) = (CI.original f, toJSON' s)  instance FromJSON MetaData where 	parseJSON (Object o) = do 		l <- HM.toList <$> parseJSON (Object o) 		MetaData . M.fromList <$> mapM go l 	  where-		go (t, l) = case mkMetaField (T.unpack t) of+		go (t, l) = case mkMetaField t of 			Left e -> fail e 			Right f -> (,) <$> pure f <*> parseJSON l 	parseJSON _ = fail "expected an object"@@ -81,17 +85,18 @@ 	deriving (Read, Show, Eq, Ord, Arbitrary)  {- Fields are case insensitive. -}-newtype MetaField = MetaField (CI.CI String)+newtype MetaField = MetaField (CI.CI T.Text) 	deriving (Read, Show, Eq, Ord) -data MetaValue = MetaValue CurrentlySet String+data MetaValue = MetaValue CurrentlySet B.ByteString 	deriving (Read, Show)  instance ToJSON' MetaValue where 	toJSON' (MetaValue _ v) = toJSON' v  instance FromJSON MetaValue where-	parseJSON (String v) = return $ MetaValue (CurrentlySet True) (T.unpack v)+	parseJSON (String v) = return $+		MetaValue (CurrentlySet True) (E.encodeUtf8 v) 	parseJSON _  = fail "expected a string"  {- Metadata values compare and order the same whether currently set or not. -}@@ -105,14 +110,16 @@  - field1 +val1 +val2 -val3 field2 +val4 +val5  -} class MetaSerializable v where-	serialize :: v -> String-	deserialize :: String -> Maybe v+	serialize :: v -> B.ByteString+	deserialize :: B.ByteString -> Maybe v  instance MetaSerializable MetaData where-	serialize (MetaData m) = unwords $ concatMap go $ M.toList m+	serialize (MetaData m) = B8.unwords $ concatMap go $ M.toList m 	  where 		go (f, vs) = serialize f : map serialize (S.toList vs)-	deserialize = Just . getfield emptyMetaData . words+	-- Note that B8.words cannot be used here, because UTF-8 encoded+	-- field names may contain bytes such as \160 that are whitespace.+	deserialize = Just . getfield emptyMetaData . B8.split ' ' 	  where 		getfield m [] = m 		getfield m (w:ws) = maybe m (getvalues m ws) (deserialize w)@@ -122,23 +129,25 @@ 			Nothing -> getfield m l  instance MetaSerializable MetaField where-	serialize (MetaField f) = CI.original f-	deserialize = Just . mkMetaFieldUnchecked+	serialize (MetaField f) = E.encodeUtf8 (CI.original f)+	deserialize = MetaField . CI.mk <$$> eitherToMaybe . E.decodeUtf8'  {- Base64 problematic values. -} instance MetaSerializable MetaValue where 	serialize (MetaValue isset v) =-		serialize isset ++-		if any isSpace v || "!" `isPrefixOf` v-			then '!' : toB64 v+		serialize isset <>+		if B8.any (== ' ') v || "!" `B8.isPrefixOf` v+			then "!" <> toB64' v 			else v-	deserialize (isset:'!':v) = MetaValue-		<$> deserialize [isset]-		<*> fromB64Maybe v-	deserialize (isset:v) = MetaValue -		<$> deserialize [isset]-		<*> pure v-	deserialize [] = Nothing+	deserialize b = do+		(isset, b') <- B8.uncons b+		case B8.uncons b' of+			Just ('!', b'') -> MetaValue+				<$> deserialize (B8.singleton isset)+				<*> fromB64Maybe' b''+			_ -> MetaValue+				<$> deserialize (B8.singleton isset)+				<*> pure b'  instance MetaSerializable CurrentlySet where 	serialize (CurrentlySet True) = "+"@@ -147,17 +156,17 @@ 	deserialize "-" = Just (CurrentlySet False) 	deserialize _ = Nothing -mkMetaField :: String -> Either String MetaField+mkMetaField :: T.Text -> Either String MetaField mkMetaField f = maybe (Left $ badField f) Right (toMetaField f) -badField :: String -> String-badField f = "Illegal metadata field name, \"" ++ f ++ "\""+badField :: T.Text -> String+badField f = "Illegal metadata field name, \"" ++ T.unpack f ++ "\""  {- Does not check that the field name is valid. Use with caution. -}-mkMetaFieldUnchecked :: String -> MetaField+mkMetaFieldUnchecked :: T.Text -> MetaField mkMetaFieldUnchecked = MetaField . CI.mk -toMetaField :: String -> Maybe MetaField+toMetaField :: T.Text -> Maybe MetaField toMetaField f 	| legalField f = Just $ MetaField $ CI.mk f 	| otherwise = Nothing@@ -168,23 +177,29 @@  - Additionally, fields should not contain any form of path separator, as  - that would break views.  -+ - And, fields need to be valid JSON keys.+ -  - So, require they have an alphanumeric first letter, with the remainder  - being either alphanumeric or a small set of whitelisted common punctuation.  -}-legalField :: String -> Bool-legalField [] = False-legalField (c1:cs)-	| not (isAlphaNum c1) = False-	| otherwise = all legalchars cs+legalField :: T.Text -> Bool+legalField t = case T.uncons t of+	Nothing -> False+	Just (c1, t')+		| not (isAlphaNum c1) -> False+		| otherwise -> T.all legalchars t'   where 	legalchars c 		| isAlphaNum c = True-		| otherwise = c `elem` "_-."+		| otherwise = c `elem` legalFieldWhiteList -toMetaValue :: String -> MetaValue+legalFieldWhiteList :: [Char]+legalFieldWhiteList = "_-."++toMetaValue :: B.ByteString -> MetaValue toMetaValue = MetaValue (CurrentlySet True) -mkMetaValue :: CurrentlySet -> String -> MetaValue+mkMetaValue :: CurrentlySet -> B.ByteString -> MetaValue mkMetaValue = MetaValue  unsetMetaValue :: MetaValue -> MetaValue@@ -194,10 +209,10 @@ unsetMetaData :: MetaData -> MetaData unsetMetaData (MetaData m) = MetaData $ M.map (S.map unsetMetaValue) m -fromMetaField :: MetaField -> String+fromMetaField :: MetaField -> T.Text fromMetaField (MetaField f) = CI.original f -fromMetaValue :: MetaValue -> String+fromMetaValue :: MetaValue -> B.ByteString fromMetaValue (MetaValue _ f) = f  fromMetaData :: MetaData -> [(MetaField, S.Set MetaValue)]@@ -296,35 +311,34 @@ extractRemoteMetaData u (MetaData m) = RemoteMetaData u $ MetaData $ 	M.mapKeys removeprefix $ M.filterWithKey belongsremote m   where-	belongsremote (MetaField f) _v = prefix `isPrefixOf` CI.original f+	belongsremote (MetaField f) _v = prefix `T.isPrefixOf` CI.original f 	removeprefix (MetaField f) = MetaField $ -		CI.mk $ drop prefixlen $ CI.original f+		CI.mk $ T.drop prefixlen $ CI.original f 	prefix = remoteMetaDataPrefix u-	prefixlen = length prefix+	prefixlen = T.length prefix  splitRemoteMetaDataField :: MetaField -> Maybe (UUID, MetaField) splitRemoteMetaDataField (MetaField f) = do-	let (su, sf) = separate (== ':') (CI.original f)-	f' <- toMetaField sf-	return $ (toUUID su, f')+	let (su, sf) = T.break (== ':') (CI.original f)+	f' <- toMetaField ((T.drop 1 sf))+	return $ (toUUID (T.unpack su), f') -remoteMetaDataPrefix :: UUID -> String-remoteMetaDataPrefix u = fromUUID u ++ ":"+remoteMetaDataPrefix :: UUID -> T.Text+remoteMetaDataPrefix u = T.pack (fromUUID u) <> ":"  fromRemoteMetaData :: RemoteMetaData -> MetaData fromRemoteMetaData (RemoteMetaData u (MetaData m)) = MetaData $ 	M.mapKeys addprefix m   where-	addprefix (MetaField f) = MetaField $ CI.mk $ (prefix ++) $ CI.original f+	addprefix (MetaField f) = MetaField $ CI.mk $ prefix <> CI.original f 	prefix = remoteMetaDataPrefix u  {- Avoid putting too many fields in the map; extremely large maps make  - the seriaization test slow due to the sheer amount of data.  - It's unlikely that more than 100 fields of metadata will be used. -} instance Arbitrary MetaData where-	arbitrary = do-		size <- arbitrarySizedBoundedIntegral `suchThat` (< 500)-		MetaData . M.filterWithKey legal . M.fromList <$> vector size+	arbitrary = MetaData . M.filterWithKey legal . M.fromList+		<$> resize 10 (listOf arbitrary) 	  where 		legal k _v = legalField $ fromMetaField k @@ -334,11 +348,11 @@ 		-- Avoid non-ascii metavalues because fully arbitrary 		-- strings may not be encoded using the filesystem 		-- encoding, which is norally applied to all input.-		<*> arbitrary `suchThat` all isAscii+		<*> (encodeBS <$> arbitrary `suchThat` all isAscii)  instance Arbitrary MetaField where-	arbitrary = MetaField . CI.mk -		<$> arbitrary `suchThat` legalField +	arbitrary = MetaField . CI.mk+		<$> (T.pack <$> arbitrary) `suchThat` legalField  prop_metadata_sane :: MetaData -> MetaField -> MetaValue -> Bool prop_metadata_sane m f v = and
Types/StandardGroups.hs view
@@ -5,6 +5,8 @@  - Licensed under the GNU GPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Types.StandardGroups where  import Types.Remote (RemoteConfig)@@ -29,28 +31,28 @@ 	deriving (Eq, Ord, Enum, Bounded, Show)  fromStandardGroup :: StandardGroup -> Group-fromStandardGroup ClientGroup = "client"-fromStandardGroup TransferGroup = "transfer"-fromStandardGroup BackupGroup = "backup"-fromStandardGroup IncrementalBackupGroup = "incrementalbackup"-fromStandardGroup SmallArchiveGroup = "smallarchive"-fromStandardGroup FullArchiveGroup = "archive"-fromStandardGroup SourceGroup = "source"-fromStandardGroup ManualGroup = "manual"-fromStandardGroup PublicGroup = "public"-fromStandardGroup UnwantedGroup = "unwanted"+fromStandardGroup ClientGroup = Group "client"+fromStandardGroup TransferGroup = Group "transfer"+fromStandardGroup BackupGroup = Group "backup"+fromStandardGroup IncrementalBackupGroup = Group "incrementalbackup"+fromStandardGroup SmallArchiveGroup = Group "smallarchive"+fromStandardGroup FullArchiveGroup = Group "archive"+fromStandardGroup SourceGroup = Group "source"+fromStandardGroup ManualGroup = Group "manual"+fromStandardGroup PublicGroup = Group "public"+fromStandardGroup UnwantedGroup = Group "unwanted"  toStandardGroup :: Group -> Maybe StandardGroup-toStandardGroup "client" = Just ClientGroup-toStandardGroup "transfer" = Just TransferGroup-toStandardGroup "backup" = Just BackupGroup-toStandardGroup "incrementalbackup" = Just IncrementalBackupGroup-toStandardGroup "smallarchive" = Just SmallArchiveGroup-toStandardGroup "archive" = Just FullArchiveGroup-toStandardGroup "source" = Just SourceGroup-toStandardGroup "manual" = Just ManualGroup-toStandardGroup "public" = Just PublicGroup-toStandardGroup "unwanted" = Just UnwantedGroup+toStandardGroup (Group "client") = Just ClientGroup+toStandardGroup (Group "transfer") = Just TransferGroup+toStandardGroup (Group "backup") = Just BackupGroup+toStandardGroup (Group "incrementalbackup") = Just IncrementalBackupGroup+toStandardGroup (Group "smallarchive") = Just SmallArchiveGroup+toStandardGroup (Group "archive") = Just FullArchiveGroup+toStandardGroup (Group "source") = Just SourceGroup+toStandardGroup (Group "manual") = Just ManualGroup+toStandardGroup (Group "public") = Just PublicGroup+toStandardGroup (Group "unwanted") = Just UnwantedGroup toStandardGroup _ = Nothing  descStandardGroup :: StandardGroup -> String
Types/UUID.hs view
@@ -1,42 +1,82 @@ {- git-annex UUID type  -- - Copyright 2011 Joey Hess <id@joeyh.name>+ - Copyright 2011-2019 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -} -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, GeneralizedNewtypeDeriving #-}  module Types.UUID where +import qualified Data.ByteString as B import qualified Data.Map as M import qualified Data.UUID as U import Data.Maybe+import Data.String+import Data.ByteString.Builder+import qualified Data.Semigroup as Sem +import Utility.FileSystemEncoding import qualified Utility.SimpleProtocol as Proto  -- A UUID is either an arbitrary opaque string, or UUID info may be missing.-data UUID = NoUUID | UUID String+data UUID = NoUUID | UUID B.ByteString 	deriving (Eq, Ord, Show, Read) -fromUUID :: UUID -> String-fromUUID (UUID u) = u-fromUUID NoUUID = ""+class FromUUID a where+	fromUUID :: UUID -> a  class ToUUID a where 	toUUID :: a -> UUID +instance FromUUID UUID where+	fromUUID = id+ instance ToUUID UUID where 	toUUID = id +instance FromUUID B.ByteString where+	fromUUID (UUID u) = u+	fromUUID NoUUID = B.empty++instance ToUUID B.ByteString where+	toUUID b+		| B.null b = NoUUID+		| otherwise = UUID b++instance FromUUID String where+	fromUUID s = decodeBS' (fromUUID s)+ instance ToUUID String where-	toUUID [] = NoUUID-	toUUID s = UUID s+	toUUID s = toUUID (encodeBS' s) +-- There is no matching FromUUID U.UUID because a git-annex UUID may+-- be NoUUID or perhaps contain something not allowed in a canonical UUID.+instance ToUUID U.UUID where+	toUUID = toUUID . U.toASCIIBytes++buildUUID :: UUID -> Builder+buildUUID (UUID b) = byteString b+buildUUID NoUUID = mempty+ isUUID :: String -> Bool isUUID = isJust . U.fromString -type UUIDMap = M.Map UUID String+-- A description of a UUID.+newtype UUIDDesc = UUIDDesc B.ByteString+	deriving (Eq, Sem.Semigroup, Monoid, IsString)++fromUUIDDesc :: UUIDDesc -> String+fromUUIDDesc (UUIDDesc d) = decodeBS d++toUUIDDesc :: String -> UUIDDesc+toUUIDDesc = UUIDDesc . encodeBS++buildUUIDDesc :: UUIDDesc -> Builder+buildUUIDDesc (UUIDDesc b) = byteString b++type UUIDDescMap = M.Map UUID UUIDDesc  instance Proto.Serializable UUID where 	serialize = fromUUID
Types/View.hs view
@@ -23,7 +23,8 @@ 	deriving (Eq, Read, Show)  instance Arbitrary View where-	arbitrary = View <$> pure (Git.Ref "master") <*> arbitrary+	arbitrary = View (Git.Ref "master")+		<$> resize 10 (listOf arbitrary)  data ViewComponent = ViewComponent 	{ viewField :: MetaField@@ -43,8 +44,7 @@  instance Arbitrary ViewFilter where 	arbitrary = do-		size <- arbitrarySizedBoundedIntegral `suchThat` (< 100)-		s <- S.fromList <$> vector size+		s <- S.fromList <$> resize 10 (listOf arbitrary) 		ifM arbitrary 			( return (FilterValues s) 			, return (ExcludeValues s)
Upgrade/V1.hs view
@@ -10,6 +10,9 @@ import System.Posix.Types import Data.Char import Data.Default+import Data.ByteString.Builder+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L  import Annex.Common import Annex.Content@@ -131,7 +134,7 @@   where 	len = length l - 4 	k = readKey1 (take len l)-	sane = (not . null $ keyName k) && (not . null $ formatKeyVariety $ keyVariety k)+	sane = (not . S.null $ keyName k) && (not . S.null $ formatKeyVariety $ keyVariety k)  -- WORM backend keys: "WORM:mtime:size:filename" -- all the rest: "backend:key"@@ -141,10 +144,10 @@ -- as the v2 key that it is. readKey1 :: String -> Key readKey1 v-	| mixup = fromJust $ file2key $ intercalate ":" $ Prelude.tail bits+	| mixup = fromJust $ deserializeKey $ intercalate ":" $ Prelude.tail bits 	| otherwise = stubKey-		{ keyName = n-		, keyVariety = parseKeyVariety b+		{ keyName = encodeBS n+		, keyVariety = parseKeyVariety (encodeBS b) 		, keySize = s 		, keyMtime = t 		}@@ -163,11 +166,11 @@  showKey1 :: Key -> String showKey1 Key { keyName = n , keyVariety = v, keySize = s, keyMtime = t } =-	intercalate ":" $ filter (not . null) [b, showifhere t, showifhere s, n]+	intercalate ":" $ filter (not . null) [b, showifhere t, showifhere s, decodeBS n]   where 	showifhere Nothing = "" 	showifhere (Just x) = show x-	b = formatKeyVariety v+	b = decodeBS $ formatKeyVariety v  keyFile1 :: Key -> FilePath keyFile1 key = replace "/" "%" $ replace "%" "&s" $ replace "&" "&a"  $ showKey1 key@@ -177,11 +180,11 @@ 	replace "&a" "&" $ replace "&s" "%" $ replace "%" "/" file  writeLog1 :: FilePath -> [LogLine] -> IO ()-writeLog1 file ls = viaTmp writeFile file (showLog ls)+writeLog1 file ls = viaTmp L.writeFile file (toLazyByteString $ buildLog ls)  readLog1 :: FilePath -> IO [LogLine] readLog1 file = catchDefaultIO [] $-	parseLog <$> readFileStrict file+	parseLog . encodeBL <$> readFileStrict file  lookupFile1 :: FilePath -> Annex (Maybe (Key, Backend)) lookupFile1 file = do@@ -194,14 +197,14 @@ 	makekey l = case maybeLookupBackendVariety (keyVariety k) of 		Nothing -> do 			unless (null kname || null bname ||-			        not (isLinkToAnnex l)) $+			        not (isLinkToAnnex (toRawFilePath l))) $ 				warning skip 			return Nothing 		Just backend -> return $ Just (k, backend) 	  where 		k = fileKey1 l-		bname = formatKeyVariety (keyVariety k)-		kname = keyName k+		bname = decodeBS (formatKeyVariety (keyVariety k))+		kname = decodeBS (keyName k) 		skip = "skipping " ++ file ++  			" (unknown backend " ++ bname ++ ")"
Upgrade/V2.hs view
@@ -83,7 +83,7 @@ 	old <- fromRepo olddir 	new <- liftIO (readFile $ old </> source) 	Annex.Branch.change dest $ \prev -> -		unlines $ nub $ lines prev ++ lines new+		encodeBL $ unlines $ nub $ lines (decodeBL prev) ++ lines new  logFiles :: FilePath -> Annex [FilePath] logFiles dir = return . filter (".log" `isSuffixOf`)
Upgrade/V5.hs view
@@ -29,6 +29,8 @@ import Utility.InodeCache import Annex.AdjustedBranch +import qualified Data.ByteString as S+ upgrade :: Bool -> Annex Bool upgrade automatic = do 	unless automatic $@@ -117,7 +119,7 @@ 		void $ linkToAnnex k f ic 	writepointer f k = liftIO $ do 		nukeFile f-		writeFile f (formatPointer k)+		S.writeFile f (formatPointer k)  {- Remove all direct mode bookkeeping files. -} removeDirectCruft :: Annex ()
Utility/Aeson.hs view
@@ -2,7 +2,7 @@  -  - Import instead of Data.Aeson  -- - Copyright 2018 Joey Hess <id@joeyh.name>+ - Copyright 2018-2019 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}@@ -14,6 +14,7 @@ 	ToJSON'(..), 	encode, 	packString,+	packByteString, ) where  import Data.Aeson as X hiding (ToJSON, toJSON, encode)@@ -43,9 +44,19 @@ class ToJSON' a where 	toJSON' :: a -> Value +instance ToJSON' T.Text where+	toJSON' = toJSON+ instance ToJSON' String where 	toJSON' = toJSON . packString +-- | Aeson does not have a ToJSON instance for ByteString;+-- this one assumes that the ByteString contains text, and will+-- have the same effect as toJSON' . decodeBS, but with a more efficient+-- implementation.+instance ToJSON' S.ByteString where+	toJSON' = toJSON . packByteString+ -- | Pack a String to Text, correctly handling the filesystem encoding. -- -- Use this instead of Data.Text.pack.@@ -53,9 +64,16 @@ -- Note that if the string contains invalid UTF8 characters not using -- the FileSystemEncoding, this is the same as Data.Text.pack. packString :: String -> T.Text-packString s = case T.decodeUtf8' (S.concat $ L.toChunks $ encodeBS s) of+packString s = case T.decodeUtf8' (encodeBS s) of 	Right t -> t 	Left _ -> T.pack s++-- | The same as packString . decodeBS, but more efficient in the usual+-- case.+packByteString :: S.ByteString -> T.Text+packByteString b = case T.decodeUtf8' b of+	Right t -> t+	Left _ -> T.pack (decodeBS b)  -- | An instance for lists cannot be included as it would overlap with -- the String instance. Instead, you can use a Vector.
Utility/AuthToken.hs view
@@ -28,7 +28,7 @@ import qualified Data.ByteString.Lazy as L import "crypto-api" Crypto.Random --- | An AuthToken is stored in secue memory, with constant time comparison.+-- | An AuthToken is stored in secure memory, with constant time comparison. -- -- It can have varying length, depending on the security needs of the -- application.
Utility/Base64.hs view
@@ -1,39 +1,49 @@-{- Simple Base64 encoding of Strings- -- - Note that this uses the FileSystemEncoding, so it can be used on Strings- - that repesent filepaths containing arbitrarily encoded characters.+{- Simple Base64 encoding  -- - Copyright 2011, 2015 Joey Hess <id@joeyh.name>+ - Copyright 2011-2019 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -} -module Utility.Base64 (toB64, fromB64Maybe, fromB64, prop_b64_roundtrips) where+module Utility.Base64 where  import Utility.FileSystemEncoding  import qualified "sandi" Codec.Binary.Base64 as B64 import Data.Maybe-import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString as B import Data.ByteString.UTF8 (fromString, toString) import Data.Char -toB64 :: String -> String	-toB64 = toString . B64.encode . L.toStrict . encodeBS+-- | This uses the FileSystemEncoding, so it can be used on Strings+-- that repesent 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 . L.fromStrict)+fromB64Maybe s = either (const Nothing) (Just . decodeBS) 	(B64.decode $ fromString s) +fromB64Maybe' :: B.ByteString -> Maybe (B.ByteString)+fromB64Maybe' = either (const Nothing) Just . B64.decode+ fromB64 :: String -> String fromB64 = fromMaybe bad . fromB64Maybe   where 	bad = error "bad base64 encoded data" +fromB64' :: B.ByteString -> B.ByteString+fromB64' = fromMaybe bad . fromB64Maybe'+  where+	bad = error "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 fromB64 always generates an output encoded that way.+-- not roundtrip, as decodeBS always generates an output encoded that way. prop_b64_roundtrips :: String -> Bool prop_b64_roundtrips s-	| all (isAscii) s = s == fromB64 (toB64 s)+	| all (isAscii) s = s == decodeBS (fromB64' (toB64' (encodeBS s))) 	| otherwise = True
Utility/DirWatcher/INotify.hs view
@@ -12,9 +12,6 @@ import Common hiding (isDirectory) import Utility.ThreadLock import Utility.DirWatcher.Types-#if MIN_VERSION_hinotify(0,3,10)-import Utility.FileSystemEncoding-#endif  import System.INotify import qualified System.Posix.Files as Files
Utility/FileMode.hs view
@@ -69,6 +69,7 @@ otherGroupModes =  	[ groupReadMode, otherReadMode 	, groupWriteMode, otherWriteMode+	, groupExecuteMode, otherExecuteMode 	]  {- Removes the write bits from a file. -}
Utility/FileSystemEncoding.hs view
@@ -15,8 +15,14 @@ 	RawFilePath, 	fromRawFilePath, 	toRawFilePath,+	decodeBL,+	encodeBL, 	decodeBS, 	encodeBS,+	decodeBL',+	encodeBL',+	decodeBS',+	encodeBS', 	decodeW8, 	encodeW8, 	encodeW8NUL,@@ -38,6 +44,7 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L #ifdef mingw32_HOST_OS+import qualified Data.ByteString.UTF8 as S8 import qualified Data.ByteString.Lazy.UTF8 as L8 #endif @@ -107,23 +114,51 @@ 		`catchNonAsync` (\_ -> return fp)  {- Decodes a ByteString into a FilePath, applying the filesystem encoding. -}-decodeBS :: L.ByteString -> FilePath+decodeBL :: L.ByteString -> FilePath #ifndef mingw32_HOST_OS-decodeBS = encodeW8NUL . L.unpack+decodeBL = encodeW8NUL . L.unpack #else {- On Windows, we assume that the ByteString is utf-8, since Windows  - only uses unicode for filenames. -}-decodeBS = L8.toString+decodeBL = L8.toString #endif  {- Encodes a FilePath into a ByteString, applying the filesystem encoding. -}-encodeBS :: FilePath -> L.ByteString+encodeBL :: FilePath -> L.ByteString #ifndef mingw32_HOST_OS-encodeBS = L.pack . decodeW8NUL+encodeBL = L.pack . decodeW8NUL #else-encodeBS = L8.fromString+encodeBL = L8.fromString #endif +decodeBS :: S.ByteString -> FilePath+#ifndef mingw32_HOST_OS+decodeBS = encodeW8NUL . S.unpack+#else+decodeBS = S8.toString+#endif++encodeBS :: FilePath -> S.ByteString+#ifndef mingw32_HOST_OS+encodeBS = S.pack . decodeW8NUL+#else+encodeBS = S8.fromString+#endif++{- Faster version that assumes the string does not contain NUL;+ - if it does it will be truncated before the NUL. -}+decodeBS' :: S.ByteString -> FilePath+decodeBS' = encodeW8 . S.unpack++encodeBS' :: FilePath -> S.ByteString+encodeBS' = S.pack . decodeW8++decodeBL' :: L.ByteString -> FilePath+decodeBL' = encodeW8 . L.unpack++encodeBL' :: FilePath -> L.ByteString+encodeBL' = L.pack . decodeW8+ {- Recent versions of the unix package have this alias; defined here  - for backwards compatibility. -} type RawFilePath = S.ByteString@@ -132,22 +167,22 @@  - since filename's don't. This should only be used with actual  - RawFilePaths not arbitrary ByteString that may contain NUL. -} fromRawFilePath :: RawFilePath -> FilePath-fromRawFilePath = encodeW8 . S.unpack+fromRawFilePath = decodeBS'  {- Note that the FilePath is assumed to never contain NUL,  - since filename's don't. This should only be used with actual FilePaths  - not arbitrary String that may contain NUL. -} toRawFilePath :: FilePath -> RawFilePath-toRawFilePath = S.pack . decodeW8+toRawFilePath = encodeBS'  {- Converts a [Word8] to a FilePath, encoding using the filesystem encoding.  -- - w82c produces a String, which may contain Chars that are invalid+ - w82s produces a String, which may contain Chars that are invalid  - unicode. From there, this is really a simple matter of applying the  - file system encoding, only complicated by GHC's interface to doing so.  -  - Note that the encoding stops at any NUL in the input. FilePaths- - do not normally contain embedded NUL, but Haskell Strings may.+ - cannot contain embedded NUL, but Haskell Strings may.  -} {-# NOINLINE encodeW8 #-} encodeW8 :: [Word8] -> FilePath@@ -155,8 +190,6 @@ 	enc <- Encoding.getFileSystemEncoding 	GHC.withCString Encoding.char8 (w82s w8) $ GHC.peekCString enc -{- Useful when you want the actual number of bytes that will be used to- - represent the FilePath on disk. -} decodeW8 :: FilePath -> [Word8] decodeW8 = s2w8 . _encodeFilePath
Utility/Gpg.hs view
@@ -19,7 +19,7 @@ #else import Utility.Tmp #endif-import Utility.Tmp.Dir+import Utility.FileMode import Utility.Format (decode_c)  import Control.Concurrent@@ -347,37 +347,39 @@  #ifndef mingw32_HOST_OS {- Runs an action using gpg in a test harness, in which gpg does- - not use ~/.gpg/, but a directory with the test key set up to be used. -}-testHarness :: GpgCmd -> IO a -> IO a-testHarness cmd a = withTmpDir "gpgtmpXXXXXX" $ \tmpdir ->-	bracket (setup tmpdir) (cleanup tmpdir) (const a)+ - not use ~/.gpg/, but sets up the test key in a subdirectory of + - the passed directory and uses it. -}+testHarness :: FilePath -> GpgCmd -> IO a -> IO a+testHarness tmpdir cmd a = bracket setup cleanup (const a)   where 	var = "GNUPGHOME"		 -	setup tmpdir = do+	setup = do 		orig <- getEnv var-		setEnv var tmpdir True+		subdir <- makenewdir (1 :: Integer)+		-- gpg is picky about permissions on its home dir+		liftIO $ void $ tryIO $ modifyFileMode subdir $+			removeModes $ otherGroupModes+		setEnv var subdir True 		-- For some reason, recent gpg needs a trustdb to be set up. 		_ <- pipeStrict cmd [Param "--trust-model", Param "auto", Param "--update-trustdb"] [] 		_ <- pipeStrict cmd [Param "--import", Param "-q"] $ unlines 			[testSecretKey, testKey] 		return orig 		-	cleanup tmpdir orig = do-		removeDirectoryRecursive tmpdir-			-- gpg-agent may be shutting down at the same time-			-- and may delete its socket at the same time as-			-- we're trying to, causing an exception. Retrying-			-- will deal with this race.-			`catchIO` (\_ -> removeDirectoryRecursive tmpdir)-		reset orig-	reset (Just v) = setEnv var v True-	reset _ = unsetEnv var+	cleanup (Just v) = setEnv var v True+	cleanup Nothing = unsetEnv var +        makenewdir n = do+		let subdir = tmpdir </> show n+		catchIOErrorType AlreadyExists (const $ makenewdir $ n + 1) $ do+			createDirectory subdir+			return subdir+ {- Tests the test harness. -}-testTestHarness :: GpgCmd -> IO Bool-testTestHarness cmd = do-	keys <- testHarness cmd $ findPubKeys cmd testKeyId+testTestHarness :: FilePath -> GpgCmd -> IO Bool+testTestHarness tmpdir cmd = do+	keys <- testHarness tmpdir cmd $ findPubKeys cmd testKeyId 	return $ KeyIds [testKeyId] == keys #endif
Utility/Hash.hs view
@@ -33,10 +33,10 @@ 	prop_mac_stable, ) where +import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import qualified Data.Text as T import qualified Data.Text.Encoding as T-import qualified Data.ByteString as S import "cryptonite" Crypto.MAC.HMAC import "cryptonite" Crypto.Hash
Utility/HumanTime.hs view
@@ -60,15 +60,17 @@ fromDuration :: Duration -> String fromDuration Duration { durationSeconds = d } 	| d == 0 = "0s"-	| otherwise = concatMap showunit $ go [] units d+	| otherwise = concatMap showunit $ take 2 $ go [] units d   where-	showunit (u, n)-		| n > 0 = show n ++ [u]-		| otherwise = ""+	showunit (u, n) = show n ++ [u] 	go c [] _ = reverse c 	go c ((u, n):us) v = 		let (q,r) = v `quotRem` n-		in go ((u, q):c) us r+		in if q > 0+			then go ((u, q):c) us r+			else if null c+				then go c us r+				else reverse c  units :: [(Char, Integer)] units =
Utility/InodeCache.hs view
@@ -156,7 +156,7 @@ 	(inode:size:mtime:mtimedecimal:_) -> do 		i <- readish inode 		sz <- readish size-		t <- parsePOSIXTime' mtime mtimedecimal+		t <- parsePOSIXTime $ mtime ++ '.' : mtimedecimal 		return $ InodeCache $ InodeCachePrim i sz (MTimeHighRes t) 	_ -> Nothing
Utility/LockFile/PidLock.hs view
@@ -102,7 +102,7 @@ 	let shortbase = reverse $ take 32 $ reverse base 	let md5sum = if base == shortbase 		then ""-		else show (md5 (encodeBS base))+		else show (md5 (encodeBL base)) 	dir <- ifM (doesDirectoryExist "/dev/shm") 		( return "/dev/shm" 		, return "/tmp"
Utility/Metered.hs view
@@ -10,7 +10,6 @@ module Utility.Metered where  import Common-import Utility.FileSystemEncoding import Utility.Percentage import Utility.DataUnits import Utility.HumanTime
Utility/Process.hs view
@@ -178,13 +178,10 @@ 		, std_out = Inherit 		, std_err = Inherit 		}-	(select, p')-		| h == StdinHandle  =-			(stdinHandle, base { std_in = CreatePipe })-		| h == StdoutHandle =-			(stdoutHandle, base { std_out = CreatePipe })-		| h == StderrHandle =-			(stderrHandle, base { std_err = CreatePipe })+	(select, p') = case h of+		StdinHandle -> (stdinHandle, base { std_in = CreatePipe })+		StdoutHandle -> (stdoutHandle, base { std_out = CreatePipe })+		StderrHandle -> (stderrHandle, base { std_err = CreatePipe })  -- | Like withHandle, but passes (stdin, stdout) handles to the action. withIOHandles
+ Utility/RawFilePath.hs view
@@ -0,0 +1,28 @@+{- Portability shim around System.Posix.Files.ByteString+ -+ - Copyright 2019 Joey Hess <id@joeyh.name>+ -+ - License: BSD-2-clause+ -}++{-# LANGUAGE CPP #-}++module Utility.RawFilePath (+	RawFilePath,+	readSymbolicLink,+) where++#ifndef mingw32_HOST_OS+import System.Posix.Files.ByteString+import System.Posix.ByteString.FilePath+#else+import qualified Data.ByteString as B+import System.IO.Error++type RawFilePath = B.ByteString++readSymbolicLink :: RawFilePath -> IO RawFilePath+readSymbolicLink _ = ioError $ mkIOError illegalOperationErrorType x Nothing Nothing+  where+	x = "Utility.RawFilePath.readSymbolicLink: not supported"+#endif
Utility/TimeStamp.hs view
@@ -1,6 +1,6 @@ {- timestamp parsing and formatting  -- - Copyright 2015-2016 Joey Hess <id@joeyh.name>+ - Copyright 2015-2019 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}@@ -9,37 +9,51 @@  module Utility.TimeStamp where -import Utility.PartialPrelude-import Utility.Misc+import Utility.Data  import Data.Time.Clock.POSIX import Data.Time import Data.Ratio+import Control.Applicative+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8+import qualified Data.Attoparsec.ByteString as A+import Data.Attoparsec.ByteString.Char8 (char, decimal, signed, isDigit_w8) #if ! MIN_VERSION_time(1,5,0) import System.Locale #endif  {- Parses how POSIXTime shows itself: "1431286201.113452s"- - Also handles the format with no fractional seconds. -}+ - (The "s" is included for historical reasons and is optional.)+ - Also handles the format with no decimal seconds. -}+parserPOSIXTime :: A.Parser POSIXTime+parserPOSIXTime = mkPOSIXTime+	<$> signed decimal+	<*> (declen <|> pure (0, 0))+	<* optional (char 's')+  where+	declen :: A.Parser (Integer, Int)+	declen = do+		_ <- char '.'+		b <- A.takeWhile isDigit_w8+		let len = B.length b+		d <- either fail pure $+			A.parseOnly (decimal <* A.endOfInput) b+		return (d, len)+ parsePOSIXTime :: String -> Maybe POSIXTime-parsePOSIXTime = uncurry parsePOSIXTime' . separate (== '.')+parsePOSIXTime s = eitherToMaybe $ +	A.parseOnly (parserPOSIXTime <* A.endOfInput) (B8.pack s) -{- Parses the integral and decimal part of a POSIXTime -}-parsePOSIXTime' :: String -> String -> Maybe POSIXTime-parsePOSIXTime' sn sd = do-	n <- fromIntegral <$> readi sn-	let sd' = takeWhile (/= 's') sd-	if null sd'-		then return n-		else do-			d <- readi sd'-			let r = d % (10 ^ (length sd'))-			return $ if n < 0-				then n - fromRational r-				else n + fromRational r+{- This implementation allows for higher precision in a POSIXTime than+ - supported by the system's Double, and avoids the complications of+ - floating point. -}+mkPOSIXTime :: Integer -> (Integer, Int) -> POSIXTime+mkPOSIXTime n (d, dlen)+	| n < 0 = fromIntegral n - fromRational r+	| otherwise = fromIntegral n + fromRational r   where-	readi :: String -> Maybe Integer-	readi = readish+	r = d % (10 ^ dlen)  formatPOSIXTime :: String -> POSIXTime -> String formatPOSIXTime fmt t = formatTime defaultTimeLocale fmt (posixSecondsToUTCTime t)
Utility/Tmp/Dir.hs view
@@ -19,8 +19,7 @@ #endif  import Utility.Exception--type Template = String+import Utility.Tmp (Template)  {- Runs an action with a tmp directory located within the system's tmp  - directory (or within "." if there is none), then removes the tmp
doc/git-annex-adjust.mdwn view
@@ -38,6 +38,14 @@   Unlock all annexed files in the adjusted branch. This allows   annexed files to be modified. +  Normally, unlocking a file requires a copy to be made of its content,+  so that its original content is preserved, while the copy can be modified.+  To use less space, annex.thin can be set to true before running this+  command; this makes a hard link to the content be made instead of a copy.+  (When supported by the file system.) While this can save considerable+  disk space, any modification made to a file will cause the old version of the+  file to be lost from the local repository. So, enable annex.thin with care.+ * `--fix`    Fix the symlinks to annexed files to point to the local git annex
doc/git-annex-calckey.mdwn view
@@ -1,6 +1,6 @@ # NAME -git-annex calckey - calculates the key that would be used to refer to a file+git-annex calckey - calulate key for a file  # SYNOPSIS
doc/git-annex-info.mdwn view
@@ -1,6 +1,6 @@ # NAME -git-annex info - shows information about the specified item or the repository as a whole+git-annex info - information about an item or the repository  # SYNOPSIS
doc/git-annex-testremote.mdwn view
@@ -8,8 +8,8 @@  # DESCRIPTION -This tests a remote by generating some random objects and sending them to-the remote, then redownloading them, removing them from the remote, etc.+This tests a remote by sending objects to it, downloading objects from it,+etc.  It's safe to run in an existing repository (the repository contents are not altered), although it may perform expensive data transfers.@@ -20,7 +20,8 @@  Testing will use the remote's configuration, automatically varying the chunk sizes, and with simple shared encryption disabled and enabled,-and exporttree disabled and enabled.+and exporttree disabled and enabled. If the remote is readonly, testing+is limited to checking various properties of downloading from it.  # OPTIONS @@ -28,9 +29,19 @@    Perform a smaller set of tests. +* `--test-readonly=file`++  Normally, random objects are generated for the test and are sent to the+  remote. When a readonly remote is being tested, that cannot be done,+  and so you need to specify some annexed files to use in the testing,+  using this option. Their content needs to be present in the readonly remote+  being tested, and in the local repository.++  This option can be repeated.+ * `--size=NUnits` -  Tune the base size of the generated objects. The default is 1MiB.+  Tune the base size of generated objects. The default is 1MiB.  # SEE ALSO
doc/git-annex.mdwn view
@@ -730,6 +730,8 @@    This runs git-annex's built-in benchmarks, if it was built with   benchmarking support.+  +  See [[git-annex-benchmark]](1) for details.  # COMMON OPTIONS
git-annex.cabal view
@@ -1,11 +1,11 @@ Name: git-annex-Version: 7.20181211+Version: 7.20190122 Cabal-Version: >= 1.8 License: GPL-3 Maintainer: Joey Hess <id@joeyh.name> Author: Joey Hess Stability: Stable-Copyright: 2010-2017 Joey Hess+Copyright: 2010-2019 Joey Hess License-File: COPYRIGHT Homepage: http://git-annex.branchable.com/ Build-type: Custom@@ -209,7 +209,6 @@   templates/configurators/edit/webrepository.hamlet   templates/configurators/edit/repository.hamlet   templates/configurators/unused.hamlet-  templates/configurators/addbox.com.hamlet   templates/configurators/ssh/testmodal.hamlet   templates/configurators/ssh/expiredpassword.hamlet   templates/configurators/ssh/error.hamlet@@ -228,7 +227,6 @@   templates/configurators/addrepository/wormholepairing.hamlet   templates/configurators/rsync.net/add.hamlet   templates/configurators/rsync.net/encrypt.hamlet-  templates/configurators/gitlab.com/add.hamlet   templates/configurators/needgcrypt.hamlet   templates/configurators/needtor.hamlet   templates/configurators/needmagicwormhole.hamlet@@ -588,7 +586,6 @@   if flag(Benchmark)     Build-Depends: criterion, deepseq     CPP-Options: -DWITH_BENCHMARK-    Other-Modules: Command.Benchmark      if flag(DebugLocks)     CPP-Options: -DDEBUGLOCKS@@ -646,6 +643,7 @@     Annex.SpecialRemote     Annex.Ssh     Annex.TaggedPush+    Annex.Tmp     Annex.Transfer     Annex.UpdateInstead     Annex.UUID@@ -663,6 +661,7 @@     Backend.URL     Backend.Utilities     Backend.WORM+    Benchmark     Build.BundledPrograms     Build.Configure     Build.DesktopFile@@ -689,6 +688,7 @@     Command.AddUnused     Command.AddUrl     Command.Adjust+    Command.Benchmark     Command.CalcKey     Command.CheckPresentKey     Command.Commit@@ -949,6 +949,7 @@     Types.AdjustedBranch     Types.Availability     Types.Backend+    Types.Benchmark     Types.BranchState     Types.CleanupActions     Types.Command@@ -1055,6 +1056,7 @@     Utility.Process.Shim     Utility.Process.Transcript     Utility.QuickCheck+    Utility.RawFilePath     Utility.Rsync     Utility.SafeCommand     Utility.Scheduled
git-annex.hs view
@@ -15,6 +15,7 @@ import qualified CmdLine.GitAnnexShell import qualified CmdLine.GitRemoteTorAnnex import qualified Test+import qualified Benchmark import Utility.FileSystemEncoding  #ifdef mingw32_HOST_OS@@ -34,7 +35,7 @@ 	run ps n = case takeFileName n of 		"git-annex-shell" -> CmdLine.GitAnnexShell.run ps 		"git-remote-tor-annex" -> CmdLine.GitRemoteTorAnnex.run ps-		_  -> CmdLine.GitAnnex.run Test.optParser Test.runner ps+		_  -> CmdLine.GitAnnex.run Test.optParser Test.runner Benchmark.mkGenerator ps  #ifdef mingw32_HOST_OS {- On Windows, if HOME is not set, probe it and set it.
stack.yaml view
@@ -10,6 +10,7 @@     magicmime: false     dbus: false     debuglocks: false+    benchmark: false packages: - '.' extra-deps:
− templates/configurators/addbox.com.hamlet 
@@ -1,28 +0,0 @@-<div .col-sm-9>-  <div .content-box>-    <h2>-      Adding a Box.com repository-    <p>-      <a href="http://box.com">Box.com</a> offers a small quantity of storage #-      for free, and larger quantities for a fee.-    <p>-      Even a small amount of free storage is useful, as a transfer point #-      between your repositories.-    <p>-      <form method="post" .form-horizontal enctype=#{enctype}>-        <fieldset>-          ^{form}-          ^{webAppFormAuthToken}-          <div .form-group>-            <div .col-sm-10 .col-sm-offset-2>-              <button .btn .btn-primary type=submit onclick="$('#workingmodal').modal('show');">-                Add repository-<div .modal .fade #workingmodal>-  <div .modal-dialog>-    <div .modal-content>-      <div .modal-header>-        <h3>-          Making repository ...-      <div .modal-body>-        <p>-          Setting up your Box.com repository. This could take a minute.
templates/configurators/addrepository/cloud.hamlet view
@@ -1,18 +1,4 @@ <h3>-  <a href="@{AddGitLabR}">-    <span .glyphicon .glyphicon-plus-sign>-    \ Gitlab.com-<p>-  Hosts git-annex repositories for free.--<h3>-  <a href="@{AddBoxComR}">-    <span .glyphicon .glyphicon-plus-sign>-    \ Box.com-<p>-  Provides free storage for small amounts of data.--<h3>   <a href="@{AddRsyncNetR}">     <span .glyphicon .glyphicon-plus-sign>     \ Rsync.net
− templates/configurators/gitlab.com/add.hamlet 
@@ -1,50 +0,0 @@-<div .col-sm-9>-  <div .content-box>-    <h2>-      Adding a GitLab.com repository-    <p>-      <a href="http://gitlab.com/">-        GitLab.com #-      provides free public and private git repositories, and supports #-      git-annex. While the amount of data that can be stored there is limited #-      (<a href="https://about.gitlab.com/gitlab-com/">to 10 gb currently</a>), #-      it's enough for smaller repositories, #-      or as a transfer point between larger repositories.-    <p>-      $case status-        $of UnusableServer msg-          <div .alert .alert-danger>-            <span .glyphicon .glyphicon-warning-sign>-            \ #{msg}-        $of ServerNeedsPubKey pubkey-          <div .alert>-            <span .glyphicon .glyphicon-warning-sign>-            \ You need to configure GitLab to accept a SSH public key.-            <p>-              Open a tab to #-                <a href="https://gitlab.com/profile/keys" target="_blank">-                  https://gitlab.com/profile/keys-              and copy and paste this public key into it:-              <pre>-                #{pubkey}-            <p>-              Once you have added the key to GitLab, come back to this page #-              to finish setting up the repository.-        $of _-          <p>-            You can sign up for an account on #-            <a href="http://gitlab.com/">-              GitLab.com #-            and create a git repository that you want to use with git-annex, #-            or find an existing git-annex repository to share with.-          <p>-           Copy the GitLab repository's SSH clone url into the form below.-      <form method="post" .form-horizontal enctype=#{enctype}>-        <fieldset>-          ^{form}-          ^{webAppFormAuthToken}-          <div .form-group>-            <div .col-sm-10 .col-sm-offset-2>-              <button .btn .btn-primary type=submit onclick="$('#setupmodal').modal('show');">-                Use this gitlab.com repository-^{sshTestModal}