summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoeyHess <>2017-05-19 14:58:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2017-05-19 14:58:00 (GMT)
commit8f137e1bcce7a7fadf7c52c85a5588aaa0c6785d (patch)
tree15d54a9af939fdf6782df36695ddc053e5575bd2
parent73f1c02d03ecf7f118a69526212c657f7c4faca6 (diff)
version 6.201705196.20170519
-rw-r--r--Annex.hs7
-rw-r--r--Annex/AdjustedBranch.hs14
-rw-r--r--Annex/Branch.hs4
-rw-r--r--Annex/DirHashes.hs24
-rw-r--r--Annex/Locations.hs8
-rw-r--r--Annex/LockFile.hs1
-rw-r--r--Annex/Ssh.hs111
-rw-r--r--Annex/UUID.hs2
-rw-r--r--Annex/VariantFile.hs5
-rw-r--r--Assistant/Threads/Committer.hs2
-rw-r--r--Assistant/Threads/SanityChecker.hs4
-rw-r--r--Assistant/Threads/Watcher.hs2
-rw-r--r--Assistant/Upgrade.hs2
-rw-r--r--Backend/Utilities.hs6
-rw-r--r--Build/EvilLinker.hs2
-rw-r--r--Build/EvilSplicer.hs2
-rw-r--r--CHANGELOG15
-rw-r--r--Command/List.hs2
-rw-r--r--Command/P2P.hs6
-rw-r--r--Command/Sync.hs2
-rw-r--r--Command/Uninit.hs6
-rw-r--r--Common.hs2
-rw-r--r--Git/CatFile.hs2
-rw-r--r--Git/Construct.hs4
-rw-r--r--Git/Remote.hs6
-rw-r--r--Git/Repair.hs2
-rw-r--r--Messages.hs21
-rw-r--r--Messages/Concurrent.hs27
-rw-r--r--Messages/Internal.hs1
-rw-r--r--Messages/Progress.hs33
-rw-r--r--Remote/GCrypt.hs2
-rw-r--r--Remote/Git.hs7
-rw-r--r--Remote/Helper/Encryptable.hs2
-rw-r--r--Remote/Helper/Special.hs2
-rw-r--r--Remote/P2P.hs2
-rw-r--r--Remote/Rsync/RsyncUrl.hs2
-rw-r--r--Remote/S3.hs2
-rw-r--r--Remote/WebDAV/DavLocation.hs6
-rw-r--r--Types/Distribution.hs2
-rw-r--r--Types/GitConfig.hs6
-rw-r--r--Types/Messages.hs13
-rw-r--r--Utility/DataUnits.hs8
-rw-r--r--Utility/Directory.hs4
-rw-r--r--Utility/FileSystemEncoding.hs33
-rw-r--r--Utility/Glob.hs27
-rw-r--r--Utility/Gpg.hs20
-rw-r--r--Utility/Hash.hs6
-rw-r--r--Utility/LinuxMkLibs.hs2
-rw-r--r--Utility/LockFile/PidLock.hs7
-rw-r--r--Utility/Metered.hs81
-rw-r--r--Utility/Misc.hs8
-rw-r--r--Utility/Path.hs30
-rw-r--r--Utility/Rsync.hs2
-rw-r--r--Utility/SafeCommand.hs2
-rw-r--r--Utility/Scheduled.hs2
-rw-r--r--Utility/Split.hs30
-rw-r--r--Utility/Tuple.hs17
-rw-r--r--doc/git-annex-adjust.mdwn2
-rw-r--r--git-annex.cabal12
-rw-r--r--stack.yaml2
60 files changed, 471 insertions, 195 deletions
diff --git a/Annex.hs b/Annex.hs
index 2a372f1..597a5dd 100644
--- a/Annex.hs
+++ b/Annex.hs
@@ -71,6 +71,7 @@ import Utility.Url
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 @@ data AnnexState = AnnexState
, 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 @@ data AnnexState = AnnexState
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 @@ newState c r = do
, backend = Nothing
, remotes = []
, remoteannexstate = M.empty
- , output = def
+ , output = o
, concurrency = NonConcurrent
, force = False
, fast = False
@@ -175,6 +179,7 @@ newState c r = do
, groupmap = Nothing
, ciphers = M.empty
, lockcache = M.empty
+ , sshstalecleaned = sc
, flags = M.empty
, fields = M.empty
, cleanup = M.empty
diff --git a/Annex/AdjustedBranch.hs b/Annex/AdjustedBranch.hs
index 72c07a5..c022554 100644
--- a/Annex/AdjustedBranch.hs
+++ b/Annex/AdjustedBranch.hs
@@ -51,6 +51,7 @@ import Annex.Content
import Annex.Perms
import Annex.GitOverlay
import Utility.Tmp
+import Utility.CopyFile
import qualified Database.Keys
import Config
@@ -355,9 +356,22 @@ updateAdjustedBranch tomerge (origbranch, adj) mergeconfig commitmode = catchBoo
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
diff --git a/Annex/Branch.hs b/Annex/Branch.hs
index af29b02..5482dc4 100644
--- a/Annex/Branch.hs
+++ b/Annex/Branch.hs
@@ -29,8 +29,8 @@ module Annex.Branch (
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 @@ commitIndex' jl branchref message basemessage retrynum parents = do
-- 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"
diff --git a/Annex/DirHashes.hs b/Annex/DirHashes.hs
index 82d751e..f843848 100644
--- a/Annex/DirHashes.hs
+++ b/Annex/DirHashes.hs
@@ -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 @@ module Annex.DirHashes (
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 -> Int -> String -> FilePath
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
-}
diff --git a/Annex/Locations.hs b/Annex/Locations.hs
index 6bc24c4..494badc 100644
--- a/Annex/Locations.hs
+++ b/Annex/Locations.hs
@@ -172,7 +172,7 @@ gitAnnexLocation' key r config crippled symlinkssupported checker gitdir
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 @@ gitAnnexLink file key r config = do
- 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. -}
diff --git a/Annex/LockFile.hs b/Annex/LockFile.hs
index cb1d232..1f35444 100644
--- a/Annex/LockFile.hs
+++ b/Annex/LockFile.hs
@@ -11,6 +11,7 @@ module Annex.LockFile (
lockFileCached,
unlockFile,
getLockCache,
+ fromLockCache,
withExclusiveLock,
tryExclusiveLock,
) where
diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs
index bf13a02..50a5163 100644
--- a/Annex/Ssh.hs
+++ b/Annex/Ssh.hs
@@ -23,10 +23,6 @@ module Annex.Ssh (
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 Config
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.Perms
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 @@ sshCommand cs (host, port) gc remotecmd = ifM (liftIO safe_GIT_SSH)
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,20 +160,73 @@ portParams :: Maybe Integer -> [CommandParam]
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.
-
@@ -242,7 +297,7 @@ hostport2socket host Nothing = hostport2socket' host
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 @@ sshOptionsTo remote gc localr
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
diff --git a/Annex/UUID.hs b/Annex/UUID.hs
index 0e87cda..8a2d884 100644
--- a/Annex/UUID.hs
+++ b/Annex/UUID.hs
@@ -37,7 +37,7 @@ import Config
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"
diff --git a/Annex/VariantFile.hs b/Annex/VariantFile.hs
index 17658a9..8365073 100644
--- a/Annex/VariantFile.hs
+++ b/Annex/VariantFile.hs
@@ -9,8 +9,7 @@ module Annex.VariantFile where
import Annex.Common
import Utility.FileSystemEncoding
-
-import Data.Hash.MD5
+import Utility.Hash
variantMarker :: String
variantMarker = ".variant-"
@@ -42,4 +41,4 @@ variantFile file key
doubleconflict = variantMarker `isInfixOf` file
shortHash :: String -> String
-shortHash = take 4 . md5s . md5FilePath
+shortHash = take 4 . show . md5 . encodeBS
diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs
index d0acb8c..3680349 100644
--- a/Assistant/Threads/Committer.hs
+++ b/Assistant/Threads/Committer.hs
@@ -38,9 +38,9 @@ import Annex.Content.Direct
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
diff --git a/Assistant/Threads/SanityChecker.hs b/Assistant/Threads/SanityChecker.hs
index 8169695..43812e5 100644
--- a/Assistant/Threads/SanityChecker.hs
+++ b/Assistant/Threads/SanityChecker.hs
@@ -257,9 +257,9 @@ checkOldUnused urlrenderer = go =<< annexExpireUnused <$> liftAnnex Annex.getGit
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
diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs
index 90bb3dc..742b8c8 100644
--- a/Assistant/Threads/Watcher.hs
+++ b/Assistant/Threads/Watcher.hs
@@ -44,13 +44,13 @@ import Git.FilePath
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
diff --git a/Assistant/Upgrade.hs b/Assistant/Upgrade.hs
index 67a4d9f..cd1be4d 100644
--- a/Assistant/Upgrade.hs
+++ b/Assistant/Upgrade.hs
@@ -39,9 +39,9 @@ import qualified Utility.Lsof as Lsof
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 ()
diff --git a/Backend/Utilities.hs b/Backend/Utilities.hs
index d1fb94f..1691fa2 100644
--- a/Backend/Utilities.hs
+++ b/Backend/Utilities.hs
@@ -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 :: String -> String
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
diff --git a/Build/EvilLinker.hs b/Build/EvilLinker.hs
index 47111d4..8d3afa9 100644
--- a/Build/EvilLinker.hs
+++ b/Build/EvilLinker.hs
@@ -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 Utility.Process hiding (env)
import qualified Utility.Process
import Utility.Env
import Utility.Directory
+import Utility.Split
data CmdParams = CmdParams
{ cmd :: String
diff --git a/Build/EvilSplicer.hs b/Build/EvilSplicer.hs
index 4e7b1c9..e07034c 100644
--- a/Build/EvilSplicer.hs
+++ b/Build/EvilSplicer.hs
@@ -35,7 +35,6 @@ import Text.Parsec.String
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.Exception hiding (try)
import Utility.Path
import Utility.FileSystemEncoding
import Utility.Directory
+import Utility.Split
data Coord = Coord
{ coordLine :: Int
diff --git a/CHANGELOG b/CHANGELOG
index e6b6d45..bd9cb32 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -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
diff --git a/Command/List.hs b/Command/List.hs
index 2676b5d..05f1282 100644
--- a/Command/List.hs
+++ b/Command/List.hs
@@ -11,7 +11,6 @@ module Command.List where
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.Trust
import Logs.UUID
import Annex.UUID
import Git.Types (RemoteName)
+import Utility.Tuple
cmd :: Command
cmd = noCommit $ withGlobalOptions annexedMatchingOptions $
diff --git a/Command/P2P.hs b/Command/P2P.hs
index 505286a..58b5c3b 100644
--- a/Command/P2P.hs
+++ b/Command/P2P.hs
@@ -98,9 +98,9 @@ genAddresses addrs = do
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 @@ linkRemote remotename = do
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
diff --git a/Command/Sync.hs b/Command/Sync.hs
index 85bb8c1..332daca 100644
--- a/Command/Sync.hs
+++ b/Command/Sync.hs
@@ -417,7 +417,7 @@ pushRemote o remote (Just branch, _) = stopUnless (pure (pushOption o) <&&> need
-- 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)
diff --git a/Command/Uninit.hs b/Command/Uninit.hs
index d8c7d12..af628d7 100644
--- a/Command/Uninit.hs
+++ b/Command/Uninit.hs
@@ -18,9 +18,6 @@ import Annex.Content
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 annexdir = do
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.
diff --git a/Common.hs b/Common.hs
index 2e28117..ba83826 100644
--- a/Common.hs
+++ b/Common.hs
@@ -9,7 +9,6 @@ import Control.Monad.IO.Class as X (liftIO)
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.Applicative as X
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
diff --git a/Git/CatFile.hs b/Git/CatFile.hs
index 4935cdf..ba68c4e 100644
--- a/Git/CatFile.hs
+++ b/Git/CatFile.hs
@@ -26,7 +26,6 @@ import qualified Data.ByteString.Lazy.Char8 as L8
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.Types
import Git.FilePath
import qualified Utility.CoProcess as CoProcess
import Utility.FileSystemEncoding
+import Utility.Tuple
data CatFileHandle = CatFileHandle
{ catFileProcess :: CoProcess.CoProcessHandle
diff --git a/Git/Construct.hs b/Git/Construct.hs
index 4899278..4ad74fd 100644
--- a/Git/Construct.hs
+++ b/Git/Construct.hs
@@ -94,7 +94,7 @@ fromUrl url
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 @@ fromRemotes repo = mapM construct remotepairs
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. -}
diff --git a/Git/Remote.hs b/Git/Remote.hs
index 717b540..f6eaf93 100644
--- a/Git/Remote.hs
+++ b/Git/Remote.hs
@@ -74,9 +74,9 @@ parseRemoteLocation s repo = ret $ calcloc s
(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
diff --git a/Git/Repair.hs b/Git/Repair.hs
index 1baf51a..8e43248 100644
--- a/Git/Repair.hs
+++ b/Git/Repair.hs
@@ -39,10 +39,10 @@ import qualified Git.Branch as Branch
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. -}
diff --git a/Messages.hs b/Messages.hs
index 0036e57..ff13b31 100644
--- a/Messages.hs
+++ b/Messages.hs
@@ -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 @@ module Messages (
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 @@ commandProgressDisabled = withMessageState $ \s -> return $
- 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)
diff --git a/Messages/Concurrent.hs b/Messages/Concurrent.hs
index 41153d0..8d69d6b 100644
--- a/Messages/Concurrent.hs
+++ b/Messages/Concurrent.hs
@@ -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
@@ -136,3 +137,25 @@ concurrentOutputSupported = return True -- Windows is always unicode
#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
diff --git a/Messages/Internal.hs b/Messages/Internal.hs
index 7ea8ee0..6ec7281 100644
--- a/Messages/Internal.hs
+++ b/Messages/Internal.hs
@@ -13,7 +13,6 @@ import Types.Messages
import Messages.Concurrent
import Messages.JSON
-
withMessageState :: (MessageState -> Annex a) -> Annex a
withMessageState a = Annex.getState Annex.output >>= a
diff --git a/Messages/Progress.hs b/Messages/Progress.hs
index c4f55de..3c263c0 100644
--- a/Messages/Progress.hs
+++ b/Messages/Progress.hs
@@ -23,34 +23,28 @@ import qualified System.Console.Regions as Regions
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
@@ -62,11 +56,6 @@ metered othermeter key a = withMessageState $ go (keySize key)
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)
combinemeter m = case othermeter of
diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs
index f1b48cd..ba28a77 100644
--- a/Remote/GCrypt.hs
+++ b/Remote/GCrypt.hs
@@ -119,7 +119,7 @@ gen' r u c gc = do
, 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
diff --git a/Remote/Git.hs b/Remote/Git.hs
index 78213f4..5c69473 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -165,8 +165,7 @@ gen r u c gc
, 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 @@ keyUrls r key = map tourl locs'
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 :: Remote -> Key -> AssociatedFile -> FilePath -> Annex Bool
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
diff --git a/Remote/Helper/Encryptable.hs b/Remote/Helper/Encryptable.hs
index b72a60e..1fe6d75 100644
--- a/Remote/Helper/Encryptable.hs
+++ b/Remote/Helper/Encryptable.hs
@@ -21,13 +21,13 @@ module Remote.Helper.Encryptable (
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
diff --git a/Remote/Helper/Special.hs b/Remote/Helper/Special.hs
index 2897087..ae654d5 100644
--- a/Remote/Helper/Special.hs
+++ b/Remote/Helper/Special.hs
@@ -62,7 +62,7 @@ findSpecialRemotes s = do
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 ()
diff --git a/Remote/P2P.hs b/Remote/P2P.hs
index ca555c3..118262b 100644
--- a/Remote/P2P.hs
+++ b/Remote/P2P.hs
@@ -63,7 +63,7 @@ chainGen addr r u c gc = do
, config = c
, localpath = Nothing
, repo = r
- , gitconfig = gc { remoteGitConfig = Just $ extractGitConfig r }
+ , gitconfig = gc { remoteGitConfig = extractGitConfig r }
, readonly = False
, availability = GloballyAvailable
, remotetype = remote
diff --git a/Remote/Rsync/RsyncUrl.hs b/Remote/Rsync/RsyncUrl.hs
index f7e9ebb..c0f30c1 100644
--- a/Remote/Rsync/RsyncUrl.hs
+++ b/Remote/Rsync/RsyncUrl.hs
@@ -17,7 +17,7 @@ import Utility.SafeCommand
import Data.Default
import System.FilePath.Posix
#ifdef mingw32_HOST_OS
-import Data.String.Utils
+import Utility.Split
#endif
import Annex.DirHashes
diff --git a/Remote/S3.hs b/Remote/S3.hs
index ab84117..a341da4 100644
--- a/Remote/S3.hs
+++ b/Remote/S3.hs
@@ -29,7 +29,6 @@ import Control.Monad.Trans.Resource
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 Annex.UUID
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)
diff --git a/Remote/WebDAV/DavLocation.hs b/Remote/WebDAV/DavLocation.hs
index e0e1846..daa669d 100644
--- a/Remote/WebDAV/DavLocation.hs
+++ b/Remote/WebDAV/DavLocation.hs
@@ -13,14 +13,14 @@ module Remote.WebDAV.DavLocation where
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
diff --git a/Types/Distribution.hs b/Types/Distribution.hs
index 80471c0..d19074b 100644
--- a/Types/Distribution.hs
+++ b/Types/Distribution.hs
@@ -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
diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs
index 7140380..f66136c 100644
--- a/Types/GitConfig.hs
+++ b/Types/GitConfig.hs
@@ -88,6 +88,7 @@ data GitConfig = GitConfig
, receiveDenyCurrentBranch :: DenyCurrentBranch
, gcryptId :: Maybe String
, gpgCmd :: GpgCmd
+ , gitConfigRepo :: Git.Repo
}
extractGitConfig :: Git.Repo -> GitConfig
@@ -148,6 +149,7 @@ extractGitConfig r = GitConfig
, 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 @@ data RemoteGitConfig = RemoteGitConfig
, 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 @@ extractRemoteGitConfig r remotename = RemoteGitConfig
, remoteAnnexDdarRepo = getmaybe "ddarrepo"
, remoteAnnexHookType = notempty $ getmaybe "hooktype"
, remoteAnnexExternalType = notempty $ getmaybe "externaltype"
- , remoteGitConfig = Nothing
+ , remoteGitConfig = extractGitConfig r
}
where
getbool k d = fromMaybe d $ getmaybebool k
diff --git a/Types/Messages.hs b/Types/Messages.hs
index 751a513..5515313 100644
--- a/Types/Messages.hs
+++ b/Types/Messages.hs
@@ -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 @@ data MessageState = MessageState
, 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 @@ instance Default MessageState
, consoleRegionErrFlag = False
#endif
, jsonBuffer = Nothing
+ , promptLock = promptlock
}
diff --git a/Utility/DataUnits.hs b/Utility/DataUnits.hs
index 6e40932..a6c9ffc 100644
--- a/Utility/DataUnits.hs
+++ b/Utility/DataUnits.hs
@@ -45,6 +45,7 @@ module Utility.DataUnits (
ByteSize,
roughSize,
+ roughSize',
compareSizes,
readSize
) where
@@ -109,7 +110,10 @@ oldSchoolUnits = zipWith (curry mingle) storageUnits memoryUnits
{- 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 @@ roughSize units short i
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
diff --git a/Utility/Directory.hs b/Utility/Directory.hs
index 693e771..c24f36d 100644
--- a/Utility/Directory.hs
+++ b/Utility/Directory.hs
@@ -96,10 +96,10 @@ dirTreeRecursiveSkipping skipdir topdir = go [] [topdir]
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. -}
diff --git a/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs
index ae3bd35..444dc4a 100644
--- a/Utility/FileSystemEncoding.hs
+++ b/Utility/FileSystemEncoding.hs
@@ -12,7 +12,6 @@ module Utility.FileSystemEncoding (
useFileSystemEncoding,
fileEncoding,
withFilePath,
- md5FilePath,
decodeBS,
encodeBS,
decodeW8,
@@ -20,6 +19,10 @@ module Utility.FileSystemEncoding (
encodeW8NUL,
decodeW8NUL,
truncateFilePath,
+ s2w8,
+ w82s,
+ c2w8,
+ w82c,
) where
import qualified GHC.Foreign as GHC
@@ -27,17 +30,15 @@ import qualified GHC.IO.Encoding as Encoding
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 @@ _encodeFilePath fp = unsafePerformIO $ do
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 @@ decodeW8 = s2w8 . _encodeFilePath
{- 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.
diff --git a/Utility/Glob.hs b/Utility/Glob.hs
index 119ea48..c7d5359 100644
--- a/Utility/Glob.hs
+++ b/Utility/Glob.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE PackageImports #-}
+
{- file globbing
-
- Copyright 2014 Joey Hess <id@joeyh.name>
@@ -14,10 +16,9 @@ module Utility.Glob (
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,11 +31,31 @@ compileGlob glob globcase = Glob $
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 =
case execute regex val of
diff --git a/Utility/Gpg.hs b/Utility/Gpg.hs
index f6173cd..336711b 100644
--- a/Utility/Gpg.hs
+++ b/Utility/Gpg.hs
@@ -14,11 +14,9 @@ import qualified Build.SysConfig as SysConfig
#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 @@ keyBlock public ls = unlines
{- 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
diff --git a/Utility/Hash.hs b/Utility/Hash.hs
index b6bf996..70f826b 100644
--- a/Utility/Hash.hs
+++ b/Utility/Hash.hs
@@ -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,
diff --git a/Utility/LinuxMkLibs.hs b/Utility/LinuxMkLibs.hs
index 122f396..15f82fd 100644
--- a/Utility/LinuxMkLibs.hs
+++ b/Utility/LinuxMkLibs.hs
@@ -12,10 +12,10 @@ import Utility.Directory
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
diff --git a/Utility/LockFile/PidLock.hs b/Utility/LockFile/PidLock.hs
index 87c11c0..23560fa 100644
--- a/Utility/LockFile/PidLock.hs
+++ b/Utility/LockFile/PidLock.hs
@@ -25,6 +25,8 @@ import Utility.Path
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.Maybe
import Data.List
import Network.BSD
import System.FilePath
-import Data.Hash.MD5
import Control.Applicative
import Prelude
@@ -99,7 +100,9 @@ sideLockFile lockfile = do
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"
diff --git a/Utility/Metered.hs b/Utility/Metered.hs
index e21e18c..626aa2c 100644
--- a/Utility/Metered.hs
+++ b/Utility/Metered.hs
@@ -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 System.IO.Unsafe
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 @@ commandMeter progressparser oh meterupdate cmd params =
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 @@ rateLimitMeterUpdate delta totalsize meterupdate = do
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
diff --git a/Utility/Misc.hs b/Utility/Misc.hs
index 564935d..4498c0a 100644
--- a/Utility/Misc.hs
+++ b/Utility/Misc.hs
@@ -45,14 +45,6 @@ separate c l = unbreak $ break c l
| 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')
diff --git a/Utility/Path.hs b/Utility/Path.hs
index cd9dc38..0779d16 100644
--- a/Utility/Path.hs
+++ b/Utility/Path.hs
@@ -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 System.Posix.Files
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 @@ simplifyPath path = dropTrailingPathSeparator $
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 @@ parentDir = takeDirectory . dropTrailingPathSeparator
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 @@ relPathDirToFile from to = relPathDirToFileAbs <$> absPath from <*> absPath to
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
diff --git a/Utility/Rsync.hs b/Utility/Rsync.hs
index d3823a5..f190b40 100644
--- a/Utility/Rsync.hs
+++ b/Utility/Rsync.hs
@@ -11,10 +11,10 @@ module Utility.Rsync where
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. -}
diff --git a/Utility/SafeCommand.hs b/Utility/SafeCommand.hs
index bef0a61..eb34d3d 100644
--- a/Utility/SafeCommand.hs
+++ b/Utility/SafeCommand.hs
@@ -11,7 +11,7 @@ module Utility.SafeCommand where
import System.Exit
import Utility.Process
-import Utility.Misc
+import Utility.Split
import System.FilePath
import Data.Char
import Data.List
diff --git a/Utility/Scheduled.hs b/Utility/Scheduled.hs
index d23aaf0..b68ff90 100644
--- a/Utility/Scheduled.hs
+++ b/Utility/Scheduled.hs
@@ -29,6 +29,7 @@ module Utility.Scheduled (
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
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
diff --git a/Utility/Split.hs b/Utility/Split.hs
new file mode 100644
index 0000000..decfe7d
--- /dev/null
+++ b/Utility/Split.hs
@@ -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
diff --git a/Utility/Tuple.hs b/Utility/Tuple.hs
new file mode 100644
index 0000000..25c6e8f
--- /dev/null
+++ b/Utility/Tuple.hs
@@ -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
diff --git a/doc/git-annex-adjust.mdwn b/doc/git-annex-adjust.mdwn
index 140de63..772d27b 100644
--- a/doc/git-annex-adjust.mdwn
+++ b/doc/git-annex-adjust.mdwn
@@ -4,7 +4,7 @@ git-annex adjust - enter an adjusted branch
# SYNOPSIS
-git annex adjust --unlock|--fix`
+`git annex adjust --unlock|--fix`
# DESCRIPTION
diff --git a/git-annex.cabal b/git-annex.cabal
index 48b2d67..b6a74c8 100644
--- a/git-annex.cabal
+++ b/git-annex.cabal
@@ -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 @@ source-repository head
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 @@ Executable git-annex
directory (>= 1.2),
filepath,
IfElse,
- MissingH,
hslogger,
monad-logger,
free,
@@ -361,12 +360,15 @@ Executable git-annex
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 @@ Executable git-annex
Utility.Scheduled.QuickCheck
Utility.Shell
Utility.SimpleProtocol
+ Utility.Split
Utility.SshConfig
Utility.Su
Utility.SystemDirectory
@@ -1059,6 +1062,7 @@ Executable git-annex
Utility.Tmp
Utility.Tor
Utility.Touch
+ Utility.Tuple
Utility.Url
Utility.UserInfo
Utility.Verifiable
diff --git a/stack.yaml b/stack.yaml
index 0d20fc3..d40b53e 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -23,4 +23,4 @@ extra-deps:
- yesod-default-1.2.0
explicit-setup-deps:
git-annex: true
-resolver: lts-8.6
+resolver: lts-8.13