packages feed

git-annex 6.20170510 → 6.20170519

raw patch · 60 files changed

+471/−195 lines, 60 filesdep +memorydep +splitdep −MissingH

Dependencies added: memory, split

Dependencies removed: MissingH

Files

Annex.hs view
@@ -71,6 +71,7 @@ import "mtl" Control.Monad.Reader import Control.Concurrent import Control.Concurrent.Async+import Control.Concurrent.STM import qualified Data.Map as M import qualified Data.Set as S @@ -124,6 +125,7 @@ 	, groupmap :: Maybe GroupMap 	, ciphers :: M.Map StorableCipher Cipher 	, lockcache :: LockCache+	, sshstalecleaned :: TMVar Bool 	, flags :: M.Map String Bool 	, fields :: M.Map String String 	, cleanup :: M.Map CleanupAction (Annex ())@@ -145,6 +147,8 @@ newState :: GitConfig -> Git.Repo -> IO AnnexState newState c r = do 	emptyactiveremotes <- newMVar M.empty+	o <- newMessageState+	sc <- newTMVarIO False 	return $ AnnexState 		{ repo = r 		, repoadjustment = return@@ -152,7 +156,7 @@ 		, backend = Nothing 		, remotes = [] 		, remoteannexstate = M.empty-		, output = def+		, output = o 		, concurrency = NonConcurrent 		, force = False 		, fast = False@@ -175,6 +179,7 @@ 		, groupmap = Nothing 		, ciphers = M.empty 		, lockcache = M.empty+		, sshstalecleaned = sc 		, flags = M.empty 		, fields = M.empty 		, cleanup = M.empty
Annex/AdjustedBranch.hs view
@@ -51,6 +51,7 @@ import Annex.Perms import Annex.GitOverlay import Utility.Tmp+import Utility.CopyFile import qualified Database.Keys import Config @@ -355,9 +356,22 @@ 		misctmpdir <- fromRepo gitAnnexTmpMiscDir 		void $ createAnnexDirectory misctmpdir 		tmpwt <- fromRepo gitAnnexMergeDir+		git_dir <- fromRepo Git.localGitDir 		withTmpDirIn misctmpdir "git" $ \tmpgit -> withWorkTreeRelated tmpgit $ 			withemptydir tmpwt $ withWorkTree tmpwt $ do 				liftIO $ writeFile (tmpgit </> "HEAD") (fromRef updatedorig)+				-- Copy in refs and packed-refs, to work+				-- around bug in git 2.13.0, which+				-- causes it not to look in GIT_DIR for refs.+				refs <- liftIO $ dirContentsRecursive $+					git_dir </> "refs"+				let refs' = (git_dir </> "packed-refs") : refs+				liftIO $ forM_ refs' $ \src ->+					whenM (doesFileExist src) $ do+						dest <- relPathDirToFile git_dir src+						let dest' = tmpgit </> dest+						createDirectoryIfMissing True (takeDirectory dest')+						void $ createLinkOrCopy src dest' 				-- This reset makes git merge not care 				-- that the work tree is empty; otherwise 				-- it will think that all the files have
Annex/Branch.hs view
@@ -29,8 +29,8 @@ import qualified Data.ByteString.Lazy as L import qualified Data.Set as S import qualified Data.Map as M-import Data.Bits.Utils import Data.Function+import Data.Char import Control.Concurrent (threadDelay)  import Annex.Common@@ -304,7 +304,7 @@ 	-- look for "parent ref" lines and return the refs 	commitparents = map (Git.Ref . snd) . filter isparent . 		map (toassoc . decodeBS) . L.split newline-	newline = c2w8 '\n'+	newline = fromIntegral (ord '\n') 	toassoc = separate (== ' ') 	isparent (k,_) = k == "parent"
Annex/DirHashes.hs view
@@ -1,6 +1,6 @@ {- git-annex file locations  -- - Copyright 2010-2015 Joey Hess <id@joeyh.name>+ - Copyright 2010-2017 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -19,14 +19,15 @@  import Data.Bits import Data.Word-import Data.Hash.MD5 import Data.Default+import qualified Data.ByteArray  import Common import Key import Types.GitConfig import Types.Difference import Utility.FileSystemEncoding+import Utility.Hash  type Hasher = Key -> FilePath @@ -62,15 +63,24 @@ hashDirs (HashLevels 1) sz s = addTrailingPathSeparator $ take sz s 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++{- 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 $ display_32bits_as_dir =<< [a,b,c,d]+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   where-	ABCD (a,b,c,d) = md5 $ md5FilePath $ key2file $ nonChunkKey k--hashDirLower :: HashLevels -> Hasher-hashDirLower n k = hashDirs n 3 $ take 6 $ md5s $ md5FilePath $ key2file $ nonChunkKey k+	encodeWord32 (b1:b2:b3:b4:rest) =+		(shiftL b4 24 .|. shiftL b3 16 .|. shiftL b2 8 .|. b1)+		: encodeWord32 rest+	encodeWord32 _ = []  {- modified version of display_32bits_as_hex from Data.Hash.MD5+ - in MissingH  -   Copyright (C) 2001 Ian Lynagh   -   License: Either BSD or GPL  -}
Annex/Locations.hs view
@@ -172,7 +172,7 @@ gitAnnexLink :: FilePath -> Key -> Git.Repo -> GitConfig -> IO FilePath gitAnnexLink file key r config = do 	currdir <- getCurrentDirectory-	let absfile = fromMaybe whoops $ absNormPathUnix currdir file+	let absfile = absNormPathUnix currdir file 	let gitdir = getgitdir currdir 	loc <- gitAnnexLocation' key r config False False (\_ -> return True) gitdir 	toInternalGitPath <$> relPathDirToFile (parentDir absfile) loc@@ -182,10 +182,10 @@ 		 - supporting symlinks; generate link target that will 		 - work portably. -} 		| not (coreSymlinks config) && needsSubmoduleFixup r =-			fromMaybe whoops $ absNormPathUnix currdir $-				Git.repoPath r </> ".git"+			absNormPathUnix currdir $ Git.repoPath r </> ".git" 		| otherwise = Git.localGitDir r-	whoops = error $ "unable to normalize " ++ file+	absNormPathUnix d p = toInternalGitPath $+		absPathFrom (toInternalGitPath d) (toInternalGitPath p)  {- Calculates a symlink target as would be used in a typical git  - repository, with .git in the top of the work tree. -}
Annex/LockFile.hs view
@@ -11,6 +11,7 @@ 	lockFileCached, 	unlockFile, 	getLockCache,+	fromLockCache, 	withExclusiveLock, 	tryExclusiveLock, ) where
Annex/Ssh.hs view
@@ -23,10 +23,6 @@ 	runSshAskPass ) where -import qualified Data.Map as M-import Data.Hash.MD5-import System.Exit- import Annex.Common import Annex.LockFile import qualified Build.SysConfig as SysConfig@@ -37,7 +33,9 @@ import Annex.Path import Utility.Env import Utility.FileSystemEncoding+import Utility.Hash import Types.CleanupActions+import Types.Concurrency import Git.Env import Git.Ssh #ifndef mingw32_HOST_OS@@ -45,6 +43,8 @@ import Annex.LockPool #endif +import Control.Concurrent.STM+ {- Some ssh commands are fed stdin on a pipe and so should be allowed to  - consume it. But ssh commands that are not piped stdin should generally  - not be allowed to consume the process's stdin. -}@@ -71,16 +71,18 @@ sshOptions :: ConsumeStdin -> (String, Maybe Integer) -> RemoteGitConfig -> [CommandParam] -> Annex [CommandParam] sshOptions cs (host, port) gc opts = go =<< sshCachingInfo (host, port)   where-	go (Nothing, params) = ret params+	go (Nothing, params) = return $ mkparams cs params 	go (Just socketfile, params) = do-		prepSocket socketfile-		ret params-	ret ps = return $ concat+		prepSocket socketfile gc+			(Param host : mkparams NoConsumeStdin params)+			+		return $ mkparams cs params+	mkparams cs' ps = concat 		[ ps 		, map Param (remoteAnnexSshOptions gc) 		, opts 		, portParams port-		, consumeStdinParams cs+		, consumeStdinParams cs' 		, [Param "-T"] 		] @@ -158,21 +160,74 @@ portParams Nothing = [] portParams (Just port) = [Param "-p", Param $ show port] -{- Prepare to use a socket file. Locks a lock file to prevent- - other git-annex processes from stopping the ssh on this socket. -}-prepSocket :: FilePath -> Annex ()-prepSocket socketfile = do-	-- If the lock pool is empty, this is the first ssh of this-	-- run. There could be stale ssh connections hanging around+{- Prepare to use a socket file for ssh connection caching.+ -+ - When concurrency is enabled, this blocks until a ssh connection+ - has been made to the host. So, any password prompting by ssh will+ - happen in this call, and only one ssh process will prompt at a time.+ -+ - Locks the socket lock file to prevent other git-annex processes from+ - stopping the ssh multiplexer on this socket.+ -}+prepSocket :: FilePath -> RemoteGitConfig -> [CommandParam] -> Annex ()+prepSocket socketfile gc sshparams = do+	-- There could be stale ssh connections hanging around 	-- from a previous git-annex run that was interrupted.-	whenM (not . any isLock . M.keys <$> getLockCache)-		sshCleanup-	-- Cleanup at end of this run.+	-- This must run only once, before we have made any ssh connection,+	-- and any other prepSocket calls must block while it's run.+	tv <- Annex.getState Annex.sshstalecleaned+	join $ liftIO $ atomically $ do+		cleaned <- takeTMVar tv+		if cleaned+			then do+				putTMVar tv cleaned+				return noop+			else return $ do+				sshCleanup+				liftIO $ atomically $ putTMVar tv True+	-- Cleanup at shutdown. 	Annex.addCleanup SshCachingCleanup sshCleanup-+	 	liftIO $ createDirectoryIfMissing True $ parentDir socketfile-	lockFileCached $ socket2lock socketfile+	let socketlock = socket2lock socketfile +	c <- Annex.getState Annex.concurrency+	case c of+		Concurrent {} -> makeconnection socketlock+		NonConcurrent -> return ()+	+	lockFileCached socketlock+  where+	-- When the LockCache already has the socketlock in it,+	-- the connection has already been started. Otherwise,+	-- get the connection started now.+	makeconnection socketlock =+		whenM (isNothing <$> fromLockCache socketlock) $ do+			let startps = sshparams ++ startSshConnection gc+			-- When we can start the connection in batch mode,+			-- ssh won't prompt to the console.+			(_, connected) <- liftIO $ processTranscript "ssh"+				(["-o", "BatchMode=true"] ++ toCommand startps)+				Nothing+			unless connected $ +				prompt $ void $ liftIO $+					boolSystem "ssh" startps++-- Parameters to get ssh connected to the remote host,+-- by asking it to run a no-op command.+--+-- Could simply run "true", but the remote host may only+-- allow git-annex-shell to run. So, run git-annex-shell inannex+-- with the path to the remote repository and no other parameters,+-- which is a no-op supported by all versions of git-annex-shell.+startSshConnection :: RemoteGitConfig -> [CommandParam]+startSshConnection gc =+	[ Param "git-annex-shell"+	, Param "inannex"+	, File $ Git.repoPath $ gitConfigRepo $+		remoteGitConfig gc+	]+ {- Find ssh socket files.  -  - The check that the lock file exists makes only socket files@@ -242,7 +297,7 @@ hostport2socket host (Just port) = hostport2socket' $ host ++ "!" ++ show port hostport2socket' :: String -> FilePath hostport2socket' s-	| length s > lengthofmd5s = md5s (Str s)+	| length s > lengthofmd5s = show $ md5 $ encodeBS s 	| otherwise = s   where 	lengthofmd5s = 32@@ -323,12 +378,20 @@ 		Just host -> ifM (liftIO $ safe_GIT_SSH <&&> gitSshEnvSet) 			( unchanged 			, do-				(msockfile, _) <- sshCachingInfo (host, Git.Url.port remote)+				let port = Git.Url.port remote+				(msockfile, cacheparams) <- sshCachingInfo (host, port) 				case msockfile of 					Nothing -> use [] 					Just sockfile -> do-						prepSocket sockfile-						use (sshConnectionCachingParams sockfile)+						prepSocket sockfile gc $+							Param host : concat+								[ cacheparams+								, map Param (remoteAnnexSshOptions gc)+								, portParams port+								, consumeStdinParams NoConsumeStdin+								, [Param "-T"]+								]+						use cacheparams 			)   where 	unchanged = return localr
Annex/UUID.hs view
@@ -37,7 +37,7 @@ import qualified Data.UUID as U import qualified Data.UUID.V4 as U4 import qualified Data.UUID.V5 as U5-import Data.Bits.Utils+import Utility.FileSystemEncoding  configkey :: ConfigKey configkey = annexConfig "uuid"
Annex/VariantFile.hs view
@@ -9,8 +9,7 @@  import Annex.Common import Utility.FileSystemEncoding--import Data.Hash.MD5+import Utility.Hash  variantMarker :: String variantMarker = ".variant-"@@ -42,4 +41,4 @@ 	doubleconflict = variantMarker `isInfixOf` file  shortHash :: String -> String-shortHash = take 4 . md5s . md5FilePath+shortHash = take 4 . show . md5 . encodeBS
Assistant/Threads/Committer.hs view
@@ -38,9 +38,9 @@ import qualified Database.Keys import qualified Command.Sync import qualified Git.Branch+import Utility.Tuple  import Data.Time.Clock-import Data.Tuple.Utils import qualified Data.Set as S import qualified Data.Map as M import Data.Either
Assistant/Threads/SanityChecker.hs view
@@ -257,9 +257,9 @@   where 	go (Just Nothing) = noop 	go (Just (Just expireunused)) = expireUnused (Just expireunused)-	go Nothing = maybe noop prompt =<< describeUnusedWhenBig+	go Nothing = maybe noop promptconfig =<< describeUnusedWhenBig -	prompt msg = +	promptconfig msg =  #ifdef WITH_WEBAPP 		do 			button <- mkAlertButton True (T.pack "Configure") urlrenderer ConfigUnusedR
Assistant/Threads/Watcher.hs view
@@ -44,13 +44,13 @@ import Config import Config.GitConfig import Utility.ThreadScheduler+import Utility.FileSystemEncoding import Logs.Location import qualified Database.Keys #ifndef mingw32_HOST_OS import qualified Utility.Lsof as Lsof #endif -import Data.Bits.Utils import Data.Typeable import qualified Data.ByteString.Lazy as L import qualified Control.Exception as E
Assistant/Upgrade.hs view
@@ -39,9 +39,9 @@ import qualified Build.SysConfig import qualified Utility.Url as Url import qualified Annex.Url as Url+import Utility.Tuple  import qualified Data.Map as M-import Data.Tuple.Utils  {- Upgrade without interaction in the webapp. -} unattendedUpgrade :: Assistant ()
Backend/Utilities.hs view
@@ -7,10 +7,9 @@  module Backend.Utilities where -import Data.Hash.MD5- import Annex.Common import Utility.FileSystemEncoding+import Utility.Hash  {- 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.@@ -20,7 +19,8 @@ genKeyName s 	-- Avoid making keys longer than the length of a SHA256 checksum. 	| bytelen > sha256len =-		truncateFilePath (sha256len - md5len - 1) s' ++ "-" ++ md5s (Str s)+		truncateFilePath (sha256len - md5len - 1) s' ++ "-" ++ +			show (md5 (encodeBS s)) 	| otherwise = s'   where 	s' = preSanitizeKeyName s
Build/EvilLinker.hs view
@@ -10,7 +10,6 @@  module Main where -import Data.List.Utils import Text.Parsec import Text.Parsec.String import Control.Applicative ((<$>))@@ -23,6 +22,7 @@ import qualified Utility.Process import Utility.Env import Utility.Directory+import Utility.Split  data CmdParams = CmdParams 	{ cmd :: String
Build/EvilSplicer.hs view
@@ -35,7 +35,6 @@ import Control.Applicative ((<$>)) import Data.Either import Data.List hiding (find)-import Data.String.Utils import Data.Char import System.Environment import System.FilePath@@ -49,6 +48,7 @@ import Utility.Path import Utility.FileSystemEncoding import Utility.Directory+import Utility.Split  data Coord = Coord 	{ coordLine :: Int
CHANGELOG view
@@ -1,3 +1,18 @@+git-annex (6.20170519) unstable; urgency=medium++  * Ssh password prompting improved when using -J for concurrency.+    When ssh connection caching is enabled (and when GIT_ANNEX_USE_GIT_SSH+    is not set), only one ssh password prompt will be made per host, and+    only one ssh password prompt will be made at a time.+  * When built with concurrent-output 1.9, ssh password prompts will no+    longer interfere with the -J display.+  * Removed dependency on MissingH, instead depending on the split library.+  * Progress is displayed for transfers of files of unknown size.+  * Work around bug in git 2.13.0 involving GIT_COMMON_DIR that broke+    merging changes into adjusted branches.++ -- Joey Hess <id@joeyh.name>  Fri, 19 May 2017 10:37:57 -0400+ git-annex (6.20170510) unstable; urgency=medium    * When a http remote does not expose an annex.uuid config, only warn
Command/List.hs view
@@ -11,7 +11,6 @@ import qualified Data.Set as S import qualified Data.Map as M import Data.Function-import Data.Tuple.Utils import Data.Ord  import Command@@ -20,6 +19,7 @@ import Logs.UUID import Annex.UUID import Git.Types (RemoteName)+import Utility.Tuple  cmd :: Command cmd = noCommit $ withGlobalOptions annexedMatchingOptions $
Command/P2P.hs view
@@ -98,9 +98,9 @@ linkRemote :: RemoteName -> CommandStart linkRemote remotename = do 	showStart "p2p link" remotename-	next $ next prompt+	next $ next promptaddr   where-	prompt = do+	promptaddr = do 		liftIO $ putStrLn "" 		liftIO $ putStr "Enter peer address: " 		liftIO $ hFlush stdout@@ -112,7 +112,7 @@ 			else case unformatP2PAddress s of 				Nothing -> do 					liftIO $ hPutStrLn stderr "Unable to parse that address, please check its format and try again."-					prompt+					promptaddr 				Just addr -> do 					r <- setupLink remotename addr 					case r of
Command/Sync.hs view
@@ -417,7 +417,7 @@ 	-- Do updateInstead emulation for remotes on eg removable drives 	-- formatted FAT, where the post-update hook won't run. 	postpushupdate-		| maybe False annexCrippledFileSystem (remoteGitConfig (Remote.gitconfig remote)) = +		| annexCrippledFileSystem (remoteGitConfig (Remote.gitconfig remote)) =  			case Git.repoWorkTree (Remote.repo remote) of 				Nothing -> return True 				Just wt -> ifM (Remote.Git.onLocal remote needUpdateInsteadEmulation)
Command/Uninit.hs view
@@ -18,9 +18,6 @@ import Annex.Init import Utility.FileMode -import System.IO.HVFS-import System.IO.HVFS.Utils- cmd :: Command cmd = addCheck check $  	command "uninit" SectionUtility@@ -101,7 +98,8 @@  prepareRemoveAnnexDir' :: FilePath -> IO () prepareRemoveAnnexDir' annexdir =-	recurseDir SystemFS annexdir >>= mapM_ (void . tryIO . allowWrite)+	dirTreeRecursiveSkipping (const False) annexdir +		>>= mapM_ (void . tryIO . allowWrite)  {- Keys that were moved out of the annex have a hard link still in the  - annex, with > 1 link count, and those can be removed.
Common.hs view
@@ -9,7 +9,6 @@  import Data.Maybe as X import Data.List as X hiding (head, tail, init, last)-import Data.String.Utils as X hiding (join) import Data.Monoid as X import Data.Default as X @@ -32,5 +31,6 @@ import Utility.PosixFiles as X hiding (fileSize) import Utility.FileSize as X import Utility.Network as X+import Utility.Split as X  import Utility.PartialPrelude as X
Git/CatFile.hs view
@@ -26,7 +26,6 @@ import qualified Data.Map as M import Data.String import Data.Char-import Data.Tuple.Utils import Numeric import System.Posix.Types @@ -38,6 +37,7 @@ import Git.FilePath import qualified Utility.CoProcess as CoProcess import Utility.FileSystemEncoding+import Utility.Tuple  data CatFileHandle = CatFileHandle  	{ catFileProcess :: CoProcess.CoProcessHandle
Git/Construct.hs view
@@ -94,7 +94,7 @@  fromUrlStrict :: String -> IO Repo fromUrlStrict url-	| startswith "file://" url = fromAbsPath $ unEscapeString $ uriPath u+	| "file://" `isPrefixOf` url = fromAbsPath $ unEscapeString $ uriPath u 	| otherwise = pure $ newFrom $ Url u   where 	u = fromMaybe bad $ parseURI url@@ -128,7 +128,7 @@ 	filterconfig f = filter f $ M.toList $ config repo 	filterkeys f = filterconfig (\(k,_) -> f k) 	remotepairs = filterkeys isremote-	isremote k = startswith "remote." k && endswith ".url" k+	isremote k = "remote." `isPrefixOf` k && ".url" `isSuffixOf` k 	construct (k,v) = remoteNamedFromKey k $ fromRemoteLocation v repo  {- Sets the name of a remote when constructing the Repo to represent it. -}
Git/Remote.hs view
@@ -74,9 +74,9 @@ 		(bestkey, bestvalue) = maximumBy longestvalue insteadofs 		longestvalue (_, a) (_, b) = compare b a 		insteadofs = filterconfig $ \(k, v) -> -			startswith prefix k &&-			endswith suffix k &&-			startswith v l+			prefix `isPrefixOf` k &&+			suffix `isSuffixOf` k &&+			v `isPrefixOf` l 		filterconfig f = filter f $ 			concatMap splitconfigs $ M.toList $ fullconfig repo 		splitconfigs (k, vs) = map (\v -> (k, v)) vs
Git/Repair.hs view
@@ -39,10 +39,10 @@ import Utility.Tmp import Utility.Rsync import Utility.FileMode+import Utility.Tuple  import qualified Data.Set as S import qualified Data.ByteString.Lazy as L-import Data.Tuple.Utils  {- Given a set of bad objects found by git fsck, which may not  - be complete, finds and removes all corrupt objects. -}
Messages.hs view
@@ -1,6 +1,6 @@ {- git-annex output messages  -- - Copyright 2010-2016 Joey Hess <id@joeyh.name>+ - Copyright 2010-2017 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -41,18 +41,22 @@ 	outputMessage, 	implicitMessage, 	withMessageState,+	prompt, ) where  import System.Log.Logger import System.Log.Formatter import System.Log.Handler (setFormatter) import System.Log.Handler.Simple+import Control.Concurrent  import Common import Types import Types.Messages import Types.ActionItem+import Types.Concurrency import Messages.Internal+import Messages.Concurrent import qualified Messages.JSON as JSON import qualified Annex @@ -219,3 +223,18 @@  - output. -} implicitMessage :: Annex () -> Annex () implicitMessage = whenM (implicitMessages <$> Annex.getState Annex.output)++{- Prevents any concurrent console access while running an action, so+ - that the action is the only thing using the console, and can eg prompt+ - the user.+ -}+prompt :: Annex a -> Annex a+prompt a = go =<< Annex.getState Annex.concurrency+  where+	go NonConcurrent = a+	go (Concurrent {}) = withMessageState $ \s -> do+		let l = promptLock s+		bracketIO+			(takeMVar l)+			(putMVar l)+			(const $ hideRegionsWhile a)
Messages/Concurrent.hs view
@@ -1,6 +1,6 @@ {- git-annex output messages, including concurrent output to display regions  -- - Copyright 2010-2016 Joey Hess <id@joeyh.name>+ - Copyright 2010-2017 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -10,8 +10,9 @@  module Messages.Concurrent where -import Annex+import Types import Types.Messages+import qualified Annex  #ifdef WITH_CONCURRENTOUTPUT import Common@@ -135,4 +136,26 @@ #endif #else concurrentOutputSupported = return False+#endif++{- Hide any currently displayed console regions while running the action,+ - so that the action can use the console itself.+ - This needs a new enough version of concurrent-output; otherwise+ - the regions will not be hidden, but the action still runs, garbling the+ - display. -}+hideRegionsWhile :: Annex a -> Annex a+#ifdef WITH_CONCURRENTOUTPUT+#if MIN_VERSION_concurrent_output(1,9,0)+hideRegionsWhile a = bracketIO setup cleanup go+  where+	setup = Regions.waitDisplayChange $ swapTMVar Regions.regionList []+	cleanup = void . atomically . swapTMVar Regions.regionList+	go _ = do+		liftIO $ hFlush stdout+		a+#else+hideRegionsWhile = id+#endif+#else+hideRegionsWhile = id #endif
Messages/Internal.hs view
@@ -13,7 +13,6 @@ import Messages.Concurrent import Messages.JSON - withMessageState :: (MessageState -> Annex a) -> Annex a withMessageState a = Annex.getState Annex.output >>= a
Messages/Progress.hs view
@@ -23,34 +23,28 @@ import qualified System.Console.Concurrent as Console #endif -import Data.Progress.Meter-import Data.Progress.Tracker-import Data.Quantity- {- Shows a progress meter while performing a transfer of a key.  - The action is passed a callback to use to update the meter. -} metered :: Maybe MeterUpdate -> Key -> (MeterUpdate -> Annex a) -> Annex a metered othermeter key a = withMessageState $ go (keySize key)   where 	go _ (MessageState { outputType = QuietOutput }) = nometer-	go Nothing (MessageState { outputType = NormalOutput }) = nometer-	go (Just size) (MessageState { outputType = NormalOutput, concurrentOutputEnabled = False }) = do+	go (msize) (MessageState { outputType = NormalOutput, concurrentOutputEnabled = False }) = do 		showOutput-		(progress, meter) <- mkmeter size-		m <- liftIO $ rateLimitMeterUpdate 0.1 (Just size) $ \n -> do-			setP progress $ fromBytesProcessed n-			displayMeter stdout meter+		meter <- liftIO $ mkMeter msize bandwidthMeter $ +			displayMeterHandle stdout+		m <- liftIO $ rateLimitMeterUpdate 0.1 msize $+			updateMeter meter 		r <- a (combinemeter m)-		liftIO $ clearMeter stdout meter+		liftIO $ clearMeterHandle meter stdout 		return r-	go (Just size) (MessageState { outputType = NormalOutput, concurrentOutputEnabled = True }) =+	go (msize) (MessageState { outputType = NormalOutput, concurrentOutputEnabled = True }) = #if WITH_CONCURRENTOUTPUT 		withProgressRegion $ \r -> do-			(progress, meter) <- mkmeter size-			m <- liftIO $ rateLimitMeterUpdate 0.1 (Just size) $ \n -> do-				setP progress $ fromBytesProcessed n-				s <- renderMeter meter-				Regions.setConsoleRegion r ("\n" ++ s)+			meter <- liftIO $ mkMeter msize bandwidthMeter $ \_ s ->+				Regions.setConsoleRegion r ('\n' : s)+			m <- liftIO $ rateLimitMeterUpdate 0.1 msize $+				updateMeter meter 			a (combinemeter m) #else 		nometer@@ -61,11 +55,6 @@ 		m <- liftIO $ rateLimitMeterUpdate 0.1 msize $ 			JSON.progress buf msize 		a (combinemeter m)--	mkmeter size = do-		progress <- liftIO $ newProgress "" size-		meter <- liftIO $ newMeter progress "B" 25 (renderNums binaryOpts 1)-		return (progress, meter)  	nometer = a $ combinemeter (const noop)
Remote/GCrypt.hs view
@@ -119,7 +119,7 @@ 		, config = c 		, localpath = localpathCalc r 		, repo = r-		, gitconfig = gc { remoteGitConfig = Just $ extractGitConfig r }+		, gitconfig = gc { remoteGitConfig = extractGitConfig r } 		, readonly = Git.repoIsHttp r 		, availability = availabilityCalc r 		, remotetype = remote
Remote/Git.hs view
@@ -165,8 +165,7 @@ 			, config = c 			, localpath = localpathCalc r 			, repo = r-			, gitconfig = gc-				{ remoteGitConfig = Just $ extractGitConfig r }+			, gitconfig = gc { remoteGitConfig = extractGitConfig r } 			, readonly = Git.repoIsHttp r 			, availability = availabilityCalc r 			, remotetype = remote@@ -351,7 +350,7 @@ 	locs' = map (replace "\\" "/") locs #endif 	remoteconfig = gitconfig r-	cfg = fromJust $ remoteGitConfig remoteconfig+	cfg = remoteGitConfig remoteconfig  dropKey :: Remote -> Key -> Annex Bool dropKey r key@@ -520,7 +519,7 @@ copyFromRemoteCheap r key af file 	| not $ Git.repoIsUrl (repo r) = guardUsable (repo r) (return False) $ liftIO $ do 		loc <- gitAnnexLocation key (repo r) $-			fromJust $ remoteGitConfig $ gitconfig r+			remoteGitConfig $ gitconfig r 		ifM (doesFileExist loc) 			( do 				absloc <- absPath loc
Remote/Helper/Encryptable.hs view
@@ -21,13 +21,13 @@ import qualified Data.Map as M import qualified "sandi" Codec.Binary.Base64 as B64 import qualified Data.ByteString as B-import Data.Bits.Utils  import Annex.Common import Types.Remote 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/Special.hs view
@@ -62,7 +62,7 @@   where 	remotepairs = M.toList . M.filterWithKey match 	construct (k,_) = Git.Construct.remoteNamedFromKey k (pure Git.Construct.fromUnknown)-	match k _ = startswith "remote." k && endswith (".annex-"++s) k+	match k _ = "remote." `isPrefixOf` k && (".annex-"++s) `isSuffixOf` k  {- Sets up configuration for a special remote in .git/config. -} gitConfigSpecialRemote :: UUID -> RemoteConfig -> String -> String -> Annex ()
Remote/P2P.hs view
@@ -63,7 +63,7 @@ 		, config = c 		, localpath = Nothing 		, repo = r-		, gitconfig = gc { remoteGitConfig = Just $ extractGitConfig r }+		, gitconfig = gc { remoteGitConfig = extractGitConfig r } 		, readonly = False 		, availability = GloballyAvailable 		, remotetype = remote
Remote/Rsync/RsyncUrl.hs view
@@ -17,7 +17,7 @@ import Data.Default import System.FilePath.Posix #ifdef mingw32_HOST_OS-import Data.String.Utils+import Utility.Split #endif import Annex.DirHashes
Remote/S3.hs view
@@ -29,7 +29,6 @@ import Control.Monad.Catch import Data.Conduit import Data.IORef-import Data.Bits.Utils import System.Log.Logger  import Annex.Common@@ -46,6 +45,7 @@ import Logs.Web import Utility.Metered import Utility.DataUnits+import Utility.FileSystemEncoding import Annex.Content import Annex.Url (withUrlOptions) import Utility.Url (checkBoth, managerSettings, closeManager)
Remote/WebDAV/DavLocation.hs view
@@ -13,14 +13,14 @@ import Types import Annex.Locations import Utility.Url (URLString)+#ifdef mingw32_HOST_OS+import Utility.Split+#endif  import System.FilePath.Posix -- for manipulating url paths import Network.Protocol.HTTP.DAV (inDAVLocation, DAVT) import Control.Monad.IO.Class (MonadIO) import Data.Default-#ifdef mingw32_HOST_OS-import Data.String.Utils-#endif  -- Relative to the top of the DAV url. type DavLocation = String
Types/Distribution.hs view
@@ -8,12 +8,12 @@ module Types.Distribution where  import Utility.PartialPrelude+import Utility.Split import Types.Key import Key import Data.Time.Clock import Git.Config (isTrue, boolConfig) -import Data.String.Utils import Control.Applicative import Prelude
Types/GitConfig.hs view
@@ -88,6 +88,7 @@ 	, receiveDenyCurrentBranch :: DenyCurrentBranch 	, gcryptId :: Maybe String 	, gpgCmd :: GpgCmd+	, gitConfigRepo :: Git.Repo 	}  extractGitConfig :: Git.Repo -> GitConfig@@ -148,6 +149,7 @@ 	, receiveDenyCurrentBranch = getDenyCurrentBranch r 	, gcryptId = getmaybe "core.gcrypt-id" 	, gpgCmd = mkGpgCmd (getmaybe "gpg.program")+	, gitConfigRepo = r 	}   where 	getbool k d = fromMaybe d $ getmaybebool k@@ -216,7 +218,7 @@ 	, remoteAnnexHookType :: Maybe String 	, remoteAnnexExternalType :: Maybe String 	{- A regular git remote's git repository config. -}-	, remoteGitConfig :: Maybe GitConfig+	, remoteGitConfig :: GitConfig 	}  extractRemoteGitConfig :: Git.Repo -> String -> RemoteGitConfig@@ -252,7 +254,7 @@ 	, remoteAnnexDdarRepo = getmaybe "ddarrepo" 	, remoteAnnexHookType = notempty $ getmaybe "hooktype" 	, remoteAnnexExternalType = notempty $ getmaybe "externaltype"-	, remoteGitConfig = Nothing+	, remoteGitConfig = extractGitConfig r 	}   where 	getbool k d = fromMaybe d $ getmaybebool k
Types/Messages.hs view
@@ -1,6 +1,6 @@ {- git-annex Messages data types  - - - Copyright 2012 Joey Hess <id@joeyh.name>+ - Copyright 2012-2017 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -9,9 +9,9 @@  module Types.Messages where -import Data.Default import qualified Data.Aeson as Aeson +import Control.Concurrent #ifdef WITH_CONCURRENTOUTPUT import System.Console.Regions (ConsoleRegion) #endif@@ -32,11 +32,13 @@ 	, consoleRegionErrFlag :: Bool #endif 	, jsonBuffer :: Maybe Aeson.Object+	, promptLock :: MVar () -- left full when not prompting 	} -instance Default MessageState-  where-	def = MessageState+newMessageState :: IO MessageState+newMessageState = do+	promptlock <- newMVar ()+	return $ MessageState 		{ outputType = NormalOutput 		, concurrentOutputEnabled = False 		, sideActionBlock = NoBlock@@ -46,4 +48,5 @@ 		, consoleRegionErrFlag = False #endif 		, jsonBuffer = Nothing+		, promptLock = promptlock 		}
Utility/DataUnits.hs view
@@ -45,6 +45,7 @@ 	ByteSize,  	roughSize,+	roughSize', 	compareSizes, 	readSize ) where@@ -109,7 +110,10 @@  {- approximate display of a particular number of bytes -} roughSize :: [Unit] -> Bool -> ByteSize -> String-roughSize units short i+roughSize units short i = roughSize' units short 2 i++roughSize' :: [Unit] -> Bool -> Int -> ByteSize -> String+roughSize' units short precision i 	| i < 0 = '-' : findUnit units' (negate i) 	| otherwise = findUnit units' i   where@@ -123,7 +127,7 @@ 	showUnit x (Unit size abbrev name) = s ++ " " ++ unit 	  where 		v = (fromInteger x :: Double) / fromInteger size-		s = showImprecise 2 v+		s = showImprecise precision v 		unit 			| short = abbrev 			| s == "1" = name
Utility/Directory.hs view
@@ -96,10 +96,10 @@ 	go c (dir:dirs) 		| skipdir (takeFileName dir) = go c dirs 		| otherwise = unsafeInterleaveIO $ do-			subdirs <- go c+			subdirs <- go [] 				=<< filterM (isDirectory <$$> getSymbolicLinkStatus) 				=<< catchDefaultIO [] (dirContents dir)-			go (subdirs++[dir]) dirs+			go (subdirs++dir:c) dirs  {- Moves one filename to another.  - First tries a rename, but falls back to moving across devices if needed. -}
Utility/FileSystemEncoding.hs view
@@ -12,7 +12,6 @@ 	useFileSystemEncoding, 	fileEncoding, 	withFilePath,-	md5FilePath, 	decodeBS, 	encodeBS, 	decodeW8,@@ -20,6 +19,10 @@ 	encodeW8NUL, 	decodeW8NUL, 	truncateFilePath,+	s2w8,+	w82s,+	c2w8,+	w82c, ) where  import qualified GHC.Foreign as GHC@@ -27,17 +30,15 @@ import Foreign.C import System.IO import System.IO.Unsafe-import qualified Data.Hash.MD5 as MD5 import Data.Word-import Data.Bits.Utils import Data.List-import Data.List.Utils import qualified Data.ByteString.Lazy as L #ifdef mingw32_HOST_OS import qualified Data.ByteString.Lazy.UTF8 as L8 #endif  import Utility.Exception+import Utility.Split  {- Makes all subsequent Handles that are opened, as well as stdio Handles,  - use the filesystem encoding, instead of the encoding of the current@@ -101,10 +102,6 @@ 	GHC.withCString enc fp (GHC.peekCString Encoding.char8) 		`catchNonAsync` (\_ -> return fp) -{- Encodes a FilePath into a Md5.Str, applying the filesystem encoding. -}-md5FilePath :: FilePath -> MD5.Str-md5FilePath = MD5.Str . _encodeFilePath- {- Decodes a ByteString into a FilePath, applying the filesystem encoding. -} decodeBS :: L.ByteString -> FilePath #ifndef mingw32_HOST_OS@@ -145,14 +142,26 @@  {- Like encodeW8 and decodeW8, but NULs are passed through unchanged. -} encodeW8NUL :: [Word8] -> FilePath-encodeW8NUL = intercalate nul . map encodeW8 . split (s2w8 nul)+encodeW8NUL = intercalate [nul] . map encodeW8 . splitc (c2w8 nul)   where-	nul = ['\NUL']+	nul = '\NUL'  decodeW8NUL :: FilePath -> [Word8]-decodeW8NUL = intercalate (s2w8 nul) . map decodeW8 . split nul+decodeW8NUL = intercalate [c2w8 nul] . map decodeW8 . splitc nul   where-	nul = ['\NUL']+	nul = '\NUL'++c2w8 :: Char -> Word8+c2w8 = fromIntegral . fromEnum++w82c :: Word8 -> Char+w82c = toEnum . fromIntegral++s2w8 :: String -> [Word8]+s2w8 = map c2w8++w82s :: [Word8] -> String+w82s = map w82c  {- Truncates a FilePath to the given number of bytes (or less),  - as represented on disk.
Utility/Glob.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE PackageImports #-}+ {- file globbing  -  - Copyright 2014 Joey Hess <id@joeyh.name>@@ -14,10 +16,9 @@  import Utility.Exception -import System.Path.WildMatch- import "regex-tdfa" Text.Regex.TDFA import "regex-tdfa" Text.Regex.TDFA.String+import Data.Char  newtype Glob = Glob Regex @@ -30,10 +31,30 @@ 		Right r -> r 		Left _ -> giveup $ "failed to compile regex: " ++ regex   where-	regex = '^':wildToRegex glob+	regex = '^' : wildToRegex glob ++ "$" 	casesentitive = case globcase of 		CaseSensative -> True 		CaseInsensative -> False++wildToRegex :: String -> String+wildToRegex = concat . go+  where+	go [] = []+	go ('*':xs) = ".*" : go xs+	go ('?':xs) = "." : go xs+	go ('[':'!':xs) = "[^" : inpat xs+	go ('[':xs) = "[" : inpat xs+	go (x:xs)+		| isDigit x || isAlpha x = [x] : go xs+		| otherwise = esc x : go xs++	inpat [] = []+	inpat (x:xs) = case x of+		']' -> "]" : go xs+		'\\' -> esc x : inpat xs+		_ -> [x] : inpat xs++	esc c = ['\\', c]  matchGlob :: Glob -> String -> Bool matchGlob (Glob regex) val =
Utility/Gpg.hs view
@@ -14,11 +14,9 @@ #ifndef mingw32_HOST_OS import System.Posix.Types import qualified System.Posix.IO-import System.Path import Utility.Env-#else-import Utility.Tmp #endif+import Utility.Tmp import Utility.Format (decode_c)  import Control.Concurrent@@ -336,23 +334,21 @@ {- 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 = do-	orig <- getEnv var-	bracket setup (cleanup orig) (const a)+testHarness cmd a = withTmpDir "gpgtmpXXXXXX" $ \tmpdir ->+	bracket (setup tmpdir) (cleanup tmpdir) (const a)   where 	var = "GNUPGHOME"		 -	setup = do-		base <- getTemporaryDirectory-		dir <- mktmpdir $ base </> "gpgtmpXXXXXX"-		setEnv var dir True+	setup tmpdir = do+		orig <- getEnv var+		setEnv var tmpdir 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 dir+		return orig 		-	cleanup orig tmpdir = do+	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
Utility/Hash.hs view
@@ -1,8 +1,4 @@-{- Convenience wrapper around cryptohash/cryptonite.- -- - SHA3 hashes are currently only enabled when using cryptonite,- - because of https://github.com/vincenthz/hs-cryptohash/issues/36- -}+{- Convenience wrapper around cryptonite's hashing. -}  module Utility.Hash ( 	sha1,
Utility/LinuxMkLibs.hs view
@@ -12,10 +12,10 @@ import Utility.Process import Utility.Monad import Utility.Path+import Utility.Split  import Data.Maybe import System.FilePath-import Data.List.Utils import System.Posix.Files import Data.Char import Control.Monad.IfElse
Utility/LockFile/PidLock.hs view
@@ -25,6 +25,8 @@ import Utility.FileMode import Utility.LockFile.LockStatus import Utility.ThreadScheduler+import Utility.Hash+import Utility.FileSystemEncoding import qualified Utility.LockFile.Posix as Posix  import System.IO@@ -33,7 +35,6 @@ import Data.List import Network.BSD import System.FilePath-import Data.Hash.MD5 import Control.Applicative import Prelude @@ -99,7 +100,9 @@ 	f <- absPath lockfile 	let base = intercalate "_" (splitDirectories (makeRelative "/" f)) 	let shortbase = reverse $ take 32 $ reverse base-	let md5sum = if base == shortbase then "" else md5s (Str base)+	let md5sum = if base == shortbase+		then ""+		else show (md5 (encodeBS base)) 	dir <- ifM (doesDirectoryExist "/dev/shm") 		( return "/dev/shm" 		, return "/tmp"
Utility/Metered.hs view
@@ -10,6 +10,10 @@ module Utility.Metered where  import Common+import Utility.FileSystemEncoding+import Utility.Percentage+import Utility.DataUnits+import Utility.HumanTime  import qualified Data.ByteString.Lazy as L import qualified Data.ByteString as S@@ -17,7 +21,6 @@ import Foreign.Storable (Storable(sizeOf)) import System.Posix.Types import Data.Int-import Data.Bits.Utils import Control.Concurrent import Control.Concurrent.Async import Control.Monad.IO.Class (MonadIO)@@ -216,7 +219,7 @@ 				unless (quietMode oh) $ do 					S.hPut stdout b 					hFlush stdout-				let s = w82s (S.unpack b)+				let s = encodeW8 (S.unpack b) 				let (mbytes, buf') = progressparser (buf++s) 				case mbytes of 					Nothing -> feedprogress prev buf' h@@ -297,3 +300,77 @@ 					putMVar lastupdate now 					meterupdate n 				else putMVar lastupdate prev++data Meter = Meter (Maybe Integer) (MVar MeterState) (MVar String) RenderMeter DisplayMeter++type MeterState = (BytesProcessed, POSIXTime)++type DisplayMeter = MVar String -> String -> IO ()++type RenderMeter = Maybe Integer -> (BytesProcessed, POSIXTime) -> (BytesProcessed, POSIXTime) -> String++-- | Make a meter. Pass the total size, if it's known.+mkMeter :: Maybe Integer -> RenderMeter -> DisplayMeter -> IO Meter+mkMeter totalsize rendermeter displaymeter = Meter+	<$> pure totalsize+	<*> ((\t -> newMVar (zeroBytesProcessed, t)) =<< getPOSIXTime)+	<*> newMVar ""+	<*> pure rendermeter+	<*> pure displaymeter++-- | Updates the meter, displaying it if necessary.+updateMeter :: Meter -> BytesProcessed -> IO ()+updateMeter (Meter totalsize sv bv rendermeter displaymeter) new = do+	now <- getPOSIXTime+	(old, before) <- swapMVar sv (new, now)+	when (old /= new) $+		displaymeter bv $ +			rendermeter totalsize (old, before) (new, now)++-- | Display meter to a Handle.+displayMeterHandle :: Handle -> DisplayMeter+displayMeterHandle h v s = do+	olds <- swapMVar v s+	-- Avoid writing when the rendered meter has not changed.+	when (olds /= s) $ do+		let padding = replicate (length olds - length s) ' '+		hPutStr h ('\r':s ++ padding)+		hFlush h++-- | Clear meter displayed by displayMeterHandle.+clearMeterHandle :: Meter -> Handle -> IO ()+clearMeterHandle (Meter _ _ v _ _) h = do+	olds <- readMVar v+	hPutStr h $ '\r' : replicate (length olds) ' ' ++ "\r"+	hFlush h++-- | Display meter in the form:+--   10%         300 KiB/s 16m40s+-- or when total size is not known:+--   1.3 MiB     300 KiB/s+bandwidthMeter :: RenderMeter+bandwidthMeter mtotalsize (BytesProcessed old, before) (BytesProcessed new, now) =+	unwords $ catMaybes+		[ Just percentoramount+		-- Pad enough for max width: "xxxx.xx KiB  xxxx KiB/s"+		, Just $ replicate (23 - length percentoramount - length rate) ' '+		, Just rate+		, estimatedcompletion+		]+  where+	percentoramount = case mtotalsize of+		Just totalsize -> showPercentage 0 $+			percentage totalsize (min new totalsize)+		Nothing -> roughSize' memoryUnits True 2 new+	rate = roughSize' memoryUnits True 0 bytespersecond ++ "/s"+	bytespersecond+		| duration == 0 = fromIntegral transferred+		| otherwise = floor $ fromIntegral transferred / duration+	transferred = max 0 (new - old)+	duration = max 0 (now - before)+	estimatedcompletion = case mtotalsize of+		Just totalsize+			| bytespersecond > 0 -> +				Just $ fromDuration $ Duration $+					totalsize `div` bytespersecond+		_ -> Nothing
Utility/Misc.hs view
@@ -45,14 +45,6 @@ 		| null b = r 		| otherwise = (a, tail b) -{- Split on a single character. This is over twice as fast as using- - Data.List.Utils.split on a list of length 1, while producing- - identical results. -}-splitc :: Char -> String -> [String]-splitc c s = case break (== c) s of-	(i, _c:rest) -> i : splitc c rest-	(i, []) -> i : []- {- Breaks out the first line. -} firstLine :: String -> String firstLine = takeWhile (/= '\n')
Utility/Path.hs view
@@ -10,7 +10,6 @@  module Utility.Path where -import Data.String.Utils import System.FilePath import Data.List import Data.Maybe@@ -25,10 +24,10 @@ import Utility.Exception #endif -import qualified "MissingH" System.Path as MissingH import Utility.Monad import Utility.UserInfo import Utility.Directory+import Utility.Split  {- Simplifies a path, removing any "." component, collapsing "dir/..",   - and removing the trailing path separator.@@ -68,18 +67,6 @@ absPathFrom :: FilePath -> FilePath -> FilePath absPathFrom dir path = simplifyPath (combine dir path) -{- On Windows, this converts the paths to unix-style, in order to run- - MissingH's absNormPath on them. -}-absNormPathUnix :: FilePath -> FilePath -> Maybe FilePath-#ifndef mingw32_HOST_OS-absNormPathUnix dir path = MissingH.absNormPath dir path-#else-absNormPathUnix dir path = todos <$> MissingH.absNormPath (fromdos dir) (fromdos path)-  where-	fromdos = replace "\\" "/"-	todos = replace "/" "\\"-#endif- {- takeDirectory "foo/bar/" is "foo/bar". This instead yields "foo" -} parentDir :: FilePath -> FilePath parentDir = takeDirectory . dropTrailingPathSeparator@@ -89,12 +76,13 @@ upFrom :: FilePath -> Maybe FilePath upFrom dir 	| length dirs < 2 = Nothing-	| otherwise = Just $ joinDrive drive (intercalate s $ init dirs)+	| otherwise = Just $ joinDrive drive $ intercalate s $ init dirs   where-	-- on Unix, the drive will be "/" when the dir is absolute, otherwise ""+	-- on Unix, the drive will be "/" when the dir is absolute,+	-- otherwise "" 	(drive, path) = splitDrive dir-	dirs = filter (not . null) $ split s path 	s = [pathSeparator]+	dirs = filter (not . null) $ split s path  prop_upFrom_basics :: FilePath -> Bool prop_upFrom_basics dir@@ -149,11 +137,11 @@ relPathDirToFileAbs :: FilePath -> FilePath -> FilePath relPathDirToFileAbs from to 	| takeDrive from /= takeDrive to = to-	| otherwise = intercalate s $ dotdots ++ uncommon+	| otherwise = joinPath $ dotdots ++ uncommon   where-	s = [pathSeparator]-	pfrom = split s from-	pto = split s to+	pfrom = sp from+	pto = sp to+	sp = map dropTrailingPathSeparator . splitPath 	common = map fst $ takeWhile same $ zip pfrom pto 	same (c,d) = c == d 	uncommon = drop numcommon pto
Utility/Rsync.hs view
@@ -11,10 +11,10 @@  import Common import Utility.Metered+import Utility.Tuple  import Data.Char import System.Console.GetOpt-import Data.Tuple.Utils  {- Generates parameters to make rsync use a specified command as its remote  - shell. -}
Utility/SafeCommand.hs view
@@ -11,7 +11,7 @@  import System.Exit import Utility.Process-import Utility.Misc+import Utility.Split import System.FilePath import Data.Char import Data.List
Utility/Scheduled.hs view
@@ -29,6 +29,7 @@ import Utility.Data import Utility.PartialPrelude import Utility.Misc+import Utility.Tuple  import Data.List import Data.Time.Clock@@ -37,7 +38,6 @@ import Data.Time.Calendar.WeekDate import Data.Time.Calendar.OrdinalDate import Data.Time.Format ()-import Data.Tuple.Utils import Data.Char import Control.Applicative import Prelude
+ Utility/Split.hs view
@@ -0,0 +1,30 @@+{- split utility functions+ -+ - Copyright 2017 Joey Hess <id@joeyh.name>+ -+ - License: BSD-2-clause+ -}++{-# OPTIONS_GHC -fno-warn-tabs #-}++module Utility.Split where++import Data.List (intercalate)+import Data.List.Split (splitOn)++-- | same as Data.List.Utils.split+--+-- intercalate x . splitOn x === id+split :: Eq a => [a] -> [a] -> [[a]]+split = splitOn++-- | Split on a single character. This is over twice as fast as using+-- split on a list of length 1, while producing identical results. -}+splitc :: Eq c => c -> [c] -> [[c]]+splitc c s = case break (== c) s of+	(i, _c:rest) -> i : splitc c rest+	(i, []) -> i : []++-- | same as Data.List.Utils.replace+replace :: Eq a => [a] -> [a] -> [a] -> [a] +replace old new = intercalate new . split old
+ Utility/Tuple.hs view
@@ -0,0 +1,17 @@+{- tuple utility functions+ -+ - Copyright 2017 Joey Hess <id@joeyh.name>+ -+ - License: BSD-2-clause+ -}++module Utility.Tuple where++fst3 :: (a,b,c) -> a+fst3 (a,_,_) = a++snd3 :: (a,b,c) -> b+snd3 (_,b,_) = b++thd3 :: (a,b,c) -> c+thd3 (_,_,c) = c
doc/git-annex-adjust.mdwn view
@@ -4,7 +4,7 @@  # SYNOPSIS -git annex adjust --unlock|--fix`+`git annex adjust --unlock|--fix`  # DESCRIPTION
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 6.20170510+Version: 6.20170519 Cabal-Version: >= 1.8 License: GPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -304,7 +304,7 @@   location: git://git-annex.branchable.com/  custom-setup-  Setup-Depends: base (>= 4.5), hslogger, MissingH, unix-compat, process,+  Setup-Depends: base (>= 4.5), hslogger, split, unix-compat, process,     unix, filepath, exceptions, bytestring, directory, IfElse, data-default,     Cabal @@ -330,7 +330,6 @@    directory (>= 1.2),    filepath,    IfElse,-   MissingH,    hslogger,    monad-logger,    free,@@ -361,12 +360,15 @@    stm-chans,    securemem,    crypto-api,-   cryptonite+   cryptonite,+   memory,+   split   CC-Options: -Wall   GHC-Options: -Wall -fno-warn-tabs   Extensions: PackageImports   -- Some things don't work with the non-threaded RTS.   GHC-Options: -threaded+  Other-Extensions: TemplateHaskell    -- Fully optimize for production.   if flag(Production)@@ -1049,6 +1051,7 @@     Utility.Scheduled.QuickCheck     Utility.Shell     Utility.SimpleProtocol+    Utility.Split     Utility.SshConfig     Utility.Su     Utility.SystemDirectory@@ -1059,6 +1062,7 @@     Utility.Tmp     Utility.Tor     Utility.Touch+    Utility.Tuple     Utility.Url     Utility.UserInfo     Utility.Verifiable
stack.yaml view
@@ -23,4 +23,4 @@ - yesod-default-1.2.0 explicit-setup-deps:   git-annex: true-resolver: lts-8.6+resolver: lts-8.13