summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoeyHess <>2018-01-12 19:48:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2018-01-12 19:48:00 (GMT)
commit4bb418582d07257a91c466e88f77ab4612a39516 (patch)
tree84a9810f39e43108675cbbbdd270decc80686a1a
parente05acb94d7b924086d92255bfb1d06e5eb2af5c9 (diff)
version 6.20180112HEAD6.20180112master
-rw-r--r--Annex.hs16
-rw-r--r--Annex/Action.hs18
-rw-r--r--Annex/AdjustedBranch.hs2
-rw-r--r--Annex/Branch.hs10
-rw-r--r--Annex/Common.hs5
-rw-r--r--Annex/Content/Direct.hs4
-rw-r--r--Annex/Environment.hs2
-rw-r--r--Annex/Fixup.hs12
-rw-r--r--Annex/Journal.hs1
-rw-r--r--Annex/MakeRepo.hs1
-rw-r--r--Annex/Path.hs8
-rw-r--r--Annex/ReplaceFile.hs3
-rw-r--r--Annex/Ssh.hs5
-rw-r--r--Annex/Transfer.hs4
-rw-r--r--Annex/Url.hs4
-rw-r--r--Annex/YoutubeDl.hs26
-rw-r--r--Assistant.hs4
-rw-r--r--Assistant/MakeRemote.hs19
-rw-r--r--Assistant/Ssh.hs2
-rw-r--r--Assistant/Threads/UpgradeWatcher.hs4
-rw-r--r--Assistant/Threads/Upgrader.hs6
-rw-r--r--Assistant/Upgrade.hs7
-rw-r--r--Assistant/WebApp/Configurators/Edit.hs2
-rw-r--r--Assistant/WebApp/Configurators/Pairing.hs1
-rw-r--r--Assistant/WebApp/Configurators/Preferences.hs4
-rw-r--r--Assistant/WebApp/Configurators/Ssh.hs1
-rw-r--r--Assistant/WebApp/Documentation.hs4
-rw-r--r--Assistant/WebApp/Gpg.hs2
-rw-r--r--Assistant/WebApp/Types.hs2
-rw-r--r--Backend/Hash.hs12
-rw-r--r--Build/BundledPrograms.hs22
-rw-r--r--Build/Configure.hs13
-rw-r--r--Build/DesktopFile.hs4
-rw-r--r--Build/TestConfig.hs5
-rw-r--r--BuildFlags.hs109
-rw-r--r--BuildInfo.hs107
-rw-r--r--CHANGELOG28
-rw-r--r--COPYRIGHT4
-rw-r--r--CmdLine/Action.hs13
-rw-r--r--CmdLine/GitAnnex.hs6
-rw-r--r--CmdLine/GitAnnex/Options.hs11
-rw-r--r--Command/AddUrl.hs51
-rw-r--r--Command/Assistant.hs4
-rw-r--r--Command/EnableRemote.hs4
-rw-r--r--Command/Fsck.hs12
-rw-r--r--Command/FuzzTest.hs2
-rw-r--r--Command/ImportFeed.hs5
-rw-r--r--Command/Inprogress.hs60
-rw-r--r--Command/Map.hs33
-rw-r--r--Command/Multicast.hs2
-rw-r--r--Command/P2P.hs4
-rw-r--r--Command/Proxy.hs2
-rw-r--r--Command/Sync.hs1
-rw-r--r--Command/Version.hs6
-rw-r--r--Common.hs5
-rw-r--r--Git/BuildVersion.hs4
-rw-r--r--Git/Config.hs6
-rw-r--r--Git/Construct.hs9
-rw-r--r--Git/CurrentRepo.hs1
-rw-r--r--Git/Index.hs1
-rw-r--r--Git/LockFile.hs1
-rw-r--r--Git/Remote.hs9
-rw-r--r--Git/Repair.hs8
-rw-r--r--Git/Types.hs4
-rw-r--r--Logs/File.hs27
-rw-r--r--Logs/FsckResults.hs17
-rw-r--r--Logs/Schedule.hs4
-rw-r--r--Logs/Transfer.hs17
-rw-r--r--Logs/Unused.hs4
-rw-r--r--Logs/View.hs4
-rw-r--r--Remote/GCrypt.hs2
-rw-r--r--Remote/Git.hs102
-rw-r--r--Remote/Rsync.hs2
-rw-r--r--RemoteDaemon/Core.hs6
-rw-r--r--Test.hs39
-rw-r--r--Types/GitConfig.hs2
-rw-r--r--Types/Test.hs8
-rw-r--r--Utility/CopyFile.hs10
-rw-r--r--Utility/Directory.hs93
-rw-r--r--Utility/Directory/Stream.hs113
-rw-r--r--Utility/Env.hs24
-rw-r--r--Utility/Env/Basic.hs22
-rw-r--r--Utility/Env/Set.hs41
-rw-r--r--Utility/Gpg.hs11
-rw-r--r--Utility/LogFile.hs1
-rw-r--r--Utility/Lsof.hs8
-rw-r--r--Utility/Misc.hs21
-rw-r--r--Utility/Path.hs53
-rw-r--r--Utility/Path/Max.hs40
-rw-r--r--Utility/Process.hs71
-rw-r--r--Utility/Process/Transcript.hs87
-rw-r--r--Utility/Rsync.hs30
-rw-r--r--Utility/Su.hs1
-rw-r--r--Utility/Tmp.hs51
-rw-r--r--Utility/Tmp/Dir.hs68
-rw-r--r--Utility/Url.hs8
-rw-r--r--Utility/UserInfo.hs2
-rw-r--r--doc/git-annex-export.mdwn118
-rw-r--r--doc/git-annex-inprogress.mdwn53
-rw-r--r--doc/git-annex.mdwn18
-rw-r--r--git-annex.cabal33
-rw-r--r--git-annex.hs2
-rw-r--r--stack.yaml1
103 files changed, 1245 insertions, 716 deletions
diff --git a/Annex.hs b/Annex.hs
index 427c479..4ab7003 100644
--- a/Annex.hs
+++ b/Annex.hs
@@ -1,6 +1,6 @@
{- git-annex monad
-
- - Copyright 2010-2013 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2018 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -34,12 +34,14 @@ module Annex (
getRemoteGitConfig,
withCurrentState,
changeDirectory,
+ getGitRemotes,
incError,
) where
import Common
import qualified Git
import qualified Git.Config
+import qualified Git.Construct
import Annex.Fixup
import Git.CatFile
import Git.HashObject
@@ -98,6 +100,7 @@ data AnnexState = AnnexState
{ repo :: Git.Repo
, repoadjustment :: (Git.Repo -> IO Git.Repo)
, gitconfig :: GitConfig
+ , gitremotes :: Maybe [Git.Repo]
, backend :: Maybe (BackendA Annex)
, remotes :: [Types.Remote.RemoteA Annex]
, remoteannexstate :: M.Map UUID AnnexState
@@ -153,6 +156,7 @@ newState c r = do
{ repo = r
, repoadjustment = return
, gitconfig = c
+ , gitremotes = Nothing
, backend = Nothing
, remotes = []
, remoteannexstate = M.empty
@@ -357,3 +361,13 @@ incError = changeState $ \s ->
let ! c = errcounter s + 1
! s' = s { errcounter = c }
in s'
+
+getGitRemotes :: Annex [Git.Repo]
+getGitRemotes = do
+ s <- getState id
+ case gitremotes s of
+ Just rs -> return rs
+ Nothing -> do
+ rs <- liftIO $ Git.Construct.fromRemotes (repo s)
+ changeState $ \s' -> s' { gitremotes = Just rs }
+ return rs
diff --git a/Annex/Action.hs b/Annex/Action.hs
index fc8be6c..273c62f 100644
--- a/Annex/Action.hs
+++ b/Annex/Action.hs
@@ -12,6 +12,8 @@ module Annex.Action where
import qualified Data.Map as M
#ifndef mingw32_HOST_OS
import System.Posix.Signals
+import System.Posix.Process (getAnyProcessStatus)
+import Utility.Exception
#endif
import Annex.Common
@@ -46,3 +48,19 @@ stopCoProcesses = do
checkAttrStop
hashObjectStop
checkIgnoreStop
+
+{- Reaps any zombie processes that may be hanging around.
+ -
+ - Warning: Not thread safe. Anything that was expecting to wait
+ - on a process and get back an exit status is going to be confused
+ - if this reap gets there first. -}
+reapZombies :: IO ()
+#ifndef mingw32_HOST_OS
+reapZombies =
+ -- throws an exception when there are no child processes
+ catchDefaultIO Nothing (getAnyProcessStatus False True)
+ >>= maybe (return ()) (const reapZombies)
+
+#else
+reapZombies = return ()
+#endif
diff --git a/Annex/AdjustedBranch.hs b/Annex/AdjustedBranch.hs
index 1ffc54f..4bf1b63 100644
--- a/Annex/AdjustedBranch.hs
+++ b/Annex/AdjustedBranch.hs
@@ -50,7 +50,7 @@ import Annex.AutoMerge
import Annex.Content
import Annex.Perms
import Annex.GitOverlay
-import Utility.Tmp
+import Utility.Tmp.Dir
import Utility.CopyFile
import qualified Database.Keys
import Config
diff --git a/Annex/Branch.hs b/Annex/Branch.hs
index 0dc360c..c8f2f4c 100644
--- a/Annex/Branch.hs
+++ b/Annex/Branch.hs
@@ -57,14 +57,15 @@ import Annex.CatFile
import Annex.Perms
import Logs
import Logs.Transitions
+import Logs.File
import Logs.Trust.Pure
import Logs.Difference.Pure
-import Annex.ReplaceFile
import qualified Annex.Queue
import Annex.Branch.Transitions
import qualified Annex
import Annex.Hook
import Utility.FileSystemEncoding
+import Utility.Directory.Stream
{- Name of the branch that is used to store git-annex's information. -}
name :: Git.Ref
@@ -419,8 +420,7 @@ needUpdateIndex branchref = do
setIndexSha :: Git.Ref -> Annex ()
setIndexSha ref = do
f <- fromRepo gitAnnexIndexStatus
- liftIO $ writeFile f $ fromRef ref ++ "\n"
- setAnnexFilePerm f
+ writeLogFile f $ fromRef ref ++ "\n"
runAnnexHook postUpdateAnnexHook
{- Stages the journal into the index and returns an action that will
@@ -582,7 +582,7 @@ ignoreRefs rs = do
old <- getIgnoredRefs
let s = S.unions [old, S.fromList rs]
f <- fromRepo gitAnnexIgnoredRefs
- replaceFile f $ \tmp -> liftIO $ writeFile tmp $
+ writeLogFile f $
unlines $ map fromRef $ S.elems s
getIgnoredRefs :: Annex (S.Set Git.Sha)
@@ -599,7 +599,7 @@ addMergedRefs new = do
-- Keep only the newest sha for each branch.
let l = nubBy ((==) `on` snd) (new ++ old)
f <- fromRepo gitAnnexMergedRefs
- replaceFile f $ \tmp -> liftIO $ writeFile tmp $
+ writeLogFile f $
unlines $ map (\(s, b) -> fromRef s ++ '\t' : fromRef b) l
getMergedRefs :: Annex (S.Set Git.Sha)
diff --git a/Annex/Common.hs b/Annex/Common.hs
index 52a545a..bb277df 100644
--- a/Annex/Common.hs
+++ b/Annex/Common.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE CPP #-}
+
module Annex.Common (module X) where
import Common as X
@@ -7,3 +9,6 @@ import Types.UUID as X
import Annex as X (gitRepo, inRepo, fromRepo, calcRepo)
import Annex.Locations as X
import Messages as X
+#ifndef mingw32_HOST_OS
+import System.Posix.IO as X hiding (createPipe)
+#endif
diff --git a/Annex/Content/Direct.hs b/Annex/Content/Direct.hs
index 734a0c1..46fd327 100644
--- a/Annex/Content/Direct.hs
+++ b/Annex/Content/Direct.hs
@@ -32,8 +32,8 @@ module Annex.Content.Direct (
import Annex.Common
import Annex.Perms
import qualified Git
-import Utility.Tmp
import Logs.Location
+import Logs.File
import Utility.InodeCache
import Utility.CopyFile
import Annex.ReplaceFile
@@ -67,7 +67,7 @@ changeAssociatedFiles key transform = do
let files' = transform files
when (files /= files') $
modifyContent mapping $
- liftIO $ viaTmp writeFile mapping $ unlines files'
+ writeLogFile mapping $ unlines files'
top <- fromRepo Git.repoPath
return $ map (top </>) files'
diff --git a/Annex/Environment.hs b/Annex/Environment.hs
index 4f0fda9..6fdac1e 100644
--- a/Annex/Environment.hs
+++ b/Annex/Environment.hs
@@ -13,7 +13,7 @@ import Annex.Common
import Utility.UserInfo
import qualified Git.Config
import Config
-import Utility.Env
+import Utility.Env.Set
{- Checks that the system's environment allows git to function.
- Git requires a GECOS username, or suitable git configuration, or
diff --git a/Annex/Fixup.hs b/Annex/Fixup.hs
index 4b5149d..077eccf 100644
--- a/Annex/Fixup.hs
+++ b/Annex/Fixup.hs
@@ -10,7 +10,6 @@ module Annex.Fixup where
import Git.Types
import Git.Config
import Types.GitConfig
-import qualified Git.Construct as Construct
import qualified Git.BuildVersion
import Utility.Path
import Utility.SafeCommand
@@ -30,7 +29,7 @@ fixupRepo r c = do
let r' = disableWildcardExpansion r
r'' <- fixupSubmodule r' c
if annexDirect c
- then fixupDirect r''
+ then return (fixupDirect r'')
else return r''
{- Disable git's built-in wildcard expansion, which is not wanted
@@ -44,19 +43,16 @@ disableWildcardExpansion r
{- Direct mode repos have core.bare=true, but are not really bare.
- Fix up the Repo to be a non-bare repo, and arrange for git commands
- run by git-annex to be passed parameters that override this setting. -}
-fixupDirect :: Repo -> IO Repo
+fixupDirect :: Repo -> Repo
fixupDirect r@(Repo { location = l@(Local { gitdir = d, worktree = Nothing }) }) = do
- let r' = r
+ r
{ location = l { worktree = Just (parentDir d) }
, gitGlobalOpts = gitGlobalOpts r ++
[ Param "-c"
, Param $ coreBare ++ "=" ++ boolConfig False
]
}
- -- Recalc now that the worktree is correct.
- rs' <- Construct.fromRemotes r'
- return $ r' { remotes = rs' }
-fixupDirect r = return r
+fixupDirect r = r
{- Submodules have their gitdir containing ".git/modules/", and
- have core.worktree set, and also have a .git file in the top
diff --git a/Annex/Journal.hs b/Annex/Journal.hs
index 184bb0a..0ff95ff 100644
--- a/Annex/Journal.hs
+++ b/Annex/Journal.hs
@@ -17,6 +17,7 @@ import Annex.Common
import qualified Git
import Annex.Perms
import Annex.LockFile
+import Utility.Directory.Stream
{- Records content for a file in the branch to the journal.
-
diff --git a/Annex/MakeRepo.hs b/Annex/MakeRepo.hs
index ac25c01..189e98c 100644
--- a/Annex/MakeRepo.hs
+++ b/Annex/MakeRepo.hs
@@ -20,6 +20,7 @@ import Annex.Action
import Types.StandardGroups
import Logs.PreferredContent
import qualified Annex.Branch
+import Utility.Process.Transcript
{- Makes a new git repository. Or, if a git repository already
- exists, returns False. -}
diff --git a/Annex/Path.hs b/Annex/Path.hs
index 8209e5b..0f85b11 100644
--- a/Annex/Path.hs
+++ b/Annex/Path.hs
@@ -5,8 +5,6 @@
- Licensed under the GNU GPL version 3 or higher.
-}
-{-# LANGUAGE CPP #-}
-
module Annex.Path where
import Common
@@ -17,7 +15,7 @@ import System.Environment (getExecutablePath)
{- A fully qualified path to the currently running git-annex program.
-
- - getExecutablePath is available since ghc 7.4.2. On OSs it supports
+ - getExecutablePath is used when possible. On OSs it supports
- well, it returns the complete path to the program. But, on other OSs,
- it might return just the basename. Fall back to reading the programFile,
- or searching for the command name in PATH.
@@ -31,12 +29,8 @@ programPath = go =<< getEnv "GIT_ANNEX_PROGRAMPATH"
where
go (Just p) = return p
go Nothing = do
-#if MIN_VERSION_base(4,6,0)
exe <- getExecutablePath
p <- if isAbsolute exe
then return exe
else readProgramFile
-#else
- p <- readProgramFile
-#endif
maybe cannotFindProgram return =<< searchPath p
diff --git a/Annex/ReplaceFile.hs b/Annex/ReplaceFile.hs
index 7cb4fbd..06dfdf5 100644
--- a/Annex/ReplaceFile.hs
+++ b/Annex/ReplaceFile.hs
@@ -11,7 +11,8 @@ module Annex.ReplaceFile where
import Annex.Common
import Annex.Perms
-import Utility.Tmp
+import Utility.Tmp.Dir
+import Utility.Path.Max
{- Replaces a possibly already existing file with a new version,
- atomically, by running an action.
diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs
index e3d2c3d..7280b58 100644
--- a/Annex/Ssh.hs
+++ b/Annex/Ssh.hs
@@ -25,7 +25,7 @@ module Annex.Ssh (
import Annex.Common
import Annex.LockFile
-import qualified Build.SysConfig as SysConfig
+import qualified BuildInfo
import qualified Annex
import qualified Git
import qualified Git.Url
@@ -34,6 +34,7 @@ import Annex.Path
import Utility.Env
import Utility.FileSystemEncoding
import Utility.Hash
+import Utility.Process.Transcript
import Types.CleanupActions
import Types.Concurrency
import Git.Env
@@ -138,7 +139,7 @@ sshConnectionCachingParams socketfile =
- a different filesystem. -}
sshCacheDir :: Annex (Maybe FilePath)
sshCacheDir
- | SysConfig.sshconnectioncaching =
+ | BuildInfo.sshconnectioncaching =
ifM (fromMaybe True . annexSshCaching <$> Annex.getGitConfig)
( ifM crippledFileSystem
( maybe (return Nothing) usetmpdir =<< gettmpdir
diff --git a/Annex/Transfer.hs b/Annex/Transfer.hs
index ad617a7..0d013d4 100644
--- a/Annex/Transfer.hs
+++ b/Annex/Transfer.hs
@@ -96,7 +96,7 @@ runTransfer' ignorelock t afile shouldretry transferaction = checkSecureHashes t
Nothing -> return (Nothing, True)
Just lockhandle -> ifM (checkSaneLock lck lockhandle)
( do
- void $ liftIO $ tryIO $
+ void $ tryIO $
writeTransferInfoFile info tfile
return (Just lockhandle, False)
, do
@@ -111,7 +111,7 @@ runTransfer' ignorelock t afile shouldretry transferaction = checkSecureHashes t
Nothing -> return (Nothing, False)
Just Nothing -> return (Nothing, True)
Just (Just lockhandle) -> do
- void $ liftIO $ tryIO $
+ void $ tryIO $
writeTransferInfoFile info tfile
return (Just lockhandle, False)
#endif
diff --git a/Annex/Url.hs b/Annex/Url.hs
index f12408a..f777a0e 100644
--- a/Annex/Url.hs
+++ b/Annex/Url.hs
@@ -16,10 +16,10 @@ module Annex.Url (
import Annex.Common
import qualified Annex
import Utility.Url as U
-import qualified Build.SysConfig as SysConfig
+import qualified BuildInfo
defaultUserAgent :: U.UserAgent
-defaultUserAgent = "git-annex/" ++ SysConfig.packageversion
+defaultUserAgent = "git-annex/" ++ BuildInfo.packageversion
getUserAgent :: Annex (Maybe U.UserAgent)
getUserAgent = Annex.getState $
diff --git a/Annex/YoutubeDl.hs b/Annex/YoutubeDl.hs
index d1cac93..f49fb33 100644
--- a/Annex/YoutubeDl.hs
+++ b/Annex/YoutubeDl.hs
@@ -11,6 +11,7 @@ module Annex.YoutubeDl (
youtubeDlSupported,
youtubeDlCheck,
youtubeDlFileName,
+ youtubeDlFileName',
) where
import Annex.Common
@@ -20,9 +21,11 @@ import Annex.Url
import Utility.Url (URLString)
import Utility.DiskFree
import Utility.HtmlDetect
+import Utility.Process.Transcript
import Logs.Transfer
import Network.URI
+import Control.Concurrent.Async
-- Runs youtube-dl in a work directory, to download a single media file
-- from the url. Reutrns the path to the media file in the work directory.
@@ -144,7 +147,16 @@ youtubeDlCheck url
youtubeDlFileName :: URLString -> Annex (Either String FilePath)
youtubeDlFileName url
| supportedScheme url = flip catchIO (pure . Left . show) $
- htmlOnly url nomedia go
+ htmlOnly url nomedia (youtubeDlFileName' url)
+ | otherwise = return nomedia
+ where
+ nomedia = Left "no media in url"
+
+-- Does not check if the url contains htmlOnly; use when that's already
+-- been verified.
+youtubeDlFileName' :: URLString -> Annex (Either String FilePath)
+youtubeDlFileName' url
+ | supportedScheme url = flip catchIO (pure . Left . show) go
| otherwise = return nomedia
where
go = do
@@ -158,8 +170,16 @@ youtubeDlFileName url
, Param "--get-filename"
, Param "--no-warnings"
]
- (output, ok) <- liftIO $ processTranscript "youtube-dl"
- (toCommand opts) Nothing
+ (Nothing, Just o, Just e, pid) <- liftIO $ createProcess
+ (proc "youtube-dl" (toCommand opts))
+ { std_out = CreatePipe
+ , std_err = CreatePipe
+ }
+ output <- liftIO $ fmap fst $
+ hGetContentsStrict o
+ `concurrently`
+ hGetContentsStrict e
+ ok <- liftIO $ checkSuccessProcess pid
return $ case (ok, lines output) of
(True, (f:_)) | not (null f) -> Right f
_ -> nomedia
diff --git a/Assistant.hs b/Assistant.hs
index 81aa036..dc358c2 100644
--- a/Assistant.hs
+++ b/Assistant.hs
@@ -48,7 +48,7 @@ import Assistant.Types.UrlRenderer
import qualified Utility.Daemon
import Utility.ThreadScheduler
import Utility.HumanTime
-import qualified Build.SysConfig as SysConfig
+import qualified BuildInfo
import Annex.Perms
import Utility.LogFile
#ifdef mingw32_HOST_OS
@@ -135,7 +135,7 @@ startDaemon assistant foreground startdelay cannotrun listenhost startbrowser =
#else
go _webappwaiter = do
#endif
- notice ["starting", desc, "version", SysConfig.packageversion]
+ notice ["starting", desc, "version", BuildInfo.packageversion]
urlrenderer <- liftIO newUrlRenderer
#ifdef WITH_WEBAPP
let webappthread = [ assist $ webAppThread d urlrenderer False cannotrun Nothing listenhost webappwaiter ]
diff --git a/Assistant/MakeRemote.hs b/Assistant/MakeRemote.hs
index f492371..43b046b 100644
--- a/Assistant/MakeRemote.hs
+++ b/Assistant/MakeRemote.hs
@@ -16,6 +16,7 @@ import qualified Remote.Rsync as Rsync
import qualified Remote.GCrypt as GCrypt
import qualified Git
import qualified Git.Command
+import qualified Annex
import qualified Annex.SpecialRemote
import Logs.UUID
import Logs.Remote
@@ -122,26 +123,26 @@ makeGitRemote basename location = makeRemote basename location $ \name ->
- Returns the name of the remote. -}
makeRemote :: String -> String -> (RemoteName -> Annex ()) -> Annex RemoteName
makeRemote basename location a = do
- g <- gitRepo
- if not (any samelocation $ Git.remotes g)
+ rs <- Annex.getGitRemotes
+ if not (any samelocation rs)
then do
- let name = uniqueRemoteName basename 0 g
+ let name = uniqueRemoteName basename 0 rs
a name
return name
else return basename
where
samelocation x = Git.repoLocation x == location
-{- Generate an unused name for a remote, adding a number if
- - necessary.
+{- Given a list of all remotes, generate an unused name for a new
+ - remote, adding a number if necessary.
-
- Ensures that the returned name is a legal git remote name. -}
-uniqueRemoteName :: String -> Int -> Git.Repo -> RemoteName
-uniqueRemoteName basename n r
+uniqueRemoteName :: String -> Int -> [Git.Repo] -> RemoteName
+uniqueRemoteName basename n rs
| null namecollision = name
- | otherwise = uniqueRemoteName legalbasename (succ n) r
+ | otherwise = uniqueRemoteName legalbasename (succ n) rs
where
- namecollision = filter samename (Git.remotes r)
+ namecollision = filter samename rs
samename x = Git.remoteName x == Just name
name
| n == 0 = legalbasename
diff --git a/Assistant/Ssh.hs b/Assistant/Ssh.hs
index fb4a39a..8528446 100644
--- a/Assistant/Ssh.hs
+++ b/Assistant/Ssh.hs
@@ -9,12 +9,14 @@ module Assistant.Ssh where
import Annex.Common
import Utility.Tmp
+import Utility.Tmp.Dir
import Utility.Shell
import Utility.Rsync
import Utility.FileMode
import Utility.SshConfig
import Git.Remote
import Utility.SshHost
+import Utility.Process.Transcript
import Data.Text (Text)
import qualified Data.Text as T
diff --git a/Assistant/Threads/UpgradeWatcher.hs b/Assistant/Threads/UpgradeWatcher.hs
index 952db1f..a50c845 100644
--- a/Assistant/Threads/UpgradeWatcher.hs
+++ b/Assistant/Threads/UpgradeWatcher.hs
@@ -21,7 +21,7 @@ import Assistant.Alert
import Assistant.DaemonStatus
#ifdef WITH_WEBAPP
import Assistant.WebApp.Types
-import qualified Build.SysConfig
+import qualified BuildInfo
#endif
import Control.Concurrent.MVar
@@ -103,7 +103,7 @@ showSuccessfulUpgrade urlrenderer = do
(T.pack "Enable Automatic Upgrades")
urlrenderer ConfigEnableAutomaticUpgradeR
)
- void $ addAlert $ upgradeFinishedAlert button Build.SysConfig.packageversion
+ void $ addAlert $ upgradeFinishedAlert button BuildInfo.packageversion
#else
noop
#endif
diff --git a/Assistant/Threads/Upgrader.hs b/Assistant/Threads/Upgrader.hs
index 2bfbe5b..75c4353 100644
--- a/Assistant/Threads/Upgrader.hs
+++ b/Assistant/Threads/Upgrader.hs
@@ -19,7 +19,7 @@ import Assistant.DaemonStatus
import Assistant.Alert
import Utility.NotificationBroadcaster
import qualified Annex
-import qualified Build.SysConfig
+import qualified BuildInfo
import qualified Utility.DottedVersion as DottedVersion
import Types.Distribution
#ifdef WITH_WEBAPP
@@ -31,7 +31,7 @@ import qualified Data.Text as T
upgraderThread :: UrlRenderer -> NamedThread
upgraderThread urlrenderer = namedThread "Upgrader" $
- when (isJust Build.SysConfig.upgradelocation) $ do
+ when (isJust BuildInfo.upgradelocation) $ do
{- Check for upgrade on startup, unless it was just
- upgraded. -}
unlessM (liftIO checkSuccessfulUpgrade) $
@@ -63,7 +63,7 @@ checkUpgrade urlrenderer = do
where
go Nothing = debug [ "Failed to check if upgrade is available." ]
go (Just d) = do
- let installed = DottedVersion.normalize Build.SysConfig.packageversion
+ let installed = DottedVersion.normalize BuildInfo.packageversion
let avail = DottedVersion.normalize $ distributionVersion d
let old = DottedVersion.normalize <$> distributionUrgentUpgrade d
if Just installed <= old
diff --git a/Assistant/Upgrade.hs b/Assistant/Upgrade.hs
index cd1be4d..a100e23 100644
--- a/Assistant/Upgrade.hs
+++ b/Assistant/Upgrade.hs
@@ -15,6 +15,7 @@ import qualified Annex
import Assistant.Alert
import Assistant.DaemonStatus
import Utility.Env
+import Utility.Env.Set
import Types.Distribution
import Types.Transfer
import Logs.Web
@@ -31,12 +32,12 @@ import Remote (remoteFromUUID)
import Annex.Path
import Config.Files
import Utility.ThreadScheduler
-import Utility.Tmp
+import Utility.Tmp.Dir
import Utility.UserInfo
import Utility.Gpg
import Utility.FileMode
import qualified Utility.Lsof as Lsof
-import qualified Build.SysConfig
+import qualified BuildInfo
import qualified Utility.Url as Url
import qualified Annex.Url as Url
import Utility.Tuple
@@ -329,7 +330,7 @@ downloadDistributionInfo = do
)
distributionInfoUrl :: String
-distributionInfoUrl = fromJust Build.SysConfig.upgradelocation ++ ".info"
+distributionInfoUrl = fromJust BuildInfo.upgradelocation ++ ".info"
distributionInfoSigUrl :: String
distributionInfoSigUrl = distributionInfoUrl ++ ".sig"
diff --git a/Assistant/WebApp/Configurators/Edit.hs b/Assistant/WebApp/Configurators/Edit.hs
index b616bf4..822b74a 100644
--- a/Assistant/WebApp/Configurators/Edit.hs
+++ b/Assistant/WebApp/Configurators/Edit.hs
@@ -94,7 +94,7 @@ setRepoConfig uuid mremote oldc newc = do
void uuidMapLoad
when nameChanged $ do
liftAnnex $ do
- name <- fromRepo $ uniqueRemoteName (legalName newc) 0
+ name <- uniqueRemoteName (legalName newc) 0 <$> Annex.getGitRemotes
{- git remote rename expects there to be a
- remote.<name>.fetch, and exits nonzero if
- there's not. Special remotes don't normally
diff --git a/Assistant/WebApp/Configurators/Pairing.hs b/Assistant/WebApp/Configurators/Pairing.hs
index 66c27a1..5fcc42b 100644
--- a/Assistant/WebApp/Configurators/Pairing.hs
+++ b/Assistant/WebApp/Configurators/Pairing.hs
@@ -34,6 +34,7 @@ import Command.P2P (unusedPeerRemoteName, PairingResult(..))
import P2P.Address
import Git
import Config.Files
+import Utility.Process.Transcript
import qualified Data.Map as M
import qualified Data.Text as T
diff --git a/Assistant/WebApp/Configurators/Preferences.hs b/Assistant/WebApp/Configurators/Preferences.hs
index 4b9f581..54b4add 100644
--- a/Assistant/WebApp/Configurators/Preferences.hs
+++ b/Assistant/WebApp/Configurators/Preferences.hs
@@ -21,7 +21,7 @@ import Annex.NumCopies
import Utility.DataUnits
import Git.Config
import Types.Distribution
-import qualified Build.SysConfig
+import qualified BuildInfo
import qualified Data.Text as T
@@ -58,7 +58,7 @@ prefsAForm d = PrefsForm
, ("disabled", NoAutoUpgrade)
]
autoUpgradeLabel
- | isJust Build.SysConfig.upgradelocation = "Auto upgrade"
+ | isJust BuildInfo.upgradelocation = "Auto upgrade"
| otherwise = "Auto restart on upgrade"
positiveIntField = check isPositive intField
diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs
index bec4961..52e8247 100644
--- a/Assistant/WebApp/Configurators/Ssh.hs
+++ b/Assistant/WebApp/Configurators/Ssh.hs
@@ -40,6 +40,7 @@ import Utility.FileMode
import Utility.ThreadScheduler
import Utility.Env
import Utility.SshHost
+import Utility.Process.Transcript
import qualified Data.Text as T
import qualified Data.Map as M
diff --git a/Assistant/WebApp/Documentation.hs b/Assistant/WebApp/Documentation.hs
index 064f5db..63c4f7c 100644
--- a/Assistant/WebApp/Documentation.hs
+++ b/Assistant/WebApp/Documentation.hs
@@ -11,8 +11,8 @@ module Assistant.WebApp.Documentation where
import Assistant.WebApp.Common
import Assistant.Install (standaloneAppBase)
-import Build.SysConfig (packageversion)
-import BuildInfo
+import BuildInfo (packageversion)
+import BuildFlags
{- The full license info may be included in a file on disk that can
- be read in and displayed. -}
diff --git a/Assistant/WebApp/Gpg.hs b/Assistant/WebApp/Gpg.hs
index 10223cc..22285cf 100644
--- a/Assistant/WebApp/Gpg.hs
+++ b/Assistant/WebApp/Gpg.hs
@@ -69,7 +69,7 @@ withNewSecretKey use = do
-}
getGCryptRemoteName :: UUID -> String -> Annex RemoteName
getGCryptRemoteName u repoloc = do
- tmpremote <- uniqueRemoteName "tmpgcryptremote" 0 <$> gitRepo
+ tmpremote <- uniqueRemoteName "tmpgcryptremote" 0 <$> Annex.getGitRemotes
void $ inRepo $ Git.Command.runBool
[ Param "remote"
, Param "add"
diff --git a/Assistant/WebApp/Types.hs b/Assistant/WebApp/Types.hs
index 5450638..daefce8 100644
--- a/Assistant/WebApp/Types.hs
+++ b/Assistant/WebApp/Types.hs
@@ -24,7 +24,7 @@ import Utility.WebApp
import Utility.Yesod
import Types.Transfer
import Utility.Gpg (KeyId)
-import Build.SysConfig (packageversion)
+import BuildInfo (packageversion)
import Types.ScheduledActivity
import Assistant.WebApp.RepoId
import Assistant.WebApp.Pairing
diff --git a/Backend/Hash.hs b/Backend/Hash.hs
index a0a16b7..da0f7df 100644
--- a/Backend/Hash.hs
+++ b/Backend/Hash.hs
@@ -18,7 +18,7 @@ import Types.KeySource
import Utility.Hash
import Utility.ExternalSHA
-import qualified Build.SysConfig as SysConfig
+import qualified BuildInfo
import qualified Data.ByteString.Lazy as L
import Data.Char
@@ -187,11 +187,11 @@ hashFile hash file filesize = go hash
shaHasher :: HashSize -> Integer -> Either (L.ByteString -> String) (String, L.ByteString -> String)
shaHasher (HashSize hashsize) filesize
- | hashsize == 1 = use SysConfig.sha1 sha1
- | hashsize == 256 = use SysConfig.sha256 sha2_256
- | hashsize == 224 = use SysConfig.sha224 sha2_224
- | hashsize == 384 = use SysConfig.sha384 sha2_384
- | hashsize == 512 = use SysConfig.sha512 sha2_512
+ | hashsize == 1 = use BuildInfo.sha1 sha1
+ | hashsize == 256 = use BuildInfo.sha256 sha2_256
+ | hashsize == 224 = use BuildInfo.sha224 sha2_224
+ | hashsize == 384 = use BuildInfo.sha384 sha2_384
+ | hashsize == 512 = use BuildInfo.sha512 sha2_512
| otherwise = error $ "unsupported SHA size " ++ show hashsize
where
use Nothing hasher = Left $ usehasher hasher
diff --git a/Build/BundledPrograms.hs b/Build/BundledPrograms.hs
index 9e590bc..a6afdb7 100644
--- a/Build/BundledPrograms.hs
+++ b/Build/BundledPrograms.hs
@@ -11,7 +11,7 @@ module Build.BundledPrograms where
import Data.Maybe
-import Build.SysConfig as SysConfig
+import BuildInfo
{- Programs that git-annex uses, to include in the bundle.
-
@@ -28,7 +28,7 @@ extraBundledPrograms = catMaybes
-- integrate with the system gpg-agent, etc.
-- On Windows, gpg is bundled with git for windows.
#ifndef mingw32_HOST_OS
- [ SysConfig.gpg
+ [ BuildInfo.gpg
#else
[
#endif
@@ -75,19 +75,19 @@ preferredBundledPrograms = catMaybes
-- wget on OSX has been problematic, looking for certs in the wrong
-- places. Don't ship it, use curl or the OSX's own wget if it has
-- one.
- , ifset SysConfig.wget "wget"
+ , ifset BuildInfo.wget "wget"
#endif
#endif
- , SysConfig.lsof
- , SysConfig.gcrypt
+ , BuildInfo.lsof
+ , BuildInfo.gcrypt
#ifndef mingw32_HOST_OS
-- All these utilities are included in git for Windows
- , ifset SysConfig.curl "curl"
- , SysConfig.sha1
- , SysConfig.sha256
- , SysConfig.sha512
- , SysConfig.sha224
- , SysConfig.sha384
+ , ifset BuildInfo.curl "curl"
+ , BuildInfo.sha1
+ , BuildInfo.sha256
+ , BuildInfo.sha512
+ , BuildInfo.sha224
+ , BuildInfo.sha384
, Just "cp"
#endif
#ifdef linux_HOST_OS
diff --git a/Build/Configure.hs b/Build/Configure.hs
index f51ceef..a0ddf4d 100644
--- a/Build/Configure.hs
+++ b/Build/Configure.hs
@@ -1,25 +1,26 @@
-{- Checks system configuration and generates SysConfig.hs. -}
+{- Checks system configuration and generates SysConfig. -}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Build.Configure where
-import Control.Applicative
-import Control.Monad.IfElse
-import Control.Monad
-
import Build.TestConfig
import Build.Version
import Utility.PartialPrelude
import Utility.Process
import Utility.SafeCommand
import Utility.ExternalSHA
-import Utility.Env
+import Utility.Env.Basic
import Utility.Exception
import qualified Git.Version
import Utility.DottedVersion
import Utility.Directory
+import Control.Monad.IfElse
+import Control.Monad
+import Control.Applicative
+import Prelude
+
tests :: [TestCase]
tests =
[ TestCase "version" (Config "packageversion" . StringConfig <$> getVersion)
diff --git a/Build/DesktopFile.hs b/Build/DesktopFile.hs
index 0203c02..a54f45d 100644
--- a/Build/DesktopFile.hs
+++ b/Build/DesktopFile.hs
@@ -22,9 +22,7 @@ import Assistant.Install.AutoStart
import Assistant.Install.Menu
import System.Environment
-#ifndef mingw32_HOST_OS
-import System.Posix.User
-#endif
+import System.PosixCompat.User
import Data.Maybe
import Control.Applicative
import Prelude
diff --git a/Build/TestConfig.hs b/Build/TestConfig.hs
index f6ad2df..2f7213f 100644
--- a/Build/TestConfig.hs
+++ b/Build/TestConfig.hs
@@ -1,4 +1,4 @@
-{- Tests the system and generates Build.SysConfig.hs. -}
+{- Tests the system and generates SysConfig. -}
{-# OPTIONS_GHC -fno-warn-tabs #-}
@@ -42,12 +42,11 @@ instance Show Config where
valuetype (MaybeBoolConfig _) = "Maybe Bool"
writeSysConfig :: [Config] -> IO ()
-writeSysConfig config = writeFile "Build/SysConfig.hs" body
+writeSysConfig config = writeFile "Build/SysConfig" body
where
body = unlines $ header ++ map show config ++ footer
header = [
"{- Automatically generated. -}"
- , "module Build.SysConfig where"
, ""
]
footer = []
diff --git a/BuildFlags.hs b/BuildFlags.hs
new file mode 100644
index 0000000..e750506
--- /dev/null
+++ b/BuildFlags.hs
@@ -0,0 +1,109 @@
+{- git-annex build flags
+ -
+ - Copyright 2013-2017 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module BuildFlags where
+
+import Data.List
+import Data.Ord
+import qualified Data.CaseInsensitive as CI
+
+buildFlags :: [String]
+buildFlags = filter (not . null)
+ [ ""
+#ifdef WITH_ASSISTANT
+ , "Assistant"
+#else
+#warning Building without the assistant.
+#endif
+#ifdef WITH_WEBAPP
+ , "Webapp"
+#else
+#warning Building without the webapp. You probably need to install Yesod..
+#endif
+#ifdef WITH_PAIRING
+ , "Pairing"
+#else
+#warning Building without local pairing.
+#endif
+#ifdef WITH_S3
+ , "S3"
+#if MIN_VERSION_aws(0,10,6)
+ ++ "(multipartupload)"
+#endif
+#if MIN_VERSION_aws(0,13,0)
+ ++ "(storageclasses)"
+#endif
+#else
+#warning Building without S3.
+#endif
+#ifdef WITH_WEBDAV
+ , "WebDAV"
+#else
+#warning Building without WebDAV.
+#endif
+#ifdef WITH_INOTIFY
+ , "Inotify"
+#endif
+#ifdef WITH_FSEVENTS
+ , "FsEvents"
+#endif
+#ifdef WITH_KQUEUE
+ , "Kqueue"
+#endif
+#ifdef WITH_DBUS
+ , "DBus"
+#endif
+#ifdef WITH_DESKTOP_NOTIFY
+ , "DesktopNotify"
+#endif
+#ifdef WITH_CONCURRENTOUTPUT
+ , "ConcurrentOutput"
+#else
+#warning Building without ConcurrentOutput
+#endif
+#ifdef WITH_TORRENTPARSER
+ , "TorrentParser"
+#endif
+#ifdef WITH_MAGICMIME
+ , "MagicMime"
+#endif
+ -- Always enabled now, but users may be used to seeing these flags
+ -- listed.
+ , "Feeds"
+ , "Testsuite"
+ ]
+
+-- Not a complete list, let alone a listing transitive deps, but only
+-- the ones that are often interesting to know.
+dependencyVersions :: [String]
+dependencyVersions = map fmt $ sortBy (comparing (CI.mk . fst))
+ [ ("feed", VERSION_feed)
+ , ("uuid", VERSION_uuid)
+ , ("bloomfilter", VERSION_bloomfilter)
+ , ("http-client", VERSION_http_client)
+ , ("persistent-sqlite", VERSION_persistent_sqlite)
+ , ("cryptonite", VERSION_cryptonite)
+#ifdef WITH_S3
+ , ("aws", VERSION_aws)
+#endif
+#ifdef WITH_WEBDAV
+ , ("DAV", VERSION_DAV)
+#endif
+#ifdef WITH_TORRENTPARSER
+ , ("torrent", VERSION_torrent)
+#endif
+#ifdef WITH_WEBAPP
+ , ("yesod", VERSION_yesod)
+#endif
+#ifdef TOOL_VERSION_ghc
+ , ("ghc", TOOL_VERSION_ghc)
+#endif
+ ]
+ where
+ fmt (p, v) = p ++ "-" ++ v
diff --git a/BuildInfo.hs b/BuildInfo.hs
index 79253ee..40aa2fd 100644
--- a/BuildInfo.hs
+++ b/BuildInfo.hs
@@ -1,4 +1,4 @@
-{- git-annex build info reporting
+{- git-annex build info
-
- Copyright 2013-2017 Joey Hess <id@joeyh.name>
-
@@ -9,105 +9,6 @@
module BuildInfo where
-import Data.List
-import Data.Ord
-import qualified Data.CaseInsensitive as CI
-
-buildFlags :: [String]
-buildFlags = filter (not . null)
- [ ""
-#ifdef WITH_ASSISTANT
- , "Assistant"
-#else
-#warning Building without the assistant.
-#endif
-#ifdef WITH_WEBAPP
- , "Webapp"
-#else
-#warning Building without the webapp. You probably need to install Yesod..
-#endif
-#ifdef WITH_PAIRING
- , "Pairing"
-#else
-#warning Building without local pairing.
-#endif
-#ifdef WITH_TESTSUITE
- , "Testsuite"
-#else
-#warning Building without the testsuite.
-#endif
-#ifdef WITH_S3
- , "S3"
-#if MIN_VERSION_aws(0,10,6)
- ++ "(multipartupload)"
-#endif
-#if MIN_VERSION_aws(0,13,0)
- ++ "(storageclasses)"
-#endif
-#else
-#warning Building without S3.
-#endif
-#ifdef WITH_WEBDAV
- , "WebDAV"
-#else
-#warning Building without WebDAV.
-#endif
-#ifdef WITH_INOTIFY
- , "Inotify"
-#endif
-#ifdef WITH_FSEVENTS
- , "FsEvents"
-#endif
-#ifdef WITH_KQUEUE
- , "Kqueue"
-#endif
-#ifdef WITH_DBUS
- , "DBus"
-#endif
-#ifdef WITH_DESKTOP_NOTIFY
- , "DesktopNotify"
-#endif
-#ifdef WITH_CONCURRENTOUTPUT
- , "ConcurrentOutput"
-#else
-#warning Building without ConcurrentOutput
-#endif
-#ifdef WITH_TORRENTPARSER
- , "TorrentParser"
-#endif
-#ifdef WITH_MAGICMIME
- , "MagicMime"
-#endif
- -- Always enabled now, but users may be used to seeing these flags
- -- listed.
- , "Feeds"
- ]
-
--- Not a complete list, let alone a listing transitive deps, but only
--- the ones that are often interesting to know.
-dependencyVersions :: [String]
-dependencyVersions = map fmt $ sortBy (comparing (CI.mk . fst))
- [ ("feed", VERSION_feed)
- , ("uuid", VERSION_uuid)
- , ("bloomfilter", VERSION_bloomfilter)
- , ("http-client", VERSION_http_client)
- , ("persistent-sqlite", VERSION_persistent_sqlite)
- , ("cryptonite", VERSION_cryptonite)
-#ifdef WITH_S3
- , ("aws", VERSION_aws)
-#endif
-#ifdef WITH_WEBDAV
- , ("DAV", VERSION_DAV)
-#endif
-#ifdef WITH_TORRENTPARSER
- , ("torrent", VERSION_torrent)
-#endif
-#ifdef WITH_WEBAPP
- , ("yesod", VERSION_yesod)
-#endif
-#ifdef TOOL_VERSION_ghc
- , ("ghc", TOOL_VERSION_ghc)
-#endif
- ]
- where
- fmt (p, v) = p ++ "-" ++ v
+-- This file is generated by the configure program with the results of its
+-- probing.
+#include "Build/SysConfig"
diff --git a/CHANGELOG b/CHANGELOG
index 633ca07..1ff4880 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -1,4 +1,30 @@
-git-annex (6.20171214) unstable; urgency=medium
+git-annex (6.20180112) upstream; urgency=medium
+
+ * Added inprogress command for accessing files as they are being
+ downloaded.
+ * Fix bug introduced in version 6.20171018 that caused some commands
+ to print out "ok" twice after processing a file.
+ * addurl: When the file youtube-dl will download is already an annexed
+ file, don't download it again and fail to overwrite it, instead just do
+ nothing, like it used to when quvi was used.
+ * addurl: Fix encoding of filename queried from youtube-dl when in
+ --fast mode.
+ * Fix several places where files in .git/annex/ were written with modes
+ that did not take the core.sharedRepository config into account.
+ * Improve startup time for commands that do not operate on remotes,
+ and for tab completion, by not unnessessarily statting paths to
+ remotes, which used to cause eg, spin-up of removable drives.
+ * Added remote.<name>.annex-checkuuid config, which can be set to false
+ to disable the default checking of the uuid of remotes that point to
+ directories. This can be useful to avoid unncessary drive spin-ups and
+ automounting.
+ * git-annex.cabal: Add back custom-setup stanza, so cabal new-build works.
+ * git-annex.cabal: Removed the testsuite build flag; test suite is always
+ included.
+
+ -- Joey Hess <id@joeyh.name> Fri, 12 Jan 2018 15:45:48 -0400
+
+git-annex (6.20171214) upstream; urgency=medium
* Use youtube-dl rather than quvi to download media from web pages,
since quvi is not being actively developed and youtube-dl supports
diff --git a/COPYRIGHT b/COPYRIGHT
index d7a1881..4ac78af 100644
--- a/COPYRIGHT
+++ b/COPYRIGHT
@@ -2,7 +2,7 @@ Format: http://www.debian.org/doc/packaging-manuals/copyright-format/1.0/
Source: native package
Files: *
-Copyright: © 2010-2017 Joey Hess <id@joeyh.name>
+Copyright: © 2010-2018 Joey Hess <id@joeyh.name>
License: GPL-3+
Files: Assistant/WebApp.hs Assistant/WebApp/* templates/* static/*
@@ -21,7 +21,7 @@ Copyright: 2011 Bas van Dijk & Roel van Dijk
License: BSD-2-clause
Files: Utility/*
-Copyright: 2012-2017 Joey Hess <id@joeyh.name>
+Copyright: 2012-2018 Joey Hess <id@joeyh.name>
License: BSD-2-clause
Files: doc/logo* */favicon.ico standalone/osx/git-annex.app/Contents/Resources/git-annex.icns standalone/android/icons/*
diff --git a/CmdLine/Action.hs b/CmdLine/Action.hs
index 2e0bc2b..036f47d 100644
--- a/CmdLine/Action.hs
+++ b/CmdLine/Action.hs
@@ -149,15 +149,20 @@ callCommandAction = fromMaybe True <$$> callCommandAction'
{- Like callCommandAction, but returns Nothing when the command did not
- perform any action. -}
callCommandAction' :: CommandStart -> Annex (Maybe Bool)
-callCommandAction' = start
+callCommandAction' a = callCommandActionQuiet a >>= \case
+ Nothing -> return Nothing
+ Just r -> implicitMessage (showEndResult r) >> return (Just r)
+
+callCommandActionQuiet :: CommandStart -> Annex (Maybe Bool)
+callCommandActionQuiet = start
where
start = stage $ maybe skip perform
perform = stage $ maybe failure cleanup
cleanup = stage $ status
stage = (=<<)
skip = return Nothing
- failure = implicitMessage showEndFail >> return (Just False)
- status r = implicitMessage (showEndResult r) >> return (Just r)
+ failure = return (Just False)
+ status = return . Just
{- Do concurrent output when that has been requested. -}
allowConcurrentOutput :: Annex a -> Annex a
@@ -188,7 +193,7 @@ onlyActionOn k a = onlyActionOn' k run
where
-- Run whole action, not just start stage, so other threads
-- block until it's done.
- run = callCommandAction' a >>= \case
+ run = callCommandActionQuiet a >>= \case
Nothing -> return Nothing
Just r' -> return $ Just $ return $ Just $ return r'
diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs
index 1a5a138..e2f28e3 100644
--- a/CmdLine/GitAnnex.hs
+++ b/CmdLine/GitAnnex.hs
@@ -73,6 +73,7 @@ import qualified Command.Merge
import qualified Command.ResolveMerge
import qualified Command.Info
import qualified Command.Status
+import qualified Command.Inprogress
import qualified Command.Migrate
import qualified Command.Uninit
import qualified Command.Reinit
@@ -116,10 +117,8 @@ import qualified Command.WebApp
#endif
#endif
import qualified Command.Test
-#ifdef WITH_TESTSUITE
import qualified Command.FuzzTest
import qualified Command.TestRemote
-#endif
#ifdef WITH_BENCHMARK
import qualified Command.Benchmark
#endif
@@ -205,6 +204,7 @@ cmds testoptparser testrunner =
, Command.ResolveMerge.cmd
, Command.Info.cmd
, Command.Status.cmd
+ , Command.Inprogress.cmd
, Command.Migrate.cmd
, Command.Map.cmd
, Command.Direct.cmd
@@ -226,10 +226,8 @@ cmds testoptparser testrunner =
#endif
#endif
, Command.Test.cmd testoptparser testrunner
-#ifdef WITH_TESTSUITE
, Command.FuzzTest.cmd
, Command.TestRemote.cmd
-#endif
#ifdef WITH_BENCHMARK
, Command.Benchmark.cmd
#endif
diff --git a/CmdLine/GitAnnex/Options.hs b/CmdLine/GitAnnex/Options.hs
index 04f2436..d762f6a 100644
--- a/CmdLine/GitAnnex/Options.hs
+++ b/CmdLine/GitAnnex/Options.hs
@@ -1,6 +1,6 @@
{- git-annex command-line option parsing
-
- - Copyright 2010-2017 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2018 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -10,10 +10,12 @@ module CmdLine.GitAnnex.Options where
import Options.Applicative
import Options.Applicative.Builder.Internal
import Control.Concurrent
+import qualified Data.Map as M
import Annex.Common
import qualified Git.Config
import qualified Git.Construct
+import Git.Remote
import Git.Types
import Types.Key
import Types.TrustLevel
@@ -348,9 +350,10 @@ completeRemotes :: HasCompleter f => Mod f a
completeRemotes = completer $ mkCompleter $ \input -> do
r <- maybe (pure Nothing) (Just <$$> Git.Config.read)
=<< Git.Construct.fromCwd
- return $ filter (input `isPrefixOf`)
- (maybe [] (mapMaybe remoteName . remotes) r)
-
+ return $ filter (input `isPrefixOf`) $
+ map remoteKeyToRemoteName $
+ filter isRemoteKey $
+ maybe [] (M.keys . config) r
completeBackends :: HasCompleter f => Mod f a
completeBackends = completeWith $
diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs
index 406682e..995848e 100644
--- a/Command/AddUrl.hs
+++ b/Command/AddUrl.hs
@@ -30,6 +30,7 @@ import Logs.Location
import Utility.Metered
import Utility.FileSystemEncoding
import Utility.HtmlDetect
+import Utility.Path.Max
import qualified Annex.Transfer as Transfer
cmd :: Command
@@ -272,26 +273,42 @@ downloadWeb o url urlinfo file =
showDestinationFile file
liftIO $ createDirectoryIfMissing True (parentDir file)
finishDownloadWith tmp webUUID url file
- tryyoutubedl tmp = withTmpWorkDir mediakey $ \workdir ->
- Transfer.notifyTransfer Transfer.Download url $
- Transfer.download webUUID mediakey (AssociatedFile Nothing) Transfer.noRetry $ \_p ->
- youtubeDl url workdir >>= \case
- Right (Just mediafile) -> do
- pruneTmpWorkDirBefore tmp (liftIO . nukeFile)
- let dest = if isJust (fileOption o)
- then file
- else takeFileName mediafile
- checkCanAdd dest $ do
- showDestinationFile dest
- addWorkTree webUUID mediaurl dest mediakey (Just mediafile)
- return $ Just mediakey
- Right Nothing -> normalfinish tmp
- Left msg -> do
- warning msg
- return Nothing
+ tryyoutubedl tmp
+ | isJust (fileOption o) = dl file
+ -- Ask youtube-dl what filename it will download
+ -- first, and check if that is already an annexed file,
+ -- to avoid unnecessary work in that case.
+ | otherwise = youtubeDlFileName' url >>= \case
+ Right dest -> ifAnnexed dest
+ (alreadyannexed dest)
+ (dl dest)
+ Left _ -> normalfinish tmp
where
+ dl dest = withTmpWorkDir mediakey $ \workdir ->
+ Transfer.notifyTransfer Transfer.Download url $
+ Transfer.download webUUID mediakey (AssociatedFile Nothing) Transfer.noRetry $ \_p ->
+ youtubeDl url workdir >>= \case
+ Right (Just mediafile) -> do
+ pruneTmpWorkDirBefore tmp (liftIO . nukeFile)
+ checkCanAdd dest $ do
+ showDestinationFile dest
+ addWorkTree webUUID mediaurl dest mediakey (Just mediafile)
+ return $ Just mediakey
+ Right Nothing -> normalfinish tmp
+ Left msg -> do
+ warning msg
+ return Nothing
mediaurl = setDownloader url YoutubeDownloader
mediakey = Backend.URL.fromUrl mediaurl Nothing
+ -- Does the already annexed file have the mediaurl
+ -- as an url? If so nothing to do.
+ alreadyannexed dest k = do
+ us <- getUrls k
+ if mediaurl `elem` us
+ then return (Just k)
+ else do
+ warning $ dest ++ " already exists; not overwriting"
+ return Nothing
showDestinationFile :: FilePath -> Annex ()
showDestinationFile file = do
diff --git a/Command/Assistant.hs b/Command/Assistant.hs
index af63778..7008867 100644
--- a/Command/Assistant.hs
+++ b/Command/Assistant.hs
@@ -12,7 +12,7 @@ import qualified Command.Watch
import Annex.Init
import Annex.Path
import Config.Files
-import qualified Build.SysConfig
+import qualified BuildInfo
import Utility.HumanTime
import Assistant.Install
@@ -78,7 +78,7 @@ autoStart o = do
f <- autoStartFile
giveup $ "Nothing listed in " ++ f
program <- programPath
- haveionice <- pure Build.SysConfig.ionice <&&> inPath "ionice"
+ haveionice <- pure BuildInfo.ionice <&&> inPath "ionice"
pids <- forM dirs $ \d -> do
putStrLn $ "git-annex autostart in " ++ d
mpid <- catchMaybeIO $ go haveionice program d
diff --git a/Command/EnableRemote.hs b/Command/EnableRemote.hs
index e540473..0966614 100644
--- a/Command/EnableRemote.hs
+++ b/Command/EnableRemote.hs
@@ -36,7 +36,7 @@ seek = withWords start
start :: [String] -> CommandStart
start [] = unknownNameError "Specify the remote to enable."
-start (name:rest) = go =<< filter matchingname <$> Annex.fromRepo Git.remotes
+start (name:rest) = go =<< filter matchingname <$> Annex.getGitRemotes
where
matchingname r = Git.remoteName r == Just name
go [] = startSpecialRemote name (Logs.Remote.keyValToConfig rest)
@@ -104,7 +104,7 @@ unknownNameError prefix = do
else Remote.prettyPrintUUIDsDescs
"known special remotes"
descm (M.keys m)
- disabledremotes <- filterM isdisabled =<< Annex.fromRepo Git.remotes
+ disabledremotes <- filterM isdisabled =<< Annex.getGitRemotes
let remotesmsg = unlines $ map ("\t" ++) $
mapMaybe Git.remoteName disabledremotes
giveup $ concat $ filter (not . null) [prefix ++ "\n", remotesmsg, specialmsg]
diff --git a/Command/Fsck.hs b/Command/Fsck.hs
index 7884f04..2db6e27 100644
--- a/Command/Fsck.hs
+++ b/Command/Fsck.hs
@@ -563,15 +563,15 @@ recordStartTime :: UUID -> Annex ()
recordStartTime u = do
f <- fromRepo (gitAnnexFsckState u)
createAnnexDirectory $ parentDir f
- liftIO $ do
- nukeFile f
- withFile f WriteMode $ \h -> do
+ liftIO $ nukeFile f
+ liftIO $ withFile f WriteMode $ \h -> do
#ifndef mingw32_HOST_OS
- t <- modificationTime <$> getFileStatus f
+ t <- modificationTime <$> getFileStatus f
#else
- t <- getPOSIXTime
+ t <- getPOSIXTime
#endif
- hPutStr h $ showTime $ realToFrac t
+ hPutStr h $ showTime $ realToFrac t
+ setAnnexFilePerm f
where
showTime :: POSIXTime -> String
showTime = show
diff --git a/Command/FuzzTest.hs b/Command/FuzzTest.hs
index 0c5aac9..fd650fa 100644
--- a/Command/FuzzTest.hs
+++ b/Command/FuzzTest.hs
@@ -33,7 +33,7 @@ start = do
guardTest
logf <- fromRepo gitAnnexFuzzTestLogFile
showStart "fuzztest" logf
- logh <-liftIO $ openFile logf WriteMode
+ logh <- liftIO $ openFile logf WriteMode
void $ forever $ fuzz logh
stop
diff --git a/Command/ImportFeed.hs b/Command/ImportFeed.hs
index a02d118..1dee484 100644
--- a/Command/ImportFeed.hs
+++ b/Command/ImportFeed.hs
@@ -30,10 +30,10 @@ import qualified Remote
import qualified Types.Remote as Remote
import Types.UrlContents
import Logs.Web
+import Logs.File
import qualified Utility.Format
import Utility.Tmp
import Command.AddUrl (addUrlFile, downloadRemoteFile, parseDownloadOptions, DownloadOptions(..))
-import Annex.Perms
import Annex.UUID
import Backend.URL (fromUrl)
import Annex.Content
@@ -386,8 +386,7 @@ checkFeedBroken' url f = do
now <- liftIO getCurrentTime
case prev of
Nothing -> do
- createAnnexDirectory (parentDir f)
- liftIO $ writeFile f $ show now
+ writeLogFile f $ show now
return False
Just prevtime -> do
let broken = diffUTCTime now prevtime > 60 * 60 * 23
diff --git a/Command/Inprogress.hs b/Command/Inprogress.hs
new file mode 100644
index 0000000..f1a8345
--- /dev/null
+++ b/Command/Inprogress.hs
@@ -0,0 +1,60 @@
+{- git-annex command
+ -
+ - Copyright 2017 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Inprogress where
+
+import Command
+import Annex.Transfer
+
+import qualified Data.Set as S
+
+cmd :: Command
+cmd = noCommit $ noMessages $ command "inprogress" SectionQuery
+ "access files while they're being downloaded"
+ paramPaths (seek <$$> optParser)
+
+data InprogressOptions = InprogressOptions
+ { inprogressFiles :: CmdParams
+ , allOption :: Bool
+ }
+
+optParser :: CmdParamsDesc -> Parser InprogressOptions
+optParser desc = InprogressOptions
+ <$> cmdParams desc
+ <*> switch
+ ( long "all"
+ <> short 'A'
+ <> help "access all files currently being downloaded"
+ )
+
+seek :: InprogressOptions -> CommandSeek
+seek o = do
+ ts <- map (transferKey . fst) <$> getTransfers
+ if allOption o
+ then forM_ ts $ commandAction . start'
+ else do
+ let s = S.fromList ts
+ withFilesInGit (whenAnnexed (start s))
+ =<< workTreeItems (inprogressFiles o)
+
+start :: S.Set Key -> FilePath -> Key -> CommandStart
+start s _file k
+ | S.member k s = start' k
+ | otherwise = notInprogress
+
+start' :: Key -> CommandStart
+start' k = do
+ tmpf <- fromRepo $ gitAnnexTmpObjectLocation k
+ ifM (liftIO $ doesFileExist tmpf)
+ ( next $ next $ do
+ liftIO $ putStrLn tmpf
+ return True
+ , notInprogress
+ )
+
+notInprogress :: CommandStart
+notInprogress = next stop
diff --git a/Command/Map.hs b/Command/Map.hs
index 9ae73d8..42e3c36 100644
--- a/Command/Map.hs
+++ b/Command/Map.hs
@@ -27,6 +27,9 @@ import qualified Utility.Dot as Dot
-- a link from the first repository to the second (its remote)
data Link = Link Git.Repo Git.Repo
+-- a repo and its remotes
+type RepoRemotes = (Git.Repo, [Git.Repo])
+
cmd :: Command
cmd = dontCheck repoExists $
command "map" SectionQuery
@@ -76,11 +79,11 @@ runViewer file ((c, ps):rest) = ifM (liftIO $ inPath c)
- the repositories first, followed by uuids that were not matched
- to a repository.
-}
-drawMap :: [Git.Repo] -> TrustMap -> M.Map UUID String -> String
+drawMap :: [RepoRemotes] -> TrustMap -> M.Map UUID String -> String
drawMap rs trustmap umap = Dot.graph $ repos ++ others
where
- repos = map (node umap rs trustmap) rs
- ruuids = map getUncachedUUID rs
+ repos = map (node umap (map fst rs) trustmap) rs
+ ruuids = map (getUncachedUUID . fst) rs
others = map uuidnode $
filter (\u -> M.lookup u trustmap /= Just DeadTrusted) $
filter (`notElem` ruuids) (M.keys umap)
@@ -113,13 +116,13 @@ nodeId r =
UUID u -> u
{- A node representing a repo. -}
-node :: M.Map UUID String -> [Git.Repo] -> TrustMap -> Git.Repo -> String
-node umap fullinfo trustmap r = unlines $ n:edges
+node :: M.Map UUID String -> [Git.Repo] -> TrustMap -> RepoRemotes -> String
+node umap fullinfo trustmap (r, rs) = unlines $ n:edges
where
n = Dot.subGraph (hostname r) (basehostname r) "lightblue" $
trustDecorate trustmap (getUncachedUUID r) $
Dot.graphNode (nodeId r) (repoName umap r)
- edges = map (edge umap fullinfo r) (Git.remotes r)
+ edges = map (edge umap fullinfo r) rs
{- An edge between two repos. The second repo is a remote of the first. -}
edge :: M.Map UUID String -> [Git.Repo] -> Git.Repo -> Git.Repo -> String
@@ -149,21 +152,21 @@ trustDecorate trustmap u s = case M.lookup u trustmap of
Nothing -> Dot.fillColor "white" s
{- Recursively searches out remotes starting with the specified repo. -}
-spider :: Git.Repo -> Annex [Git.Repo]
+spider :: Git.Repo -> Annex [RepoRemotes]
spider r = spider' [r] []
-spider' :: [Git.Repo] -> [Git.Repo] -> Annex [Git.Repo]
+spider' :: [Git.Repo] -> [RepoRemotes] -> Annex [RepoRemotes]
spider' [] known = return known
spider' (r:rs) known
- | any (same r) known = spider' rs known
+ | any (same r) (map fst known) = spider' rs known
| otherwise = do
r' <- scan r
-- The remotes will be relative to r', and need to be
-- made absolute for later use.
- remotes <- mapM (absRepo r') (Git.remotes r')
- let r'' = r' { Git.remotes = remotes }
-
- spider' (rs ++ remotes) (r'':known)
+ remotes <- mapM (absRepo r')
+ =<< (liftIO $ Git.Construct.fromRemotes r')
+
+ spider' (rs ++ remotes) ((r', remotes):known)
{- Converts repos to a common absolute form. -}
absRepo :: Git.Repo -> Git.Repo -> Annex Git.Repo
@@ -260,11 +263,11 @@ tryScan r
{- Spidering can find multiple paths to the same repo, so this is used
- to combine (really remove) duplicate repos with the same UUID. -}
-combineSame :: [Git.Repo] -> [Git.Repo]
+combineSame :: [RepoRemotes] -> [RepoRemotes]
combineSame = map snd . nubBy sameuuid . map pair
where
sameuuid (u1, _) (u2, _) = u1 == u2 && u1 /= NoUUID
- pair r = (getUncachedUUID r, r)
+ pair (r, rs) = (getUncachedUUID r, (r, rs))
safely :: IO Git.Repo -> IO (Maybe Git.Repo)
safely a = do
diff --git a/Command/Multicast.hs b/Command/Multicast.hs
index 9a518a1..55792a2 100644
--- a/Command/Multicast.hs
+++ b/Command/Multicast.hs
@@ -25,6 +25,8 @@ import Types.FileMatcher
import qualified Git.LsFiles as LsFiles
import Utility.Hash
import Utility.Tmp
+import Utility.Tmp.Dir
+import Utility.Process.Transcript
import Config
import Data.Char
diff --git a/Command/P2P.hs b/Command/P2P.hs
index 40a49b4..65a2a67 100644
--- a/Command/P2P.hs
+++ b/Command/P2P.hs
@@ -19,7 +19,7 @@ import qualified Annex
import Annex.UUID
import Config
import Utility.AuthToken
-import Utility.Tmp
+import Utility.Tmp.Dir
import Utility.FileMode
import Utility.ThreadScheduler
import qualified Utility.MagicWormhole as Wormhole
@@ -76,7 +76,7 @@ seek (Pair, Nothing) = commandAction $ do
unusedPeerRemoteName :: Annex RemoteName
unusedPeerRemoteName = go (1 :: Integer) =<< usednames
where
- usednames = mapMaybe remoteName . remotes <$> Annex.gitRepo
+ usednames = mapMaybe remoteName <$> Annex.getGitRemotes
go n names = do
let name = "peer" ++ show n
if name `elem` names
diff --git a/Command/Proxy.hs b/Command/Proxy.hs
index dba0300..553d826 100644
--- a/Command/Proxy.hs
+++ b/Command/Proxy.hs
@@ -9,7 +9,7 @@ module Command.Proxy where
import Command
import Config
-import Utility.Tmp
+import Utility.Tmp.Dir
import Utility.Env
import Annex.Direct
import qualified Git
diff --git a/Command/Sync.hs b/Command/Sync.hs
index f63260e..75752f4 100644
--- a/Command/Sync.hs
+++ b/Command/Sync.hs
@@ -63,6 +63,7 @@ import Annex.TaggedPush
import qualified Database.Export as Export
import Utility.Bloom
import Utility.OptParse
+import Utility.Process.Transcript
import Control.Concurrent.MVar
import qualified Data.Map as M
diff --git a/Command/Version.hs b/Command/Version.hs
index 7af9287..ef3ef39 100644
--- a/Command/Version.hs
+++ b/Command/Version.hs
@@ -8,9 +8,9 @@
module Command.Version where
import Command
-import qualified Build.SysConfig as SysConfig
import Annex.Version
import BuildInfo
+import BuildFlags
import Types.Key
import qualified Types.Backend as B
import qualified Types.Remote as R
@@ -61,7 +61,7 @@ showVersion = do
showPackageVersion :: IO ()
showPackageVersion = do
- vinfo "git-annex version" SysConfig.packageversion
+ vinfo "git-annex version" BuildInfo.packageversion
vinfo "build flags" $ unwords buildFlags
vinfo "dependency versions" $ unwords dependencyVersions
vinfo "key/value backends" $ unwords $
@@ -70,7 +70,7 @@ showPackageVersion = do
showRawVersion :: IO ()
showRawVersion = do
- putStr SysConfig.packageversion
+ putStr BuildInfo.packageversion
hFlush stdout -- no newline, so flush
vinfo :: String -> String -> IO ()
diff --git a/Common.hs b/Common.hs
index 8ff1b71..9505620 100644
--- a/Common.hs
+++ b/Common.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE PackageImports, CPP #-}
+{-# LANGUAGE PackageImports #-}
module Common (module X) where
@@ -14,9 +14,6 @@ import Data.Default as X
import System.FilePath as X
import System.IO as X hiding (FilePath)
-#ifndef mingw32_HOST_OS
-import System.Posix.IO as X hiding (createPipe)
-#endif
import System.Exit as X
import System.PosixCompat.Files as X hiding (fileSize)
diff --git a/Git/BuildVersion.hs b/Git/BuildVersion.hs
index 50e4a3a..7d1c53a 100644
--- a/Git/BuildVersion.hs
+++ b/Git/BuildVersion.hs
@@ -8,14 +8,14 @@
module Git.BuildVersion where
import Git.Version
-import qualified Build.SysConfig
+import qualified BuildInfo
{- Using the version it was configured for avoids running git to check its
- version, at the cost that upgrading git won't be noticed.
- This is only acceptable because it's rare that git's version influences
- code's behavior. -}
buildVersion :: GitVersion
-buildVersion = normalize Build.SysConfig.gitversion
+buildVersion = normalize BuildInfo.gitversion
older :: String -> Bool
older n = buildVersion < normalize n
diff --git a/Git/Config.hs b/Git/Config.hs
index 9b4c342..9cee83f 100644
--- a/Git/Config.hs
+++ b/Git/Config.hs
@@ -13,8 +13,8 @@ import Data.Char
import Common
import Git
import Git.Types
-import qualified Git.Construct
import qualified Git.Command
+import qualified Git.Construct
import Utility.UserInfo
{- Returns a single git config setting, or a default value if not set. -}
@@ -89,12 +89,10 @@ hRead repo h = do
store :: String -> Repo -> IO Repo
store s repo = do
let c = parse s
- repo' <- updateLocation $ repo
+ updateLocation $ repo
{ config = (M.map Prelude.head c) `M.union` config repo
, fullconfig = M.unionWith (++) c (fullconfig repo)
}
- rs <- Git.Construct.fromRemotes repo'
- return $ repo' { remotes = rs }
{- Updates the location of a repo, based on its configuration.
-
diff --git a/Git/Construct.hs b/Git/Construct.hs
index 4ad74fd..d4424c9 100644
--- a/Git/Construct.hs
+++ b/Git/Construct.hs
@@ -127,8 +127,7 @@ fromRemotes repo = mapM construct remotepairs
where
filterconfig f = filter f $ M.toList $ config repo
filterkeys f = filterconfig (\(k,_) -> f k)
- remotepairs = filterkeys isremote
- isremote k = "remote." `isPrefixOf` k && ".url" `isSuffixOf` k
+ remotepairs = filterkeys isRemoteKey
construct (k,v) = remoteNamedFromKey k $ fromRemoteLocation v repo
{- Sets the name of a remote when constructing the Repo to represent it. -}
@@ -140,10 +139,7 @@ remoteNamed n constructor = do
{- Sets the name of a remote based on the git config key, such as
- "remote.foo.url". -}
remoteNamedFromKey :: String -> IO Repo -> IO Repo
-remoteNamedFromKey k = remoteNamed basename
- where
- basename = intercalate "." $
- reverse $ drop 1 $ reverse $ drop 1 $ splitc '.' k
+remoteNamedFromKey = remoteNamed . remoteKeyToRemoteName
{- Constructs a new Repo for one of a Repo's remotes using a given
- location (ie, an url). -}
@@ -233,7 +229,6 @@ newFrom l = Repo
{ location = l
, config = M.empty
, fullconfig = M.empty
- , remotes = []
, remoteName = Nothing
, gitEnv = Nothing
, gitEnvOverridesGitDir = False
diff --git a/Git/CurrentRepo.hs b/Git/CurrentRepo.hs
index 69a679e..df074cf 100644
--- a/Git/CurrentRepo.hs
+++ b/Git/CurrentRepo.hs
@@ -12,6 +12,7 @@ import Git.Types
import Git.Construct
import qualified Git.Config
import Utility.Env
+import Utility.Env.Set
{- Gets the current git repository.
-
diff --git a/Git/Index.hs b/Git/Index.hs
index 85ea480..0898569 100644
--- a/Git/Index.hs
+++ b/Git/Index.hs
@@ -10,6 +10,7 @@ module Git.Index where
import Common
import Git
import Utility.Env
+import Utility.Env.Set
indexEnv :: String
indexEnv = "GIT_INDEX_FILE"
diff --git a/Git/LockFile.hs b/Git/LockFile.hs
index a7a1441..e3d5900 100644
--- a/Git/LockFile.hs
+++ b/Git/LockFile.hs
@@ -13,6 +13,7 @@ import Common
#ifndef mingw32_HOST_OS
import System.Posix.Types
+import System.Posix.IO
#else
import System.Win32.Types
import System.Win32.File
diff --git a/Git/Remote.hs b/Git/Remote.hs
index f6eaf93..ce741a0 100644
--- a/Git/Remote.hs
+++ b/Git/Remote.hs
@@ -20,6 +20,15 @@ import Network.URI
import Git.FilePath
#endif
+{- Is a git config key one that specifies the location of a remote? -}
+isRemoteKey :: String -> Bool
+isRemoteKey k = "remote." `isPrefixOf` k && ".url" `isSuffixOf` k
+
+{- Get a remote's name from the config key that specifies its location. -}
+remoteKeyToRemoteName :: String -> RemoteName
+remoteKeyToRemoteName k = intercalate "." $
+ reverse $ drop 1 $ reverse $ drop 1 $ splitc '.' k
+
{- Construct a legal git remote name out of an arbitrary input string.
-
- There seems to be no formal definition of this in the git source,
diff --git a/Git/Repair.hs b/Git/Repair.hs
index 8e43248..ffc0976 100644
--- a/Git/Repair.hs
+++ b/Git/Repair.hs
@@ -11,7 +11,6 @@ module Git.Repair (
removeBadBranches,
successfulRepair,
cleanCorruptObjects,
- retrieveMissingObjects,
resetLocalBranches,
checkIndex,
checkIndexFast,
@@ -36,7 +35,7 @@ import qualified Git.Ref as Ref
import qualified Git.RefLog as RefLog
import qualified Git.UpdateIndex as UpdateIndex
import qualified Git.Branch as Branch
-import Utility.Tmp
+import Utility.Tmp.Dir
import Utility.Rsync
import Utility.FileMode
import Utility.Tuple
@@ -102,10 +101,11 @@ retrieveMissingObjects missing referencerepo r
unlessM (boolSystem "git" [Param "init", File tmpdir]) $
error $ "failed to create temp repository in " ++ tmpdir
tmpr <- Config.read =<< Construct.fromAbsPath tmpdir
- stillmissing <- pullremotes tmpr (remotes r) fetchrefstags missing
+ rs <- Construct.fromRemotes r
+ stillmissing <- pullremotes tmpr rs fetchrefstags missing
if S.null (knownMissing stillmissing)
then return stillmissing
- else pullremotes tmpr (remotes r) fetchallrefs stillmissing
+ else pullremotes tmpr rs fetchallrefs stillmissing
where
pullremotes tmpr [] fetchrefs stillmissing = case referencerepo of
Nothing -> return stillmissing
diff --git a/Git/Types.hs b/Git/Types.hs
index 327c1d7..25282a0 100644
--- a/Git/Types.hs
+++ b/Git/Types.hs
@@ -34,8 +34,8 @@ data Repo = Repo
, config :: M.Map String String
-- a given git config key can actually have multiple values
, fullconfig :: M.Map String [String]
- , remotes :: [Repo]
- -- remoteName holds the name used for this repo in remotes
+ -- remoteName holds the name used for this repo in some other
+ -- repo's list of remotes, when this repo is such a remote
, remoteName :: Maybe RemoteName
-- alternate environment to use when running git commands
, gitEnv :: Maybe [(String, String)]
diff --git a/Logs/File.hs b/Logs/File.hs
new file mode 100644
index 0000000..6676dbb
--- /dev/null
+++ b/Logs/File.hs
@@ -0,0 +1,27 @@
+{- git-annex log files
+ -
+ - Copyright 2018 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Logs.File where
+
+import Annex.Common
+import Annex.Perms
+import Utility.Tmp
+
+-- | Writes content to a file, replacing the file atomically, and
+-- making the new file have whatever permissions the git repository is
+-- configured to use. Creates the parent directory when necessary.
+writeLogFile :: FilePath -> String -> Annex ()
+writeLogFile f c = go `catchNonAsync` \_e -> do
+ -- Most of the time, the directory will exist, so this is only
+ -- done if writing the file fails.
+ createAnnexDirectory (parentDir f)
+ go
+ where
+ go = viaTmp writelog f c
+ writelog f' c' = do
+ liftIO $ writeFile f' c'
+ setAnnexFilePerm f'
diff --git a/Logs/FsckResults.hs b/Logs/FsckResults.hs
index 09430e8..296847f 100644
--- a/Logs/FsckResults.hs
+++ b/Logs/FsckResults.hs
@@ -12,25 +12,22 @@ module Logs.FsckResults (
) where
import Annex.Common
-import Utility.Tmp
import Git.Fsck
import Git.Types
+import Logs.File
import qualified Data.Set as S
writeFsckResults :: UUID -> FsckResults -> Annex ()
writeFsckResults u fsckresults = do
logfile <- fromRepo $ gitAnnexFsckResultsLog u
- liftIO $
- case fsckresults of
- FsckFailed -> store S.empty False logfile
- FsckFoundMissing s t
- | S.null s -> nukeFile logfile
- | otherwise -> store s t logfile
+ case fsckresults of
+ FsckFailed -> store S.empty False logfile
+ FsckFoundMissing s t
+ | S.null s -> liftIO $ nukeFile logfile
+ | otherwise -> store s t logfile
where
- store s t logfile = do
- createDirectoryIfMissing True (parentDir logfile)
- liftIO $ viaTmp writeFile logfile $ serialize s t
+ store s t logfile = writeLogFile logfile $ serialize s t
serialize s t =
let ls = map fromRef (S.toList s)
in if t
diff --git a/Logs/Schedule.hs b/Logs/Schedule.hs
index aea0df2..1868e34 100644
--- a/Logs/Schedule.hs
+++ b/Logs/Schedule.hs
@@ -26,7 +26,7 @@ import Types.ScheduledActivity
import qualified Annex.Branch
import Logs
import Logs.UUIDBased
-import Utility.Tmp
+import Logs.File
scheduleSet :: UUID -> [ScheduledActivity] -> Annex ()
scheduleSet uuid@(UUID _) activities = do
@@ -67,5 +67,5 @@ getLastRunTimes = do
setLastRunTime :: ScheduledActivity -> LocalTime -> Annex ()
setLastRunTime activity lastrun = do
f <- fromRepo gitAnnexScheduleState
- liftIO . viaTmp writeFile f . show . M.insert activity lastrun
+ writeLogFile f . show . M.insert activity lastrun
=<< getLastRunTimes
diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs
index 3e90ae1..9413f70 100644
--- a/Logs/Transfer.hs
+++ b/Logs/Transfer.hs
@@ -19,6 +19,7 @@ import Utility.Percentage
import Utility.PID
import Annex.LockPool
import Logs.TimeStamp
+import Logs.File
import Data.Time.Clock
import Data.Time.Clock.POSIX
@@ -51,7 +52,7 @@ percentComplete (Transfer { transferKey = key }) info =
mkProgressUpdater :: Transfer -> TransferInfo -> Annex (MeterUpdate, FilePath, MVar Integer)
mkProgressUpdater t info = do
tfile <- fromRepo $ transferFile t
- _ <- tryNonAsync $ createAnnexDirectory $ takeDirectory tfile
+ _ <- tryNonAsync $ writeTransferInfoFile info tfile
mvar <- liftIO $ newMVar 0
return (liftIO . updater tfile mvar, tfile, mvar)
where
@@ -60,7 +61,7 @@ mkProgressUpdater t info = do
if newbytes - oldbytes >= mindelta
then do
let info' = info { bytesComplete = Just newbytes }
- _ <- tryIO $ writeTransferInfoFile info' tfile
+ _ <- tryIO $ updateTransferInfoFile info' tfile
return newbytes
else return oldbytes
{- The minimum change in bytesComplete that is worth
@@ -181,8 +182,7 @@ removeFailedTransfer t = do
recordFailedTransfer :: Transfer -> TransferInfo -> Annex ()
recordFailedTransfer t info = do
failedtfile <- fromRepo $ failedTransferFile t
- createAnnexDirectory $ takeDirectory failedtfile
- liftIO $ writeTransferInfoFile info failedtfile
+ writeTransferInfoFile info failedtfile
{- The transfer information file to use for a given Transfer. -}
transferFile :: Transfer -> Git.Repo -> FilePath
@@ -213,8 +213,13 @@ parseTransferFile file
where
bits = splitDirectories file
-writeTransferInfoFile :: TransferInfo -> FilePath -> IO ()
-writeTransferInfoFile info tfile = writeFile tfile $ writeTransferInfo info
+writeTransferInfoFile :: TransferInfo -> FilePath -> Annex ()
+writeTransferInfoFile info tfile = writeLogFile tfile $ writeTransferInfo info
+
+-- The file keeps whatever permissions it has, so should be used only
+-- after it's been created with the right perms by writeTransferInfoFile.
+updateTransferInfoFile :: TransferInfo -> FilePath -> IO ()
+updateTransferInfoFile info tfile = writeFile tfile $ writeTransferInfo info
{- File format is a header line containing the startedTime and any
- bytesComplete value. Followed by a newline and the associatedFile.
diff --git a/Logs/Unused.hs b/Logs/Unused.hs
index a2f4041..d76d19a 100644
--- a/Logs/Unused.hs
+++ b/Logs/Unused.hs
@@ -33,8 +33,8 @@ import Data.Time
import Annex.Common
import qualified Annex
-import Utility.Tmp
import Logs.TimeStamp
+import Logs.File
-- everything that is stored in the unused log
type UnusedLog = M.Map Key (Int, Maybe POSIXTime)
@@ -64,7 +64,7 @@ updateUnusedLog prefix m = do
writeUnusedLog :: FilePath -> UnusedLog -> Annex ()
writeUnusedLog prefix l = do
logfile <- fromRepo $ gitAnnexUnusedLog prefix
- liftIO $ viaTmp writeFile logfile $ unlines $ map format $ M.toList l
+ writeLogFile logfile $ unlines $ map format $ M.toList l
where
format (k, (i, Just t)) = show i ++ " " ++ key2file k ++ " " ++ show t
format (k, (i, Nothing)) = show i ++ " " ++ key2file k
diff --git a/Logs/View.hs b/Logs/View.hs
index 00bdb30..80bdcc2 100644
--- a/Logs/View.hs
+++ b/Logs/View.hs
@@ -26,7 +26,7 @@ import qualified Git
import qualified Git.Branch
import qualified Git.Ref
import Git.Types
-import Utility.Tmp
+import Logs.File
import qualified Data.Set as S
import Data.Char
@@ -39,7 +39,7 @@ setView v = do
writeViews :: [View] -> Annex ()
writeViews l = do
f <- fromRepo gitAnnexViewLog
- liftIO $ viaTmp writeFile f $ unlines $ map show l
+ writeLogFile f $ unlines $ map show l
removeView :: View -> Annex ()
removeView v = writeViews =<< filter (/= v) <$> recentViews
diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs
index 3270a1d..52ae5e1 100644
--- a/Remote/GCrypt.hs
+++ b/Remote/GCrypt.hs
@@ -182,7 +182,7 @@ gCryptSetup _ mu _ c gc = go $ M.lookup "gitrepo" c
(c', _encsetup) <- encryptionSetup c gc
let url = Git.GCrypt.urlPrefix ++ gitrepo
- rs <- fromRepo Git.remotes
+ rs <- Annex.getGitRemotes
case filter (\r -> Git.remoteName r == Just remotename) rs of
[] -> inRepo $ Git.Command.run
[ Param "remote", Param "add"
diff --git a/Remote/Git.hs b/Remote/Git.hs
index da2ecee..2cebcce 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -1,6 +1,6 @@
{- Standard git remotes.
-
- - Copyright 2011-2017 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2018 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -78,7 +78,7 @@ remote = RemoteType
list :: Bool -> Annex [Git.Repo]
list autoinit = do
c <- fromRepo Git.config
- rs <- mapM (tweakurl c) =<< fromRepo Git.remotes
+ rs <- mapM (tweakurl c) =<< Annex.getGitRemotes
mapM (configRead autoinit) rs
where
annexurl n = "remote." ++ n ++ ".annexurl"
@@ -104,8 +104,8 @@ gitSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> Remote
gitSetup Init mu _ c _ = do
let location = fromMaybe (giveup "Specify location=url") $
Url.parseURIRelaxed =<< M.lookup "location" c
- g <- Annex.gitRepo
- u <- case filter (\r -> Git.location r == Git.Url location) (Git.remotes g) of
+ rs <- Annex.getGitRemotes
+ u <- case filter (\r -> Git.location r == Git.Url location) rs of
[r] -> getRepoUUID r
[] -> giveup "could not find existing git remote with specified location"
_ -> giveup "found multiple git remotes with specified location"
@@ -123,7 +123,8 @@ gitSetup (Enable _) (Just u) _ c _ = do
gitSetup (Enable _) Nothing _ _ _ = error "unable to enable git remote with no specified uuid"
{- It's assumed to be cheap to read the config of non-URL remotes, so this is
- - done each time git-annex is run in a way that uses remotes.
+ - done each time git-annex is run in a way that uses remotes, unless
+ - annex-checkuuid is false.
-
- Conversely, the config of an URL remote is only read when there is no
- cached UUID value. -}
@@ -134,7 +135,9 @@ configRead autoinit r = do
annexignore <- liftIO $ getDynamicConfig (remoteAnnexIgnore gc)
case (repoCheap r, annexignore, u) of
(_, True, _) -> return r
- (True, _, _) -> tryGitConfigRead autoinit r
+ (True, _, _)
+ | remoteAnnexCheckUUID gc -> tryGitConfigRead autoinit r
+ | otherwise -> return r
(False, _, NoUUID) -> tryGitConfigRead autoinit r
_ -> return r
@@ -142,22 +145,24 @@ gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remot
gen r u c gc
| Git.GCrypt.isEncrypted r = Remote.GCrypt.chainGen r u c gc
| otherwise = case repoP2PAddress r of
- Nothing -> go <$> remoteCost gc defcst
+ Nothing -> do
+ duc <- mkDeferredUUIDCheck r u gc
+ go duc <$> remoteCost gc defcst
Just addr -> Remote.P2P.chainGen addr r u c gc
where
defcst = if repoCheap r then cheapRemoteCost else expensiveRemoteCost
- go cst = Just new
+ go duc cst = Just new
where
new = Remote
{ uuid = u
, cost = cst
, name = Git.repoDescribe r
- , storeKey = copyToRemote new
+ , storeKey = copyToRemote new duc
, retrieveKeyFile = copyFromRemote new
, retrieveKeyFileCheap = copyFromRemoteCheap new
- , removeKey = dropKey new
- , lockContent = Just (lockKey new)
- , checkPresent = inAnnex new
+ , removeKey = dropKey new duc
+ , lockContent = Just (lockKey new duc)
+ , checkPresent = inAnnex new duc
, checkPresentCheap = repoCheap r
, exportActions = exportUnsupported
, whereisKey = Nothing
@@ -263,10 +268,9 @@ tryGitConfigRead autoinit r
return r
store = observe $ \r' -> do
- g <- gitRepo
- let l = Git.remotes g
- let g' = g { Git.remotes = exchange l r' }
- Annex.changeState $ \s -> s { Annex.repo = g' }
+ l <- Annex.getGitRemotes
+ let rs = exchange l r'
+ Annex.changeState $ \s -> s { Annex.gitremotes = Just rs }
exchange [] _ = []
exchange (old:ls) new
@@ -323,8 +327,8 @@ tryGitConfigRead autoinit r
else []
{- Checks if a given remote has the content for a key in its annex. -}
-inAnnex :: Remote -> Key -> Annex Bool
-inAnnex rmt key
+inAnnex :: Remote -> DeferredUUIDCheck -> Key -> Annex Bool
+inAnnex rmt duc key
| Git.repoIsHttp r = checkhttp
| Git.repoIsUrl r = checkremote
| otherwise = checklocal
@@ -337,9 +341,12 @@ inAnnex rmt key
, giveup "not found"
)
checkremote = Ssh.inAnnex r key
- checklocal = guardUsable r (cantCheck r) $
- maybe (cantCheck r) return
- =<< onLocalFast rmt (Annex.Content.inAnnexSafe key)
+ checklocal = ifM duc
+ ( guardUsable r (cantCheck r) $
+ maybe (cantCheck r) return
+ =<< onLocalFast rmt (Annex.Content.inAnnexSafe key)
+ , cantCheck r
+ )
keyUrls :: Remote -> Key -> [String]
keyUrls r key = map tourl locs'
@@ -358,10 +365,10 @@ keyUrls r key = map tourl locs'
remoteconfig = gitconfig r
cfg = remoteGitConfig remoteconfig
-dropKey :: Remote -> Key -> Annex Bool
-dropKey r key
- | not $ Git.repoIsUrl (repo r) =
- guardUsable (repo r) (return False) $
+dropKey :: Remote -> DeferredUUIDCheck -> Key -> Annex Bool
+dropKey r duc key
+ | not $ Git.repoIsUrl (repo r) = ifM duc
+ ( guardUsable (repo r) (return False) $
commitOnCleanup r $ onLocalFast r $ do
ensureInitialized
whenM (Annex.Content.inAnnex key) $ do
@@ -370,13 +377,15 @@ dropKey r key
logStatus key InfoMissing
Annex.Content.saveState True
return True
+ , return False
+ )
| Git.repoIsHttp (repo r) = giveup "dropping from http remote not supported"
| otherwise = commitOnCleanup r $ Ssh.dropKey (repo r) key
-lockKey :: Remote -> Key -> (VerifiedCopy -> Annex r) -> Annex r
-lockKey r key callback
- | not $ Git.repoIsUrl (repo r) =
- guardUsable (repo r) failedlock $ do
+lockKey :: Remote -> DeferredUUIDCheck -> Key -> (VerifiedCopy -> Annex r) -> Annex r
+lockKey r duc key callback
+ | not $ Git.repoIsUrl (repo r) = ifM duc
+ ( guardUsable (repo r) failedlock $ do
inorigrepo <- Annex.makeRunner
-- Lock content from perspective of remote,
-- and then run the callback in the original
@@ -387,6 +396,8 @@ lockKey r key callback
( liftIO $ inorigrepo $ callback vc
, failedlock
)
+ , failedlock
+ )
| Git.repoIsSsh (repo r) = do
showLocking r
Just (cmd, params) <- Ssh.git_annex_shell ConsumeStdin
@@ -545,11 +556,13 @@ copyFromRemoteCheap _ _ _ _ = return False
#endif
{- Tries to copy a key's content to a remote's annex. -}
-copyToRemote :: Remote -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
-copyToRemote r key file meterupdate
- | not $ Git.repoIsUrl (repo r) =
- guardUsable (repo r) (return False) $ commitOnCleanup r $
+copyToRemote :: Remote -> DeferredUUIDCheck -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
+copyToRemote r duc key file meterupdate
+ | not $ Git.repoIsUrl (repo r) = ifM duc
+ ( guardUsable (repo r) (return False) $ commitOnCleanup r $
copylocal =<< Annex.Content.prepSendAnnex key
+ , return False
+ )
| Git.repoIsSsh (repo r) = commitOnCleanup r $
Annex.Content.sendAnnex key noop $ \object ->
withmeter object $ \p -> do
@@ -718,3 +731,26 @@ mkCopier remotewanthardlink rsyncparams = do
)
, return copier
)
+
+{- Normally the UUID is checked at startup, but annex-checkuuid config
+ - can prevent that. To avoid getting confused, a deferred
+ - check is done just before the repository is used. This returns False
+ - when the repository UUID is not as expected. -}
+type DeferredUUIDCheck = Annex Bool
+
+mkDeferredUUIDCheck :: Git.Repo -> UUID -> RemoteGitConfig -> Annex DeferredUUIDCheck
+mkDeferredUUIDCheck r u gc
+ | remoteAnnexCheckUUID gc = return (return True)
+ | otherwise = do
+ v <- liftIO newEmptyMVar
+ return $ ifM (liftIO $ isEmptyMVar v)
+ ( do
+ r' <- tryGitConfigRead False r
+ u' <- getRepoUUID r'
+ let ok = u' == u
+ void $ liftIO $ tryPutMVar v ok
+ unless ok $
+ warning $ Git.repoDescribe r ++ " is not the expected repository. The remote's annex-checkuuid configuration prevented noticing the change until now."
+ return ok
+ , liftIO $ readMVar v
+ )
diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs
index 79aebad..dfac615 100644
--- a/Remote/Rsync.hs
+++ b/Remote/Rsync.hs
@@ -38,7 +38,7 @@ import Utility.Metered
import Types.Transfer
import Types.Creds
import Annex.DirHashes
-import Utility.Tmp
+import Utility.Tmp.Dir
import Utility.SshHost
import qualified Data.Map as M
diff --git a/RemoteDaemon/Core.hs b/RemoteDaemon/Core.hs
index 399b155..b3cd34a 100644
--- a/RemoteDaemon/Core.hs
+++ b/RemoteDaemon/Core.hs
@@ -17,6 +17,7 @@ import RemoteDaemon.Transport
import qualified Git
import qualified Git.Types as Git
import qualified Git.CurrentRepo
+import qualified Git.Construct
import Utility.SimpleProtocol
import Utility.ThreadScheduler
import Config
@@ -137,8 +138,9 @@ runController ichan ochan = do
-- Generates a map with a transport for each supported remote in the git repo,
-- except those that have annex.sync = false
genRemoteMap :: TransportHandle -> TChan Emitted -> IO RemoteMap
-genRemoteMap h@(TransportHandle (LocalRepo g) _) ochan =
- M.fromList . catMaybes <$> mapM gen (Git.remotes g)
+genRemoteMap h@(TransportHandle (LocalRepo g) _) ochan = do
+ rs <- Git.Construct.fromRemotes g
+ M.fromList . catMaybes <$> mapM gen rs
where
gen r = do
gc <- atomically $ extractRemoteGitConfig g (Git.repoDescribe r)
diff --git a/Test.hs b/Test.hs
index 766a6ca..2f198a1 100644
--- a/Test.hs
+++ b/Test.hs
@@ -12,18 +12,6 @@ module Test where
import Types.Test
import Options.Applicative.Types
-#ifndef WITH_TESTSUITE
-
-import Options.Applicative (pure)
-
-optParser :: Parser ()
-optParser = pure ()
-
-runner :: Maybe (() -> IO ())
-runner = Nothing
-
-#else
-
import Test.Tasty
import Test.Tasty.Runners
import Test.Tasty.HUnit
@@ -88,13 +76,14 @@ import qualified Annex.Action
import qualified Logs.View
import qualified Utility.Path
import qualified Utility.FileMode
-import qualified Build.SysConfig
+import qualified BuildInfo
import qualified Utility.Format
import qualified Utility.Verifiable
import qualified Utility.Process
import qualified Utility.Misc
import qualified Utility.InodeCache
import qualified Utility.Env
+import qualified Utility.Env.Set
import qualified Utility.Matcher
import qualified Utility.Exception
import qualified Utility.Hash
@@ -103,7 +92,7 @@ import qualified Utility.Scheduled.QuickCheck
import qualified Utility.HumanTime
import qualified Utility.ThreadScheduler
import qualified Utility.Base64
-import qualified Utility.Tmp
+import qualified Utility.Tmp.Dir
import qualified Utility.FileSystemEncoding
import qualified Command.Uninit
import qualified CmdLine.GitAnnex as GitAnnex
@@ -142,7 +131,7 @@ runner = Just go
subenv = "GIT_ANNEX_TEST_SUBPROCESS"
runsubprocesstests opts Nothing = do
pp <- Annex.Path.programPath
- Utility.Env.setEnv subenv "1" True
+ Utility.Env.Set.setEnv subenv "1" True
ps <- getArgs
(Nothing, Nothing, Nothing, pid) <-createProcess (proc pp ps)
exitcode <- waitForProcess pid
@@ -368,7 +357,7 @@ test_log = intmpclonerepo $ do
git_annex "log" [annexedfile] @? "log failed"
test_import :: Assertion
-test_import = intmpclonerepo $ Utility.Tmp.withTmpDir "importtest" $ \importdir -> do
+test_import = intmpclonerepo $ Utility.Tmp.Dir.withTmpDir "importtest" $ \importdir -> do
(toimport1, importf1, imported1) <- mktoimport importdir "import1"
git_annex "import" [toimport1] @? "import failed"
annexed_present_imported imported1
@@ -1622,7 +1611,7 @@ test_rsync_remote = intmpclonerepo $ do
annexed_present annexedfile
test_bup_remote :: Assertion
-test_bup_remote = intmpclonerepo $ when Build.SysConfig.bup $ do
+test_bup_remote = intmpclonerepo $ when BuildInfo.bup $ do
dir <- absPath "dir" -- bup special remote needs an absolute path
createDirectory dir
git_annex "initremote" (words $ "foo type=bup encryption=none buprepo="++dir) @? "initremote failed"
@@ -1929,11 +1918,11 @@ ensuretmpdir = do
{- Prevent global git configs from affecting the test suite. -}
isolateGitConfig :: IO a -> IO a
-isolateGitConfig a = Utility.Tmp.withTmpDir "testhome" $ \tmphome -> do
+isolateGitConfig a = Utility.Tmp.Dir.withTmpDir "testhome" $ \tmphome -> do
tmphomeabs <- absPath tmphome
- Utility.Env.setEnv "HOME" tmphomeabs True
- Utility.Env.setEnv "XDG_CONFIG_HOME" tmphomeabs True
- Utility.Env.setEnv "GIT_CONFIG_NOSYSTEM" "1" True
+ Utility.Env.Set.setEnv "HOME" tmphomeabs True
+ Utility.Env.Set.setEnv "XDG_CONFIG_HOME" tmphomeabs True
+ Utility.Env.Set.setEnv "GIT_CONFIG_NOSYSTEM" "1" True
a
cleanup :: FilePath -> IO ()
@@ -1945,7 +1934,7 @@ cleanup dir = whenM (doesDirectoryExist dir) $ do
finalCleanup :: IO ()
finalCleanup = whenM (doesDirectoryExist tmpdir) $ do
- Utility.Misc.reapZombies
+ Annex.Action.reapZombies
Command.Uninit.prepareRemoveAnnexDir' tmpdir
catchIO (removeDirectoryRecursive tmpdir) $ \e -> do
print e
@@ -1953,7 +1942,7 @@ finalCleanup = whenM (doesDirectoryExist tmpdir) $ do
Utility.ThreadScheduler.threadDelaySeconds $
Utility.ThreadScheduler.Seconds 10
whenM (doesDirectoryExist tmpdir) $ do
- Utility.Misc.reapZombies
+ Annex.Action.reapZombies
removeDirectoryRecursive tmpdir
checklink :: FilePath -> Assertion
@@ -2119,7 +2108,7 @@ setTestMode testmode = do
currdir <- getCurrentDirectory
p <- Utility.Env.getEnvDefault "PATH" ""
- mapM_ (\(var, val) -> Utility.Env.setEnv var val True)
+ mapM_ (\(var, val) -> Utility.Env.Set.setEnv var val True)
-- Ensure that the just-built git annex is used.
[ ("PATH", currdir ++ [searchPathSeparator] ++ p)
, ("TOPDIR", currdir)
@@ -2235,5 +2224,3 @@ getKey b f = fromJust <$> annexeval go
, Types.KeySource.contentLocation = f
, Types.KeySource.inodeCache = Nothing
}
-
-#endif
diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs
index 9a48ad1..ad22dad 100644
--- a/Types/GitConfig.hs
+++ b/Types/GitConfig.hs
@@ -199,6 +199,7 @@ data RemoteGitConfig = RemoteGitConfig
, remoteAnnexPush :: Bool
, remoteAnnexReadOnly :: Bool
, remoteAnnexVerify :: Bool
+ , remoteAnnexCheckUUID :: Bool
, remoteAnnexExportTracking :: Maybe Git.Ref
, remoteAnnexTrustLevel :: Maybe String
, remoteAnnexStartCommand :: Maybe String
@@ -247,6 +248,7 @@ extractRemoteGitConfig r remotename = do
, remoteAnnexPull = getbool "pull" True
, remoteAnnexPush = getbool "push" True
, remoteAnnexReadOnly = getbool "readonly" False
+ , remoteAnnexCheckUUID = getbool "checkuuid" True
, remoteAnnexVerify = getbool "verify" True
, remoteAnnexExportTracking = Git.Ref
<$> notempty (getmaybe "export-tracking")
diff --git a/Types/Test.hs b/Types/Test.hs
index 66f263c..50c460f 100644
--- a/Types/Test.hs
+++ b/Types/Test.hs
@@ -5,18 +5,13 @@
- Licensed under the GNU GPL version 3 or higher.
-}
-{-# LANGUAGE CPP #-}
-
module Types.Test where
-#ifdef WITH_TESTSUITE
import Test.Tasty.Options
import Data.Monoid
import Prelude
import Types.Command
-#endif
-#ifdef WITH_TESTSUITE
data TestOptions = TestOptions
{ tastyOptionSet :: OptionSet
, keepFailuresOption :: Bool
@@ -32,8 +27,5 @@ instance Monoid TestOptions where
(fakeSsh a || fakeSsh b)
(internalData a <> internalData b)
-#else
-type TestOptions = ()
-#endif
type TestRunner = TestOptions -> IO ()
diff --git a/Utility/CopyFile.hs b/Utility/CopyFile.hs
index 01c6005..4ad85b7 100644
--- a/Utility/CopyFile.hs
+++ b/Utility/CopyFile.hs
@@ -14,7 +14,7 @@ module Utility.CopyFile (
) where
import Common
-import qualified Build.SysConfig as SysConfig
+import qualified BuildInfo
data CopyMetaData
-- Copy timestamps when possible, but no other metadata, and
@@ -34,11 +34,11 @@ copyFileExternal meta src dest = do
where
#ifndef __ANDROID__
params = map snd $ filter fst
- [ (SysConfig.cp_reflink_auto, Param "--reflink=auto")
- , (allmeta && SysConfig.cp_a, Param "-a")
- , (allmeta && SysConfig.cp_p && not SysConfig.cp_a
+ [ (BuildInfo.cp_reflink_auto, Param "--reflink=auto")
+ , (allmeta && BuildInfo.cp_a, Param "-a")
+ , (allmeta && BuildInfo.cp_p && not BuildInfo.cp_a
, Param "-p")
- , (not allmeta && SysConfig.cp_preserve_timestamps
+ , (not allmeta && BuildInfo.cp_preserve_timestamps
, Param "--preserve=timestamps")
]
#else
diff --git a/Utility/Directory.hs b/Utility/Directory.hs
index 895581d..e2c6a94 100644
--- a/Utility/Directory.hs
+++ b/Utility/Directory.hs
@@ -18,15 +18,11 @@ import Control.Monad
import System.FilePath
import System.PosixCompat.Files
import Control.Applicative
-import Control.Concurrent
import System.IO.Unsafe (unsafeInterleaveIO)
import Data.Maybe
import Prelude
-#ifdef mingw32_HOST_OS
-import qualified System.Win32 as Win32
-#else
-import qualified System.Posix as Posix
+#ifndef mingw32_HOST_OS
import Utility.SafeCommand
import Control.Monad.IfElse
#endif
@@ -158,90 +154,3 @@ nukeFile file = void $ tryWhenExists go
#else
go = removeFile file
#endif
-
-#ifndef mingw32_HOST_OS
-data DirectoryHandle = DirectoryHandle IsOpen Posix.DirStream
-#else
-data DirectoryHandle = DirectoryHandle IsOpen Win32.HANDLE Win32.FindData (MVar ())
-#endif
-
-type IsOpen = MVar () -- full when the handle is open
-
-openDirectory :: FilePath -> IO DirectoryHandle
-openDirectory path = do
-#ifndef mingw32_HOST_OS
- dirp <- Posix.openDirStream path
- isopen <- newMVar ()
- return (DirectoryHandle isopen dirp)
-#else
- (h, fdat) <- Win32.findFirstFile (path </> "*")
- -- Indicate that the fdat contains a filename that readDirectory
- -- has not yet returned, by making the MVar be full.
- -- (There's always at least a "." entry.)
- alreadyhave <- newMVar ()
- isopen <- newMVar ()
- return (DirectoryHandle isopen h fdat alreadyhave)
-#endif
-
-closeDirectory :: DirectoryHandle -> IO ()
-#ifndef mingw32_HOST_OS
-closeDirectory (DirectoryHandle isopen dirp) =
- whenOpen isopen $
- Posix.closeDirStream dirp
-#else
-closeDirectory (DirectoryHandle isopen h _ alreadyhave) =
- whenOpen isopen $ do
- _ <- tryTakeMVar alreadyhave
- Win32.findClose h
-#endif
- where
- whenOpen :: IsOpen -> IO () -> IO ()
- whenOpen mv f = do
- v <- tryTakeMVar mv
- when (isJust v) f
-
-{- |Reads the next entry from the handle. Once the end of the directory
-is reached, returns Nothing and automatically closes the handle.
--}
-readDirectory :: DirectoryHandle -> IO (Maybe FilePath)
-#ifndef mingw32_HOST_OS
-readDirectory hdl@(DirectoryHandle _ dirp) = do
- e <- Posix.readDirStream dirp
- if null e
- then do
- closeDirectory hdl
- return Nothing
- else return (Just e)
-#else
-readDirectory hdl@(DirectoryHandle _ h fdat mv) = do
- -- If the MVar is full, then the filename in fdat has
- -- not yet been returned. Otherwise, need to find the next
- -- file.
- r <- tryTakeMVar mv
- case r of
- Just () -> getfn
- Nothing -> do
- more <- Win32.findNextFile h fdat
- if more
- then getfn
- else do
- closeDirectory hdl
- return Nothing
- where
- getfn = do
- filename <- Win32.getFindDataFileName fdat
- return (Just filename)
-#endif
-
--- True only when directory exists and contains nothing.
--- Throws exception if directory does not exist.
-isDirectoryEmpty :: FilePath -> IO Bool
-isDirectoryEmpty d = bracket (openDirectory d) closeDirectory check
- where
- check h = do
- v <- readDirectory h
- case v of
- Nothing -> return True
- Just f
- | not (dirCruft f) -> return False
- | otherwise -> check h
diff --git a/Utility/Directory/Stream.hs b/Utility/Directory/Stream.hs
new file mode 100644
index 0000000..ac62263
--- /dev/null
+++ b/Utility/Directory/Stream.hs
@@ -0,0 +1,113 @@
+{- streaming directory traversal
+ -
+ - Copyright 2011-2014 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
+module Utility.Directory.Stream where
+
+import Control.Monad
+import System.FilePath
+import Control.Concurrent
+import Data.Maybe
+import Prelude
+
+#ifdef mingw32_HOST_OS
+import qualified System.Win32 as Win32
+#else
+import qualified System.Posix as Posix
+#endif
+
+import Utility.Directory
+import Utility.Exception
+
+#ifndef mingw32_HOST_OS
+data DirectoryHandle = DirectoryHandle IsOpen Posix.DirStream
+#else
+data DirectoryHandle = DirectoryHandle IsOpen Win32.HANDLE Win32.FindData (MVar ())
+#endif
+
+type IsOpen = MVar () -- full when the handle is open
+
+openDirectory :: FilePath -> IO DirectoryHandle
+openDirectory path = do
+#ifndef mingw32_HOST_OS
+ dirp <- Posix.openDirStream path
+ isopen <- newMVar ()
+ return (DirectoryHandle isopen dirp)
+#else
+ (h, fdat) <- Win32.findFirstFile (path </> "*")
+ -- Indicate that the fdat contains a filename that readDirectory
+ -- has not yet returned, by making the MVar be full.
+ -- (There's always at least a "." entry.)
+ alreadyhave <- newMVar ()
+ isopen <- newMVar ()
+ return (DirectoryHandle isopen h fdat alreadyhave)
+#endif
+
+closeDirectory :: DirectoryHandle -> IO ()
+#ifndef mingw32_HOST_OS
+closeDirectory (DirectoryHandle isopen dirp) =
+ whenOpen isopen $
+ Posix.closeDirStream dirp
+#else
+closeDirectory (DirectoryHandle isopen h _ alreadyhave) =
+ whenOpen isopen $ do
+ _ <- tryTakeMVar alreadyhave
+ Win32.findClose h
+#endif
+ where
+ whenOpen :: IsOpen -> IO () -> IO ()
+ whenOpen mv f = do
+ v <- tryTakeMVar mv
+ when (isJust v) f
+
+{- |Reads the next entry from the handle. Once the end of the directory
+is reached, returns Nothing and automatically closes the handle.
+-}
+readDirectory :: DirectoryHandle -> IO (Maybe FilePath)
+#ifndef mingw32_HOST_OS
+readDirectory hdl@(DirectoryHandle _ dirp) = do
+ e <- Posix.readDirStream dirp
+ if null e
+ then do
+ closeDirectory hdl
+ return Nothing
+ else return (Just e)
+#else
+readDirectory hdl@(DirectoryHandle _ h fdat mv) = do
+ -- If the MVar is full, then the filename in fdat has
+ -- not yet been returned. Otherwise, need to find the next
+ -- file.
+ r <- tryTakeMVar mv
+ case r of
+ Just () -> getfn
+ Nothing -> do
+ more <- Win32.findNextFile h fdat
+ if more
+ then getfn
+ else do
+ closeDirectory hdl
+ return Nothing
+ where
+ getfn = do
+ filename <- Win32.getFindDataFileName fdat
+ return (Just filename)
+#endif
+
+-- True only when directory exists and contains nothing.
+-- Throws exception if directory does not exist.
+isDirectoryEmpty :: FilePath -> IO Bool
+isDirectoryEmpty d = bracket (openDirectory d) closeDirectory check
+ where
+ check h = do
+ v <- readDirectory h
+ case v of
+ Nothing -> return True
+ Just f
+ | not (dirCruft f) -> return False
+ | otherwise -> check h
diff --git a/Utility/Env.hs b/Utility/Env.hs
index c56f4ec..dfebd98 100644
--- a/Utility/Env.hs
+++ b/Utility/Env.hs
@@ -16,7 +16,6 @@ import Control.Applicative
import Data.Maybe
import Prelude
import qualified System.Environment as E
-import qualified System.SetEnv
#else
import qualified System.Posix.Env as PE
#endif
@@ -42,29 +41,6 @@ getEnvironment = PE.getEnvironment
getEnvironment = E.getEnvironment
#endif
-{- Sets an environment variable. To overwrite an existing variable,
- - overwrite must be True.
- -
- - On Windows, setting a variable to "" unsets it. -}
-setEnv :: String -> String -> Bool -> IO ()
-#ifndef mingw32_HOST_OS
-setEnv var val overwrite = PE.setEnv var val overwrite
-#else
-setEnv var val True = System.SetEnv.setEnv var val
-setEnv var val False = do
- r <- getEnv var
- case r of
- Nothing -> setEnv var val True
- Just _ -> return ()
-#endif
-
-unsetEnv :: String -> IO ()
-#ifndef mingw32_HOST_OS
-unsetEnv = PE.unsetEnv
-#else
-unsetEnv = System.SetEnv.unsetEnv
-#endif
-
{- Adds the environment variable to the input environment. If already
- present in the list, removes the old value.
-
diff --git a/Utility/Env/Basic.hs b/Utility/Env/Basic.hs
new file mode 100644
index 0000000..38295be
--- /dev/null
+++ b/Utility/Env/Basic.hs
@@ -0,0 +1,22 @@
+{- portable environment variables, without any dependencies
+ -
+ - Copyright 2013 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
+module Utility.Env.Basic where
+
+import Utility.Exception
+import Control.Applicative
+import Data.Maybe
+import Prelude
+import qualified System.Environment as E
+
+getEnv :: String -> IO (Maybe String)
+getEnv = catchMaybeIO . E.getEnv
+
+getEnvDefault :: String -> String -> IO String
+getEnvDefault var fallback = fromMaybe fallback <$> getEnv var
diff --git a/Utility/Env/Set.hs b/Utility/Env/Set.hs
new file mode 100644
index 0000000..bd835e9
--- /dev/null
+++ b/Utility/Env/Set.hs
@@ -0,0 +1,41 @@
+{- portable environment variables
+ -
+ - Copyright 2013 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Utility.Env.Set where
+
+#ifdef mingw32_HOST_OS
+import qualified System.Environment as E
+import qualified System.SetEnv
+import Utility.Env
+#else
+import qualified System.Posix.Env as PE
+#endif
+
+{- Sets an environment variable. To overwrite an existing variable,
+ - overwrite must be True.
+ -
+ - On Windows, setting a variable to "" unsets it. -}
+setEnv :: String -> String -> Bool -> IO ()
+#ifndef mingw32_HOST_OS
+setEnv var val overwrite = PE.setEnv var val overwrite
+#else
+setEnv var val True = System.SetEnv.setEnv var val
+setEnv var val False = do
+ r <- getEnv var
+ case r of
+ Nothing -> setEnv var val True
+ Just _ -> return ()
+#endif
+
+unsetEnv :: String -> IO ()
+#ifndef mingw32_HOST_OS
+unsetEnv = PE.unsetEnv
+#else
+unsetEnv = System.SetEnv.unsetEnv
+#endif
diff --git a/Utility/Gpg.hs b/Utility/Gpg.hs
index 2ffb0ad..13bd581 100644
--- a/Utility/Gpg.hs
+++ b/Utility/Gpg.hs
@@ -10,13 +10,16 @@
module Utility.Gpg where
import Common
-import qualified Build.SysConfig as SysConfig
+import qualified BuildInfo
#ifndef mingw32_HOST_OS
import System.Posix.Types
-import qualified System.Posix.IO
+import System.Posix.IO
import Utility.Env
-#endif
+import Utility.Env.Set
+#else
import Utility.Tmp
+#endif
+import Utility.Tmp.Dir
import Utility.Format (decode_c)
import Control.Concurrent
@@ -35,7 +38,7 @@ newtype GpgCmd = GpgCmd { unGpgCmd :: String }
- command was found at configure time, use it, or otherwise, "gpg". -}
mkGpgCmd :: Maybe FilePath -> GpgCmd
mkGpgCmd (Just c) = GpgCmd c
-mkGpgCmd Nothing = GpgCmd (fromMaybe "gpg" SysConfig.gpg)
+mkGpgCmd Nothing = GpgCmd (fromMaybe "gpg" BuildInfo.gpg)
boolGpgCmd :: GpgCmd -> [CommandParam] -> IO Bool
boolGpgCmd (GpgCmd cmd) = boolSystem cmd
diff --git a/Utility/LogFile.hs b/Utility/LogFile.hs
index bc6d92c..4e08e9b 100644
--- a/Utility/LogFile.hs
+++ b/Utility/LogFile.hs
@@ -13,6 +13,7 @@ import Common
#ifndef mingw32_HOST_OS
import System.Posix.Types
+import System.Posix.IO
#endif
openLog :: FilePath -> IO Handle
diff --git a/Utility/Lsof.hs b/Utility/Lsof.hs
index e3ed709..7cab8d9 100644
--- a/Utility/Lsof.hs
+++ b/Utility/Lsof.hs
@@ -10,8 +10,8 @@
module Utility.Lsof where
import Common
-import Build.SysConfig as SysConfig
-import Utility.Env
+import BuildInfo
+import Utility.Env.Set
import System.Posix.Types
@@ -23,12 +23,12 @@ type CmdLine = String
data ProcessInfo = ProcessInfo ProcessID CmdLine
deriving (Show)
-{- lsof is not in PATH on all systems, so SysConfig may have the absolute
+{- lsof is not in PATH on all systems, so BuildInfo may have the absolute
- path where the program was found. Make sure at runtime that lsof is
- available, and if it's not in PATH, adjust PATH to contain it. -}
setup :: IO ()
setup = do
- let cmd = fromMaybe "lsof" SysConfig.lsof
+ let cmd = fromMaybe "lsof" BuildInfo.lsof
when (isAbsolute cmd) $ do
path <- getSearchPath
let path' = takeDirectory cmd : path
diff --git a/Utility/Misc.hs b/Utility/Misc.hs
index 2ae9928..48fcceb 100644
--- a/Utility/Misc.hs
+++ b/Utility/Misc.hs
@@ -5,7 +5,6 @@
- License: BSD-2-clause
-}
-{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Misc where
@@ -16,10 +15,6 @@ import Foreign
import Data.Char
import Data.List
import System.Exit
-#ifndef mingw32_HOST_OS
-import System.Posix.Process (getAnyProcessStatus)
-import Utility.Exception
-#endif
import Control.Applicative
import Prelude
@@ -112,22 +107,6 @@ hGetSomeString h sz = do
peekbytes :: Int -> Ptr Word8 -> IO [Word8]
peekbytes len buf = mapM (peekElemOff buf) [0..pred len]
-{- Reaps any zombie processes that may be hanging around.
- -
- - Warning: Not thread safe. Anything that was expecting to wait
- - on a process and get back an exit status is going to be confused
- - if this reap gets there first. -}
-reapZombies :: IO ()
-#ifndef mingw32_HOST_OS
-reapZombies =
- -- throws an exception when there are no child processes
- catchDefaultIO Nothing (getAnyProcessStatus False True)
- >>= maybe (return ()) (const reapZombies)
-
-#else
-reapZombies = return ()
-#endif
-
exitBool :: Bool -> IO a
exitBool False = exitFailure
exitBool True = exitSuccess
diff --git a/Utility/Path.hs b/Utility/Path.hs
index dc91ce5..f1302ae 100644
--- a/Utility/Path.hs
+++ b/Utility/Path.hs
@@ -5,7 +5,7 @@
- License: BSD-2-clause
-}
-{-# LANGUAGE PackageImports, CPP #-}
+{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Path where
@@ -17,13 +17,6 @@ import Data.Char
import Control.Applicative
import Prelude
-#ifdef mingw32_HOST_OS
-import qualified System.FilePath.Posix as Posix
-#else
-import System.Posix.Files
-import Utility.Exception
-#endif
-
import Utility.Monad
import Utility.UserInfo
import Utility.Directory
@@ -247,50 +240,6 @@ dotfile file
where
f = takeFileName file
-{- Converts a DOS style path to a msys2 style path. Only on Windows.
- - Any trailing '\' is preserved as a trailing '/'
- -
- - Taken from: http://sourceforge.net/p/msys2/wiki/MSYS2%20introduction/i
- -
- - The virtual filesystem contains:
- - /c, /d, ... mount points for Windows drives
- -}
-toMSYS2Path :: FilePath -> FilePath
-#ifndef mingw32_HOST_OS
-toMSYS2Path = id
-#else
-toMSYS2Path p
- | null drive = recombine parts
- | otherwise = recombine $ "/" : driveletter drive : parts
- where
- (drive, p') = splitDrive p
- parts = splitDirectories p'
- driveletter = map toLower . takeWhile (/= ':')
- recombine = fixtrailing . Posix.joinPath
- fixtrailing s
- | hasTrailingPathSeparator p = Posix.addTrailingPathSeparator s
- | otherwise = s
-#endif
-
-{- Maximum size to use for a file in a specified directory.
- -
- - Many systems have a 255 byte limit to the name of a file,
- - so that's taken as the max if the system has a larger limit, or has no
- - limit.
- -}
-fileNameLengthLimit :: FilePath -> IO Int
-#ifdef mingw32_HOST_OS
-fileNameLengthLimit _ = return 255
-#else
-fileNameLengthLimit dir = do
- -- getPathVar can fail due to statfs(2) overflow
- l <- catchDefaultIO 0 $
- fromIntegral <$> getPathVar dir FileNameLimit
- if l <= 0
- then return 255
- else return $ minimum [l, 255]
-#endif
-
{- Given a string that we'd like to use as the basis for FilePath, but that
- was provided by a third party and is not to be trusted, returns the closest
- sane FilePath.
diff --git a/Utility/Path/Max.hs b/Utility/Path/Max.hs
new file mode 100644
index 0000000..4a810e5
--- /dev/null
+++ b/Utility/Path/Max.hs
@@ -0,0 +1,40 @@
+{- path manipulation
+ -
+ - Copyright 2010-2014 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
+module Utility.Path.Max where
+
+import System.FilePath
+import Data.List
+import Control.Applicative
+import Prelude
+
+#ifndef mingw32_HOST_OS
+import Utility.Exception
+import System.Posix.Files
+#endif
+
+{- Maximum size to use for a file in a specified directory.
+ -
+ - Many systems have a 255 byte limit to the name of a file,
+ - so that's taken as the max if the system has a larger limit, or has no
+ - limit.
+ -}
+fileNameLengthLimit :: FilePath -> IO Int
+#ifdef mingw32_HOST_OS
+fileNameLengthLimit _ = return 255
+#else
+fileNameLengthLimit dir = do
+ -- getPathVar can fail due to statfs(2) overflow
+ l <- catchDefaultIO 0 $
+ fromIntegral <$> getPathVar dir FileNameLimit
+ if l <= 0
+ then return 255
+ else return $ minimum [l, 255]
+#endif
diff --git a/Utility/Process.hs b/Utility/Process.hs
index 6d981cb..ff454f7 100644
--- a/Utility/Process.hs
+++ b/Utility/Process.hs
@@ -24,8 +24,6 @@ module Utility.Process (
createProcessSuccess,
createProcessChecked,
createBackgroundProcess,
- processTranscript,
- processTranscript',
withHandle,
withIOHandles,
withOEHandles,
@@ -54,13 +52,6 @@ import System.Log.Logger
import Control.Concurrent
import qualified Control.Exception as E
import Control.Monad
-#ifndef mingw32_HOST_OS
-import qualified System.Posix.IO
-#else
-import Control.Applicative
-#endif
-import Data.Maybe
-import Prelude
type CreateProcessRunner = forall a. CreateProcess -> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO a) -> IO a
@@ -170,68 +161,6 @@ createProcessChecked checker p a = do
createBackgroundProcess :: CreateProcessRunner
createBackgroundProcess p a = a =<< createProcess p
--- | Runs a process, optionally feeding it some input, and
--- returns a transcript combining its stdout and stderr, and
--- whether it succeeded or failed.
-processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool)
-processTranscript cmd opts = processTranscript' (proc cmd opts)
-
-processTranscript' :: CreateProcess -> Maybe String -> IO (String, Bool)
-processTranscript' cp input = do
-#ifndef mingw32_HOST_OS
-{- This implementation interleves stdout and stderr in exactly the order
- - the process writes them. -}
- (readf, writef) <- System.Posix.IO.createPipe
- readh <- System.Posix.IO.fdToHandle readf
- writeh <- System.Posix.IO.fdToHandle writef
- p@(_, _, _, pid) <- createProcess $ cp
- { std_in = if isJust input then CreatePipe else Inherit
- , std_out = UseHandle writeh
- , std_err = UseHandle writeh
- }
- hClose writeh
-
- get <- mkreader readh
- writeinput input p
- transcript <- get
-
- ok <- checkSuccessProcess pid
- return (transcript, ok)
-#else
-{- This implementation for Windows puts stderr after stdout. -}
- p@(_, _, _, pid) <- createProcess $ cp
- { std_in = if isJust input then CreatePipe else Inherit
- , std_out = CreatePipe
- , std_err = CreatePipe
- }
-
- getout <- mkreader (stdoutHandle p)
- geterr <- mkreader (stderrHandle p)
- writeinput input p
- transcript <- (++) <$> getout <*> geterr
-
- ok <- checkSuccessProcess pid
- return (transcript, ok)
-#endif
- where
- mkreader h = do
- s <- hGetContents h
- v <- newEmptyMVar
- void $ forkIO $ do
- void $ E.evaluate (length s)
- putMVar v ()
- return $ do
- takeMVar v
- return s
-
- writeinput (Just s) p = do
- let inh = stdinHandle p
- unless (null s) $ do
- hPutStr inh s
- hFlush inh
- hClose inh
- writeinput Nothing _ = return ()
-
-- | Runs a CreateProcessRunner, on a CreateProcess structure, that
-- is adjusted to pipe only from/to a single StdHandle, and passes
-- the resulting Handle to an action.
diff --git a/Utility/Process/Transcript.hs b/Utility/Process/Transcript.hs
new file mode 100644
index 0000000..0dbe428
--- /dev/null
+++ b/Utility/Process/Transcript.hs
@@ -0,0 +1,87 @@
+{- Process transcript
+ -
+ - Copyright 2012-2015 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
+module Utility.Process.Transcript where
+
+import Utility.Process
+
+import System.IO
+import Control.Concurrent
+import qualified Control.Exception as E
+import Control.Monad
+#ifndef mingw32_HOST_OS
+import qualified System.Posix.IO
+#else
+import Control.Applicative
+#endif
+import Data.Maybe
+import Prelude
+
+-- | Runs a process, optionally feeding it some input, and
+-- returns a transcript combining its stdout and stderr, and
+-- whether it succeeded or failed.
+processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool)
+processTranscript cmd opts = processTranscript' (proc cmd opts)
+
+processTranscript' :: CreateProcess -> Maybe String -> IO (String, Bool)
+processTranscript' cp input = do
+#ifndef mingw32_HOST_OS
+{- This implementation interleves stdout and stderr in exactly the order
+ - the process writes them. -}
+ (readf, writef) <- System.Posix.IO.createPipe
+ readh <- System.Posix.IO.fdToHandle readf
+ writeh <- System.Posix.IO.fdToHandle writef
+ p@(_, _, _, pid) <- createProcess $ cp
+ { std_in = if isJust input then CreatePipe else Inherit
+ , std_out = UseHandle writeh
+ , std_err = UseHandle writeh
+ }
+ hClose writeh
+
+ get <- mkreader readh
+ writeinput input p
+ transcript <- get
+
+ ok <- checkSuccessProcess pid
+ return (transcript, ok)
+#else
+{- This implementation for Windows puts stderr after stdout. -}
+ p@(_, _, _, pid) <- createProcess $ cp
+ { std_in = if isJust input then CreatePipe else Inherit
+ , std_out = CreatePipe
+ , std_err = CreatePipe
+ }
+
+ getout <- mkreader (stdoutHandle p)
+ geterr <- mkreader (stderrHandle p)
+ writeinput input p
+ transcript <- (++) <$> getout <*> geterr
+
+ ok <- checkSuccessProcess pid
+ return (transcript, ok)
+#endif
+ where
+ mkreader h = do
+ s <- hGetContents h
+ v <- newEmptyMVar
+ void $ forkIO $ do
+ void $ E.evaluate (length s)
+ putMVar v ()
+ return $ do
+ takeMVar v
+ return s
+
+ writeinput (Just s) p = do
+ let inh = stdinHandle p
+ unless (null s) $ do
+ hPutStr inh s
+ hFlush inh
+ hClose inh
+ writeinput Nothing _ = return ()
diff --git a/Utility/Rsync.hs b/Utility/Rsync.hs
index f190b40..25af526 100644
--- a/Utility/Rsync.hs
+++ b/Utility/Rsync.hs
@@ -13,6 +13,10 @@ import Common
import Utility.Metered
import Utility.Tuple
+#ifdef mingw32_HOST_OS
+import qualified System.FilePath.Posix as Posix
+#endif
+
import Data.Char
import System.Console.GetOpt
@@ -139,3 +143,29 @@ filterRsyncSafeOptions = fst3 . getOpt Permute
[ Option [] ["bwlimit"] (reqArgLong "bwlimit") "" ]
where
reqArgLong x = ReqArg (\v -> "--" ++ x ++ "=" ++ v) ""
+
+{- Converts a DOS style path to a msys2 style path. Only on Windows.
+ - Any trailing '\' is preserved as a trailing '/'
+ -
+ - Taken from: http://sourceforge.net/p/msys2/wiki/MSYS2%20introduction/i
+ -
+ - The virtual filesystem contains:
+ - /c, /d, ... mount points for Windows drives
+ -}
+toMSYS2Path :: FilePath -> FilePath
+#ifndef mingw32_HOST_OS
+toMSYS2Path = id
+#else
+toMSYS2Path p
+ | null drive = recombine parts
+ | otherwise = recombine $ "/" : driveletter drive : parts
+ where
+ (drive, p') = splitDrive p
+ parts = splitDirectories p'
+ driveletter = map toLower . takeWhile (/= ':')
+ recombine = fixtrailing . Posix.joinPath
+ fixtrailing s
+ | hasTrailingPathSeparator p = Posix.addTrailingPathSeparator s
+ | otherwise = s
+#endif
+
diff --git a/Utility/Su.hs b/Utility/Su.hs
index 84ea4c5..a0500e4 100644
--- a/Utility/Su.hs
+++ b/Utility/Su.hs
@@ -13,6 +13,7 @@ import Common
#ifndef mingw32_HOST_OS
import Utility.Env
+import System.Posix.IO
import System.Posix.Terminal
#endif
diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs
index 7255c14..6e04b10 100644
--- a/Utility/Tmp.hs
+++ b/Utility/Tmp.hs
@@ -1,4 +1,4 @@
-{- Temporary files and directories.
+{- Temporary files.
-
- Copyright 2010-2013 Joey Hess <id@joeyh.name>
-
@@ -11,14 +11,10 @@
module Utility.Tmp where
import System.IO
-import Control.Monad.IfElse
import System.FilePath
import System.Directory
import Control.Monad.IO.Class
import System.PosixCompat.Files
-#ifndef mingw32_HOST_OS
-import System.Posix.Temp (mkdtemp)
-#endif
import Utility.Exception
import Utility.FileSystemEncoding
@@ -62,51 +58,6 @@ withTmpFileIn tmpdir template a = bracket create remove use
catchBoolIO (removeFile name >> return True)
use (name, h) = a name h
-{- Runs an action with a tmp directory located within the system's tmp
- - directory (or within "." if there is none), then removes the tmp
- - directory and all its contents. -}
-withTmpDir :: (MonadMask m, MonadIO m) => Template -> (FilePath -> m a) -> m a
-withTmpDir template a = do
- topleveltmpdir <- liftIO $ catchDefaultIO "." getTemporaryDirectory
-#ifndef mingw32_HOST_OS
- -- Use mkdtemp to create a temp directory securely in /tmp.
- bracket
- (liftIO $ mkdtemp $ topleveltmpdir </> template)
- removeTmpDir
- a
-#else
- withTmpDirIn topleveltmpdir template a
-#endif
-
-{- Runs an action with a tmp directory located within a specified directory,
- - then removes the tmp directory and all its contents. -}
-withTmpDirIn :: (MonadMask m, MonadIO m) => FilePath -> Template -> (FilePath -> m a) -> m a
-withTmpDirIn tmpdir template = bracketIO create removeTmpDir
- where
- create = do
- createDirectoryIfMissing True tmpdir
- makenewdir (tmpdir </> template) (0 :: Int)
- makenewdir t n = do
- let dir = t ++ "." ++ show n
- catchIOErrorType AlreadyExists (const $ makenewdir t $ n + 1) $ do
- createDirectory dir
- return dir
-
-{- Deletes the entire contents of the the temporary directory, if it
- - exists. -}
-removeTmpDir :: MonadIO m => FilePath -> m ()
-removeTmpDir tmpdir = liftIO $ whenM (doesDirectoryExist tmpdir) $ do
-#if mingw32_HOST_OS
- -- Windows will often refuse to delete a file
- -- after a process has just written to it and exited.
- -- Because it's crap, presumably. So, ignore failure
- -- to delete the temp directory.
- _ <- tryIO $ removeDirectoryRecursive tmpdir
- return ()
-#else
- removeDirectoryRecursive tmpdir
-#endif
-
{- It's not safe to use a FilePath of an existing file as the template
- for openTempFile, because if the FilePath is really long, the tmpfile
- will be longer, and may exceed the maximum filename length.
diff --git a/Utility/Tmp/Dir.hs b/Utility/Tmp/Dir.hs
new file mode 100644
index 0000000..ddf6ddb
--- /dev/null
+++ b/Utility/Tmp/Dir.hs
@@ -0,0 +1,68 @@
+{- Temporary directorie
+ -
+ - Copyright 2010-2013 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
+module Utility.Tmp.Dir where
+
+import Control.Monad.IfElse
+import System.FilePath
+import System.Directory
+import Control.Monad.IO.Class
+#ifndef mingw32_HOST_OS
+import System.Posix.Temp (mkdtemp)
+#endif
+
+import Utility.Exception
+
+type Template = String
+
+{- Runs an action with a tmp directory located within the system's tmp
+ - directory (or within "." if there is none), then removes the tmp
+ - directory and all its contents. -}
+withTmpDir :: (MonadMask m, MonadIO m) => Template -> (FilePath -> m a) -> m a
+withTmpDir template a = do
+ topleveltmpdir <- liftIO $ catchDefaultIO "." getTemporaryDirectory
+#ifndef mingw32_HOST_OS
+ -- Use mkdtemp to create a temp directory securely in /tmp.
+ bracket
+ (liftIO $ mkdtemp $ topleveltmpdir </> template)
+ removeTmpDir
+ a
+#else
+ withTmpDirIn topleveltmpdir template a
+#endif
+
+{- Runs an action with a tmp directory located within a specified directory,
+ - then removes the tmp directory and all its contents. -}
+withTmpDirIn :: (MonadMask m, MonadIO m) => FilePath -> Template -> (FilePath -> m a) -> m a
+withTmpDirIn tmpdir template = bracketIO create removeTmpDir
+ where
+ create = do
+ createDirectoryIfMissing True tmpdir
+ makenewdir (tmpdir </> template) (0 :: Int)
+ makenewdir t n = do
+ let dir = t ++ "." ++ show n
+ catchIOErrorType AlreadyExists (const $ makenewdir t $ n + 1) $ do
+ createDirectory dir
+ return dir
+
+{- Deletes the entire contents of the the temporary directory, if it
+ - exists. -}
+removeTmpDir :: MonadIO m => FilePath -> m ()
+removeTmpDir tmpdir = liftIO $ whenM (doesDirectoryExist tmpdir) $ do
+#if mingw32_HOST_OS
+ -- Windows will often refuse to delete a file
+ -- after a process has just written to it and exited.
+ -- Because it's crap, presumably. So, ignore failure
+ -- to delete the temp directory.
+ _ <- tryIO $ removeDirectoryRecursive tmpdir
+ return ()
+#else
+ removeDirectoryRecursive tmpdir
+#endif
diff --git a/Utility/Url.hs b/Utility/Url.hs
index 3ebbf41..ad595e3 100644
--- a/Utility/Url.hs
+++ b/Utility/Url.hs
@@ -32,8 +32,8 @@ module Utility.Url (
) where
import Common
-import Utility.Tmp
-import qualified Build.SysConfig
+import Utility.Tmp.Dir
+import qualified BuildInfo
import Network.URI
import Network.HTTP.Types
@@ -163,7 +163,7 @@ getUrlInfo url uo = case parseURIRelaxed url of
sz <- getFileSize' f stat
found (Just sz) Nothing
Nothing -> dne
- | Build.SysConfig.curl -> existscurl u
+ | BuildInfo.curl -> existscurl u
| otherwise -> dne
Nothing -> dne
where
@@ -281,7 +281,7 @@ download' quiet url file uo = do
-}
#ifndef __ANDROID__
wgetparams = concat
- [ if Build.SysConfig.wgetunclutter && not quiet
+ [ if BuildInfo.wgetunclutter && not quiet
then [Param "-nv", Param "--show-progress"]
else []
, [ Param "--clobber", Param "-c", Param "-O"]
diff --git a/Utility/UserInfo.hs b/Utility/UserInfo.hs
index d504fa5..694bbe6 100644
--- a/Utility/UserInfo.hs
+++ b/Utility/UserInfo.hs
@@ -14,7 +14,7 @@ module Utility.UserInfo (
myUserGecos,
) where
-import Utility.Env
+import Utility.Env.Basic
import Utility.Exception
#ifndef mingw32_HOST_OS
import Utility.Data
diff --git a/doc/git-annex-export.mdwn b/doc/git-annex-export.mdwn
new file mode 100644
index 0000000..a8f9f5c
--- /dev/null
+++ b/doc/git-annex-export.mdwn
@@ -0,0 +1,118 @@
+# NAME
+
+git-annex export - export content to a remote
+
+# SYNOPSIS
+
+git annex export `treeish --to remote`
+
+git annex export `--tracking treeish --to remote`
+
+# DESCRIPTION
+
+Use this command to export a tree of files from a git-annex repository.
+
+Normally files are stored on a git-annex special remote named by their
+keys. That is great for reliable data storage, but your filenames are
+obscured. Exporting replicates the tree to the special remote as-is.
+
+Mixing key/value storage and exports in the same remote would be a mess and
+so is not allowed. You have to configure a special remote with
+`exporttree=yes` when initially setting it up with
+[[git-annex-initremote]](1).
+
+The treeish to export can be the name of a git branch, or a tag, or any
+other treeish accepted by git, including eg master:subdir to only export a
+subdirectory from a branch.
+
+Repeated exports are done efficiently, by diffing the old and new tree,
+and transferring only the changed files, and renaming files as necessary.
+
+Exports can be interrupted and resumed. However, partially uploaded files
+will be re-started from the beginning.
+
+Once content has been exported to a remote, commands like `git annex get`
+can download content from there the same as from other remotes. However,
+since an export is not a key/value store, git-annex has to do more
+verification of content downloaded from an export. Some types of keys,
+that are not based on checksums, cannot be downloaded from an export.
+And, git-annex will never trust an export to retain the content of a key.
+
+# OPTIONS
+
+* `--to=remote`
+
+ Specify the special remote to export to.
+
+* `--tracking`
+
+ This makes the export track changes that are committed to
+ the branch. `git annex sync --content` and the git-annex assistant
+ will update exports when it commits to the branch they are tracking.
+
+* `--fast`
+
+ This sets up an export of a tree, but avoids any expensive file uploads to
+ the remote. You can later run `git annex sync --content` to upload
+ the files to the export.
+
+# EXAMPLE
+
+ git annex initremote myexport type=directory directory=/mnt/myexport \
+ exporttree=yes encryption=none
+ git annex export master --to myexport
+
+After that, /mnt/myexport will contain the same tree of files as the master
+branch does.
+
+ git mv myfile subdir/myfile
+ git commit -m renamed
+ git annex export master --to myexport
+
+That updates /mnt/myexport to reflect the renamed file.
+
+ git annex export master:subdir --to myexport
+
+That updates /mnt/myexport, to contain only the files in the "subdir"
+directory of the master branch.
+
+ git annex export --tracking master --to myexport
+
+That makes myexport track changes that are committed to the master branch.
+
+# EXPORT CONFLICTS
+
+If two different git-annex repositories are both exporting different trees
+to the same special remote, it's possible for an export conflict to occur.
+This leaves the special remote with some files from one tree, and some
+files from the other. Files in the special remote may have entirely the
+wrong content as well.
+
+It's not possible for git-annex to detect when making an export will result
+in an export conflict. The best way to avoid export conflicts is to either
+only ever export to a special remote from a single repository, or to have a
+rule about the tree that you export to the special remote. For example, if
+you always export origin/master after pushing to origin, then an export
+conflict can't happen.
+
+An export conflict can only be detected after the two git repositories
+that produced it get back in sync. Then the next time you run `git annex
+export`, it will detect the export conflict, and resolve it.
+
+# SEE ALSO
+
+[[git-annex]](1)
+
+[[git-annex-initremote]](1)
+
+[[git-annex-sync]](1)
+
+# HISTORY
+
+The `export` command was introduced in git-annex version 6.20170925.
+
+# AUTHOR
+
+Joey Hess <id@joeyh.name>
+
+Warning: Automatically converted into a man page by mdwn2man. Edit with care.
diff --git a/doc/git-annex-inprogress.mdwn b/doc/git-annex-inprogress.mdwn
new file mode 100644
index 0000000..1a595cb
--- /dev/null
+++ b/doc/git-annex-inprogress.mdwn
@@ -0,0 +1,53 @@
+# NAME
+
+git-annex inprogress - access files while they're being downloaded
+
+# SYNOPSIS
+
+git annex inprogress `[path ...]`
+
+# DESCRIPTION
+
+This command allows accessing the content of an annexed file while
+it is still being downloaded. It outputs to standard output the
+name of the temporary file that is being used to download the specified
+annexed file.
+
+This can sometimes be used to stream a file before it's been fully
+downloaded, for example:
+
+ git annex get video.mpeg &
+ vlc $(git annex inprogress video.mpeg)
+
+Of course if the file is downloading too slowly, the media player will
+reach the end too soon and not show the whole thing. And of course, only
+some file formats can be usefully streamed in this way.
+
+# OPTIONS
+
+* file matching options
+
+ The [[git-annex-matching-options]](1)
+ can be used to specify files to access.
+
+* `--all`
+
+ Rather than specifying a filename or path, this option can be
+ used to access all files that are currently being downloaded.
+
+# EXIT STATUS
+
+If any of the requested files are not currently being downloaded,
+the exit status will be 1.
+
+# SEE ALSO
+
+[[git-annex]](1)
+
+[[git-annex-get]](1)
+
+# AUTHOR
+
+Joey Hess <id@joeyh.name>
+
+Warning: Automatically converted into a man page by mdwn2man. Edit with care.
diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn
index 8f84f1d..f427d94 100644
--- a/doc/git-annex.mdwn
+++ b/doc/git-annex.mdwn
@@ -461,6 +461,12 @@ subdirectories).
See [[git-annex-map]](1) for details.
+* `inprogress`
+
+ Access files while they're being downloaded.
+
+ See [[git-annex-inprogress]](1) for details.
+
# METADATA COMMANDS
* `metadata [path ...]`
@@ -1228,6 +1234,18 @@ Here are all the supported configuration settings.
git-annex caches UUIDs of remote repositories here.
+- `remote.<name>.annex-checkuuid`
+
+ This only affects remotes that have their url pointing to a directory on
+ the same system. git-annex normally checks the uuid of such
+ remotes each time it's run, which lets it transparently deal with
+ different drives being mounted to the location at different times.
+
+ Setting annex-checkuuid to false will prevent it from checking the uuid
+ at startup (although the uuid is still verified before making any
+ changes to the remote repository). This may be useful to set to prevent
+ unncessary spin-up or automounting of a drive.
+
* `remote.<name>.annex-trustlevel`
Configures a local trust level for the remote. This overrides the value
diff --git a/git-annex.cabal b/git-annex.cabal
index a030a5a..5c03fac 100644
--- a/git-annex.cabal
+++ b/git-annex.cabal
@@ -1,5 +1,5 @@
Name: git-annex
-Version: 6.20171214
+Version: 6.20180112
Cabal-Version: >= 1.8
License: GPL-3
Maintainer: Joey Hess <id@joeyh.name>
@@ -62,6 +62,7 @@ Extra-Source-Files:
doc/git-annex-enable-tor.mdwn
doc/git-annex-examinekey.mdwn
doc/git-annex-expire.mdwn
+ doc/git-annex-export.mdwn
doc/git-annex-find.mdwn
doc/git-annex-findref.mdwn
doc/git-annex-fix.mdwn
@@ -78,6 +79,7 @@ Extra-Source-Files:
doc/git-annex-info.mdwn
doc/git-annex-init.mdwn
doc/git-annex-initremote.mdwn
+ doc/git-annex-inprogress.mdwn
doc/git-annex-list.mdwn
doc/git-annex-lock.mdwn
doc/git-annex-log.mdwn
@@ -276,9 +278,6 @@ Flag AndroidSplice
Description: Building to get TH splices for Android
Default: False
-Flag TestSuite
- Description: Embed the test suite into git-annex
-
Flag TorrentParser
Description: Use haskell torrent library to parse torrent files
@@ -303,6 +302,11 @@ source-repository head
type: git
location: git://git-annex.branchable.com/
+custom-setup
+ Setup-Depends: base (>= 4.6), hslogger, split, unix-compat, process,
+ filepath, exceptions, bytestring, directory, IfElse, data-default,
+ utf8-string, Cabal
+
Executable git-annex
Main-Is: git-annex.hs
Build-Depends:
@@ -310,7 +314,6 @@ Executable git-annex
optparse-applicative (>= 0.11.0),
containers (>= 0.5.0.0),
exceptions (>= 0.6),
- QuickCheck (>= 2.1),
stm (>= 2.3),
mtl (>= 2),
uuid (>= 1.2.6),
@@ -358,7 +361,12 @@ Executable git-annex
crypto-api,
cryptonite,
memory,
- split
+ split,
+ QuickCheck (>= 2.1),
+ tasty (>= 0.7),
+ tasty-hunit,
+ tasty-quickcheck,
+ tasty-rerun
CC-Options: -Wall
GHC-Options: -Wall -fno-warn-tabs
Extensions: PackageImports, LambdaCase
@@ -391,10 +399,6 @@ Executable git-annex
if impl(ghc <= 7.6.3)
Other-Modules: Utility.Touch.Old
- if flag(TestSuite)
- Build-Depends: tasty (>= 0.7), tasty-hunit, tasty-quickcheck, tasty-rerun
- CPP-Options: -DWITH_TESTSUITE
-
if flag(S3)
Build-Depends: conduit, conduit-extra, aws (>= 0.9.2)
CPP-Options: -DWITH_S3
@@ -662,6 +666,7 @@ Executable git-annex
Build.TestConfig
Build.Version
BuildInfo
+ BuildFlags
CmdLine
CmdLine.Action
CmdLine.Batch
@@ -719,6 +724,7 @@ Executable git-annex
Command.Info
Command.Init
Command.InitRemote
+ Command.Inprogress
Command.List
Command.Lock
Command.LockContent
@@ -854,6 +860,7 @@ Executable git-annex
Logs.Difference
Logs.Difference.Pure
Logs.Export
+ Logs.File
Logs.FsckResults
Logs.Group
Logs.Line
@@ -987,10 +994,13 @@ Executable git-annex
Utility.DirWatcher
Utility.DirWatcher.Types
Utility.Directory
+ Utility.Directory.Stream
Utility.DiskFree
Utility.Dot
Utility.DottedVersion
Utility.Env
+ Utility.Env.Basic
+ Utility.Env.Set
Utility.Exception
Utility.ExternalSHA
Utility.FileMode
@@ -1029,9 +1039,11 @@ Executable git-annex
Utility.Parallel
Utility.PartialPrelude
Utility.Path
+ Utility.Path.Max
Utility.Percentage
Utility.Process
Utility.Process.Shim
+ Utility.Process.Transcript
Utility.QuickCheck
Utility.Rsync
Utility.SRV
@@ -1050,6 +1062,7 @@ Executable git-annex
Utility.ThreadLock
Utility.ThreadScheduler
Utility.Tmp
+ Utility.Tmp.Dir
Utility.Tor
Utility.Touch
Utility.Tuple
diff --git a/git-annex.hs b/git-annex.hs
index e30d320..e9e8e7b 100644
--- a/git-annex.hs
+++ b/git-annex.hs
@@ -19,7 +19,7 @@ import Utility.FileSystemEncoding
#ifdef mingw32_HOST_OS
import Utility.UserInfo
-import Utility.Env
+import Utility.Env.Set
#endif
main :: IO ()
diff --git a/stack.yaml b/stack.yaml
index e82bc2b..64e1081 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -6,7 +6,6 @@ flags:
pairing: true
network-uri: true
s3: true
- testsuite: true
webdav: true
torrentparser: true
webapp: true