summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Annex/Environment.hs6
-rw-r--r--Annex/Index.hs37
-rw-r--r--Annex/Init.hs19
-rw-r--r--Annex/Ssh.hs146
-rw-r--r--Annex/UUID.hs12
-rw-r--r--Annex/View.hs2
-rw-r--r--Assistant.hs2
-rw-r--r--Assistant/Alert.hs25
-rw-r--r--Assistant/DaemonStatus.hs10
-rw-r--r--Assistant/Install.hs37
-rw-r--r--Assistant/Monad.hs3
-rw-r--r--Assistant/RemoteControl.hs21
-rw-r--r--Assistant/Sync.hs2
-rw-r--r--Assistant/Threads/NetWatcher.hs86
-rw-r--r--Assistant/Threads/RemoteControl.hs122
-rw-r--r--Assistant/Threads/TransferScanner.hs2
-rw-r--r--Assistant/Threads/Watcher.hs2
-rw-r--r--Assistant/Threads/XMPPClient.hs19
-rw-r--r--Assistant/Types/Alert.hs4
-rw-r--r--Assistant/Types/DaemonStatus.hs3
-rw-r--r--Assistant/Types/RemoteControl.hs16
-rw-r--r--Assistant/WebApp/Configurators.hs10
-rw-r--r--Assistant/WebApp/Configurators/Delete.hs12
-rw-r--r--Assistant/WebApp/Configurators/Edit.hs25
-rw-r--r--Assistant/WebApp/Configurators/Local.hs1
-rw-r--r--Assistant/WebApp/Configurators/Pairing.hs1
-rw-r--r--Assistant/WebApp/Configurators/Ssh.hs65
-rw-r--r--Assistant/WebApp/Configurators/XMPP.hs37
-rw-r--r--Assistant/WebApp/MakeRemote.hs14
-rw-r--r--Assistant/WebApp/RepoList.hs15
-rw-r--r--Assistant/WebApp/SideBar.hs3
-rw-r--r--Assistant/WebApp/routes2
-rw-r--r--Assistant/XMPP/Git.hs2
-rw-r--r--Backend.hs24
-rw-r--r--Build/Configure.hs5
-rw-r--r--Build/DistributionUpdate.hs26
-rw-r--r--CHANGELOG42
-rw-r--r--CmdLine/GitAnnex.hs11
-rw-r--r--CmdLine/Seek.hs16
-rw-r--r--CmdLine/Usage.hs2
-rw-r--r--Command.hs6
-rw-r--r--Command/Add.hs2
-rw-r--r--Command/AddUrl.hs4
-rw-r--r--Command/Copy.hs6
-rw-r--r--Command/Direct.hs2
-rw-r--r--Command/Drop.hs16
-rw-r--r--Command/Find.hs10
-rw-r--r--Command/FindRef.hs20
-rw-r--r--Command/Fix.hs4
-rw-r--r--Command/Fsck.hs16
-rw-r--r--Command/Get.hs4
-rw-r--r--Command/ImportFeed.hs6
-rw-r--r--Command/Indirect.hs2
-rw-r--r--Command/Info.hs2
-rw-r--r--Command/List.hs4
-rw-r--r--Command/Log.hs12
-rw-r--r--Command/MetaData.hs4
-rw-r--r--Command/Migrate.hs22
-rw-r--r--Command/Mirror.hs4
-rw-r--r--Command/Move.hs4
-rw-r--r--Command/ReKey.hs2
-rw-r--r--Command/Reinit.hs38
-rw-r--r--Command/Reinject.hs23
-rw-r--r--Command/RmUrl.hs2
-rw-r--r--Command/Sync.hs19
-rw-r--r--Command/Unannex.hs15
-rw-r--r--Command/Uninit.hs4
-rw-r--r--Command/Unlock.hs4
-rw-r--r--Command/Unused.hs4
-rw-r--r--Command/WebApp.hs21
-rw-r--r--Command/Whereis.hs4
-rw-r--r--Common.hs1
-rw-r--r--Creds.hs7
-rw-r--r--Git/GCrypt.hs5
-rw-r--r--Git/Types.hs1
-rw-r--r--Limit.hs9
-rw-r--r--Makefile2
-rw-r--r--Remote.hs17
-rw-r--r--Remote/Git.hs4
-rw-r--r--Remote/Helper/Ssh.hs19
-rw-r--r--RemoteDaemon/Common.hs2
-rw-r--r--RemoteDaemon/Core.hs35
-rw-r--r--RemoteDaemon/Transport.hs2
-rw-r--r--RemoteDaemon/Transport/Ssh.hs126
-rw-r--r--RemoteDaemon/Types.hs38
-rw-r--r--Test.hs13
-rw-r--r--Types/UUID.hs5
-rw-r--r--Utility/Process.hs4
-rw-r--r--Utility/Scheduled.hs70
-rw-r--r--Utility/URI.hs18
-rw-r--r--debian/changelog42
-rw-r--r--debian/control1
-rw-r--r--doc/bugs/Android___91__Terminal_session_finished__93__.mdwn33
-rw-r--r--doc/bugs/Drop_--from_always_trusts_local_repository.mdwn46
-rw-r--r--doc/bugs/git-annex_branch_shows_commit_with_looong_commitlog.mdwn72
-rw-r--r--doc/bugs/protocol_mismatch_after_interrupt.mdwn31
-rw-r--r--doc/design/assistant/polls/Android_default_directory.mdwn2
-rw-r--r--doc/design/assistant/polls/prioritizing_special_remotes.mdwn2
-rw-r--r--doc/design/assistant/telehash.mdwn2
-rw-r--r--doc/design/git-remote-daemon.mdwn42
-rw-r--r--doc/devblog/day_133__db_and_bugfixes.mdwn2
-rw-r--r--doc/devblog/day_149__signal.mdwn4
-rw-r--r--doc/devblog/day_151__birthday_bug.mdwn18
-rw-r--r--doc/devblog/day_152__more_ssh_connection_caching.mdwn37
-rw-r--r--doc/devblog/day_153__remotedaemon_has_landed.mdwn10
-rw-r--r--doc/devblog/day_154__catching_up.mdwn13
-rw-r--r--doc/devblog/day_155__missing_bits.mdwn27
-rw-r--r--doc/encryption/comment_2_f19c9bb519a7017f0731fd0e8780ed74._comment22
-rw-r--r--doc/forum/Big_repository_vs._multiple_small.mdwn8
-rw-r--r--doc/forum/Corrupt_Repository_Invalid_Object.mdwn10
-rw-r--r--doc/forum/Starting_assistant_from_CLI.mdwn9
-rw-r--r--doc/forum/best_practices_for_importing_photos__63__.mdwn13
-rw-r--r--doc/forum/sync_stages_deletions_on_remote.mdwn72
-rw-r--r--doc/forum/taskwarrior/comment_2_4b3d70501763f6d36c927ae37bbd33c2._comment8
-rw-r--r--doc/git-annex.mdwn21
-rw-r--r--doc/news/version_5.20140320.mdwn37
-rw-r--r--doc/news/version_5.20140421.mdwn39
-rw-r--r--doc/preferred_content/standard_groups.mdwn2
-rwxr-xr-xdoc/tips/automatically_adding_metadata/pre-commit-annex24
-rw-r--r--doc/tips/file_manager_integration.mdwn4
-rw-r--r--doc/tips/flickrannex/comment_14_c728f10074d194efa8b2c60e97d275e7._comment12
-rw-r--r--doc/tips/using_Amazon_S3/comment_3_32acba030c2ad252e2f7027075e4303e._comment8
-rw-r--r--doc/tips/using_Amazon_S3/comment_4_92df5a9f923beafba55a1c455728112e._comment13
-rw-r--r--doc/tips/using_gitolite_with_git-annex.mdwn74
-rw-r--r--doc/todo/Time_Stamping_of_Events_in_Webapp.mdwn2
-rw-r--r--doc/todo/allow_removing_jabber_configuration.mdwn5
-rw-r--r--doc/todo/build_a_user_guide.mdwn3
-rw-r--r--doc/todo/do_not_bug_me_about_intermediate_files.mdwn7
-rw-r--r--doc/todo/document_standard_groups_more_extensively_in_the_UI.mdwn14
-rw-r--r--doc/todo/sharedRepository_mode_not_supported_by_git-annex.mdwn7
-rw-r--r--doc/users/tobiastheviking.mdwn23
-rw-r--r--git-annex.119
-rw-r--r--git-annex.cabal9
-rwxr-xr-xstandalone/linux/skel/runshell15
-rwxr-xr-xstandalone/osx/git-annex.app/Contents/MacOS/runshell15
-rw-r--r--templates/configurators/addrepository/cloud.hamlet7
-rw-r--r--templates/configurators/addrepository/connection.hamlet3
-rw-r--r--templates/configurators/addrepository/misc.hamlet14
-rw-r--r--templates/configurators/addrepository/ssh.hamlet6
-rw-r--r--templates/configurators/addrepository/xmppconnection.hamlet11
-rw-r--r--templates/configurators/delete/xmpp.hamlet10
-rw-r--r--templates/configurators/needconnection.hamlet12
-rw-r--r--templates/configurators/xmpp.hamlet2
-rw-r--r--templates/repolist.hamlet13
144 files changed, 1984 insertions, 526 deletions
diff --git a/Annex/Environment.hs b/Annex/Environment.hs
index f22c5f2..4b8d384 100644
--- a/Annex/Environment.hs
+++ b/Annex/Environment.hs
@@ -56,10 +56,12 @@ checkEnvironmentIO =
#endif
{- Runs an action that commits to the repository, and if it fails,
- - sets user.email to a dummy value and tries the action again. -}
+ - sets user.email and user.name to a dummy value and tries the action again. -}
ensureCommit :: Annex a -> Annex a
ensureCommit a = either retry return =<< tryAnnex a
where
retry _ = do
- setConfig (ConfigKey "user.email") =<< liftIO myUserName
+ name <- liftIO myUserName
+ setConfig (ConfigKey "user.name") name
+ setConfig (ConfigKey "user.email") name
a
diff --git a/Annex/Index.hs b/Annex/Index.hs
index a1b2442..af0cab4 100644
--- a/Annex/Index.hs
+++ b/Annex/Index.hs
@@ -9,6 +9,7 @@
module Annex.Index (
withIndexFile,
+ addGitEnv,
) where
import qualified Control.Exception as E
@@ -23,24 +24,30 @@ import Annex.Exception
withIndexFile :: FilePath -> Annex a -> Annex a
withIndexFile f a = do
g <- gitRepo
-#ifdef __ANDROID__
- {- This should not be necessary on Android, but there is some
- - weird getEnvironment breakage. See
- - https://github.com/neurocyte/ghc-android/issues/7
- - Use getEnv to get some key environment variables that
- - git expects to have. -}
- let keyenv = words "USER PATH GIT_EXEC_PATH HOSTNAME HOME"
- let getEnvPair k = maybe Nothing (\v -> Just (k, v)) <$> getEnv k
- e <- liftIO $ catMaybes <$> forM keyenv getEnvPair
- let e' = ("GIT_INDEX_FILE", f):e
-#else
- e <- liftIO getEnvironment
- let e' = addEntry "GIT_INDEX_FILE" f e
-#endif
- let g' = g { gitEnv = Just e' }
+ g' <- liftIO $ addGitEnv g "GIT_INDEX_FILE" f
r <- tryAnnex $ do
Annex.changeState $ \s -> s { Annex.repo = g' }
a
Annex.changeState $ \s -> s { Annex.repo = (Annex.repo s) { gitEnv = gitEnv g} }
either E.throw return r
+
+addGitEnv :: Repo -> String -> String -> IO Repo
+addGitEnv g var val = do
+ e <- maybe copyenv return (gitEnv g)
+ let e' = addEntry var val e
+ return $ g { gitEnv = Just e' }
+ where
+ copyenv = do
+#ifdef __ANDROID__
+ {- This should not be necessary on Android, but there is some
+ - weird getEnvironment breakage. See
+ - https://github.com/neurocyte/ghc-android/issues/7
+ - Use getEnv to get some key environment variables that
+ - git expects to have. -}
+ let keyenv = words "USER PATH GIT_EXEC_PATH HOSTNAME HOME"
+ let getEnvPair k = maybe Nothing (\v -> Just (k, v)) <$> getEnv k
+ liftIO $ catMaybes <$> forM keyenv getEnvPair
+#else
+ liftIO getEnvironment
+#endif
diff --git a/Annex/Init.hs b/Annex/Init.hs
index e095aef..637b130 100644
--- a/Annex/Init.hs
+++ b/Annex/Init.hs
@@ -11,12 +11,12 @@ module Annex.Init (
ensureInitialized,
isInitialized,
initialize,
+ initialize',
uninitialize,
probeCrippledFileSystem,
) where
import Common.Annex
-import Utility.Network
import qualified Annex
import qualified Git
import qualified Git.LsFiles
@@ -61,6 +61,17 @@ genDescription Nothing = do
initialize :: Maybe String -> Annex ()
initialize mdescription = do
prepUUID
+ initialize'
+
+ u <- getUUID
+ {- This will make the first commit to git, so ensure git is set up
+ - properly to allow commits when running it. -}
+ ensureCommit $ do
+ Annex.Branch.create
+ describeUUID u =<< genDescription mdescription
+
+initialize' :: Annex ()
+initialize' = do
checkFifoSupport
checkCrippledFileSystem
unlessM isBare $
@@ -76,12 +87,6 @@ initialize mdescription = do
switchHEADBack
)
createInodeSentinalFile
- u <- getUUID
- {- This will make the first commit to git, so ensure git is set up
- - properly to allow commits when running it. -}
- ensureCommit $ do
- Annex.Branch.create
- describeUUID u =<< genDescription mdescription
uninitialize :: Annex ()
uninitialize = do
diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs
index bd10a40..1594801 100644
--- a/Annex/Ssh.hs
+++ b/Annex/Ssh.hs
@@ -1,6 +1,6 @@
{- git-annex ssh interface, with connection caching
-
- - Copyright 2012,2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -11,19 +11,29 @@ module Annex.Ssh (
sshCachingOptions,
sshCacheDir,
sshReadPort,
+ forceSshCleanup,
+ sshCachingEnv,
+ sshCachingTo,
+ inRepoWithSshCachingTo,
+ runSshCaching,
) where
import qualified Data.Map as M
import Data.Hash.MD5
import System.Process (cwd)
+import System.Exit
import Common.Annex
import Annex.LockPool
import qualified Build.SysConfig as SysConfig
import qualified Annex
+import qualified Git
+import qualified Git.Url
import Config
+import Config.Files
import Utility.Env
import Types.CleanupActions
+import Annex.Index (addGitEnv)
#ifndef mingw32_HOST_OS
import Annex.Perms
#endif
@@ -31,22 +41,13 @@ import Annex.Perms
{- Generates parameters to ssh to a given host (or user@host) on a given
- port, with connection caching. -}
sshCachingOptions :: (String, Maybe Integer) -> [CommandParam] -> Annex [CommandParam]
-sshCachingOptions (host, port) opts = do
- Annex.addCleanup SshCachingCleanup sshCleanup
- go =<< sshInfo (host, port)
+sshCachingOptions (host, port) opts = go =<< sshInfo (host, port)
where
go (Nothing, params) = ret params
go (Just socketfile, params) = do
- cleanstale
- liftIO $ createDirectoryIfMissing True $ parentDir socketfile
- lockFile $ socket2lock socketfile
+ prepSocket socketfile
ret params
ret ps = return $ ps ++ opts ++ portParams port ++ [Param "-T"]
- -- If the lock pool is empty, this is the first ssh of this
- -- run. There could be stale ssh connections hanging around
- -- from a previous git-annex run that was interrupted.
- cleanstale = whenM (not . any isLock . M.keys <$> getPool)
- sshCleanup
{- Returns a filename to use for a ssh connection caching socket, and
- parameters to enable ssh connection caching. -}
@@ -102,28 +103,50 @@ sshCacheDir
where
gettmpdir = liftIO $ getEnv "GIT_ANNEX_TMP_DIR"
usetmpdir tmpdir = liftIO $ catchMaybeIO $ do
- createDirectoryIfMissing True tmpdir
- return tmpdir
+ let socktmp = tmpdir </> "ssh"
+ createDirectoryIfMissing True socktmp
+ return socktmp
portParams :: Maybe Integer -> [CommandParam]
portParams Nothing = []
portParams (Just port) = [Param "-p", Param $ show port]
-{- Stop any unused ssh processes. -}
+{- Prepare to use a socket file. Locks a lock file to prevent
+ - other git-annex processes from stopping the ssh on this socket. -}
+prepSocket :: FilePath -> Annex ()
+prepSocket socketfile = do
+ -- If the lock pool is empty, this is the first ssh of this
+ -- run. There could be stale ssh connections hanging around
+ -- from a previous git-annex run that was interrupted.
+ whenM (not . any isLock . M.keys <$> getPool)
+ sshCleanup
+ -- Cleanup at end of this run.
+ Annex.addCleanup SshCachingCleanup sshCleanup
+
+ liftIO $ createDirectoryIfMissing True $ parentDir socketfile
+ lockFile $ socket2lock socketfile
+
+enumSocketFiles :: Annex [FilePath]
+enumSocketFiles = go =<< sshCacheDir
+ where
+ go Nothing = return []
+ go (Just dir) = liftIO $ filter (not . isLock)
+ <$> catchDefaultIO [] (dirContents dir)
+
+{- Stop any unused ssh connection caching processes. -}
sshCleanup :: Annex ()
-sshCleanup = go =<< sshCacheDir
+sshCleanup = mapM_ cleanup =<< enumSocketFiles
where
- go Nothing = noop
- go (Just dir) = do
- sockets <- liftIO $ filter (not . isLock)
- <$> catchDefaultIO [] (dirContents dir)
- forM_ sockets cleanup
cleanup socketfile = do
#ifndef mingw32_HOST_OS
-- Drop any shared lock we have, and take an
-- exclusive lock, without blocking. If the lock
-- succeeds, nothing is using this ssh, and it can
-- be stopped.
+ --
+ -- After ssh is stopped cannot remove the lock file;
+ -- other processes may be waiting on our exclusive
+ -- lock to use it.
let lockfile = socket2lock socketfile
unlockFile lockfile
mode <- annexFileMode
@@ -133,24 +156,28 @@ sshCleanup = go =<< sshCacheDir
setLock fd (WriteLock, AbsoluteSeek, 0, 0)
case v of
Left _ -> noop
- Right _ -> stopssh socketfile
+ Right _ -> forceStopSsh socketfile
liftIO $ closeFd fd
#else
- stopssh socketfile
+ forceStopSsh socketfile
#endif
- stopssh socketfile = do
- let (dir, base) = splitFileName socketfile
- let params = sshConnectionCachingParams base
- -- "ssh -O stop" is noisy on stderr even with -q
- void $ liftIO $ catchMaybeIO $
- withQuietOutput createProcessSuccess $
- (proc "ssh" $ toCommand $
- [ Params "-O stop"
- ] ++ params ++ [Param "localhost"])
- { cwd = Just dir }
- liftIO $ nukeFile socketfile
- -- Cannot remove the lock file; other processes may
- -- be waiting on our exclusive lock to use it.
+
+{- Stop all ssh connection caching processes, even when they're in use. -}
+forceSshCleanup :: Annex ()
+forceSshCleanup = mapM_ forceStopSsh =<< enumSocketFiles
+
+forceStopSsh :: FilePath -> Annex ()
+forceStopSsh socketfile = do
+ let (dir, base) = splitFileName socketfile
+ let params = sshConnectionCachingParams base
+ -- "ssh -O stop" is noisy on stderr even with -q
+ void $ liftIO $ catchMaybeIO $
+ withQuietOutput createProcessSuccess $
+ (proc "ssh" $ toCommand $
+ [ Params "-O stop"
+ ] ++ params ++ [Param "localhost"])
+ { cwd = Just dir }
+ liftIO $ nukeFile socketfile
{- This needs to be as short as possible, due to limitations on the length
- of the path to a socket file. At the same time, it needs to be unique
@@ -199,3 +226,50 @@ sshReadPort params = (port, reverse args)
aux (p,ps) (q:rest) | "-p" `isPrefixOf` q = aux (readPort $ drop 2 q, ps) rest
| otherwise = aux (p,q:ps) rest
readPort p = fmap fst $ listToMaybe $ reads p
+
+{- When this env var is set, git-annex runs ssh with parameters
+ - to use the socket file that the env var contains.
+ -
+ - This is a workaround for GiT_SSH not being able to contain
+ - additional parameters to pass to ssh. -}
+sshCachingEnv :: String
+sshCachingEnv = "GIT_ANNEX_SSHCACHING"
+
+{- Enables ssh caching for git push/pull to a particular
+ - remote git repo. (Can safely be used on non-ssh remotes.)
+ -
+ - Like inRepo, the action is run with the local git repo.
+ - But here it's a modified version, with gitEnv to set GIT_SSH=git-annex,
+ - and sshCachingEnv set so that git-annex will know what socket
+ - file to use. -}
+inRepoWithSshCachingTo :: Git.Repo -> (Git.Repo -> IO a) -> Annex a
+inRepoWithSshCachingTo remote a =
+ liftIO . a =<< sshCachingTo remote =<< gitRepo
+
+{- To make any git commands be run with ssh caching enabled,
+ - alters the local Git.Repo's gitEnv to set GIT_SSH=git-annex,
+ - and set sshCachingEnv so that git-annex will know what socket
+ - file to use. -}
+sshCachingTo :: Git.Repo -> Git.Repo -> Annex Git.Repo
+sshCachingTo remote g
+ | not (Git.repoIsUrl remote) || Git.repoIsHttp remote = uncached
+ | otherwise = case Git.Url.hostuser remote of
+ Nothing -> uncached
+ Just host -> do
+ (msockfile, _) <- sshInfo (host, Git.Url.port remote)
+ case msockfile of
+ Nothing -> return g
+ Just sockfile -> do
+ command <- liftIO readProgramFile
+ prepSocket sockfile
+ liftIO $ do
+ g' <- addGitEnv g sshCachingEnv sockfile
+ addGitEnv g' "GIT_SSH" command
+ where
+ uncached = return g
+
+runSshCaching :: [String] -> String -> IO ()
+runSshCaching args sockfile = do
+ let args' = toCommand (sshConnectionCachingParams sockfile) ++ args
+ let p = proc "ssh" args'
+ exitWith =<< waitForProcess . processHandle =<< createProcess p
diff --git a/Annex/UUID.hs b/Annex/UUID.hs
index 4e27450..5ed8876 100644
--- a/Annex/UUID.hs
+++ b/Annex/UUID.hs
@@ -21,6 +21,7 @@ module Annex.UUID (
gCryptNameSpace,
removeRepoUUID,
storeUUID,
+ storeUUIDIn,
setUUID,
) where
@@ -70,7 +71,7 @@ getRepoUUID r = do
where
updatecache u = do
g <- gitRepo
- when (g /= r) $ storeUUID cachekey u
+ when (g /= r) $ storeUUIDIn cachekey u
cachekey = remoteConfig r "uuid"
removeRepoUUID :: Annex ()
@@ -84,10 +85,13 @@ getUncachedUUID = toUUID . Git.Config.get key ""
{- Make sure that the repo has an annex.uuid setting. -}
prepUUID :: Annex ()
prepUUID = whenM ((==) NoUUID <$> getUUID) $
- storeUUID configkey =<< liftIO genUUID
+ storeUUID =<< liftIO genUUID
-storeUUID :: ConfigKey -> UUID -> Annex ()
-storeUUID configfield = setConfig configfield . fromUUID
+storeUUID :: UUID -> Annex ()
+storeUUID = storeUUIDIn configkey
+
+storeUUIDIn :: ConfigKey -> UUID -> Annex ()
+storeUUIDIn configfield = setConfig configfield . fromUUID
{- Only sets the configkey in the Repo; does not change .git/config -}
setUUID :: Git.Repo -> UUID -> IO Git.Repo
diff --git a/Annex/View.hs b/Annex/View.hs
index 7c187be..5cf21cd 100644
--- a/Annex/View.hs
+++ b/Annex/View.hs
@@ -348,7 +348,7 @@ applyView' mkviewedfile getfilemetadata view = do
void clean
where
genviewedfiles = viewedFiles view mkviewedfile -- enables memoization
- go uh hasher f (Just (k, _)) = do
+ go uh hasher f (Just k) = do
metadata <- getCurrentMetaData k
let metadata' = getfilemetadata f `unionMetaData` metadata
forM_ (genviewedfiles f metadata') $ \fv -> do
diff --git a/Assistant.hs b/Assistant.hs
index 67398f2..b5cacea 100644
--- a/Assistant.hs
+++ b/Assistant.hs
@@ -21,6 +21,7 @@ import Assistant.Threads.Pusher
import Assistant.Threads.Merger
import Assistant.Threads.TransferWatcher
import Assistant.Threads.Transferrer
+import Assistant.Threads.RemoteControl
import Assistant.Threads.SanityChecker
import Assistant.Threads.Cronner
import Assistant.Threads.ProblemFixer
@@ -147,6 +148,7 @@ startDaemon assistant foreground startdelay cannotrun listenhost startbrowser =
, assist $ transferWatcherThread
, assist $ transferPollerThread
, assist $ transfererThread
+ , assist $ remoteControlThread
, assist $ daemonStatusThread
, assist $ sanityCheckerDailyThread urlrenderer
, assist $ sanityCheckerHourlyThread
diff --git a/Assistant/Alert.hs b/Assistant/Alert.hs
index 192952f..745694f 100644
--- a/Assistant/Alert.hs
+++ b/Assistant/Alert.hs
@@ -16,6 +16,7 @@ import qualified Remote
import Utility.Tense
import Logs.Transfer
import Types.Distribution
+import Git.Types (RemoteName)
import Data.String
import qualified Data.Text as T
@@ -117,11 +118,14 @@ commitAlert :: Alert
commitAlert = activityAlert Nothing
[Tensed "Committing" "Committed", "changes to git"]
-showRemotes :: [Remote] -> TenseChunk
-showRemotes = UnTensed . T.intercalate ", " . map (T.pack . Remote.name)
+showRemotes :: [RemoteName] -> TenseChunk
+showRemotes = UnTensed . T.intercalate ", " . map T.pack
syncAlert :: [Remote] -> Alert
-syncAlert rs = baseActivityAlert
+syncAlert = syncAlert' . map Remote.name
+
+syncAlert' :: [RemoteName] -> Alert
+syncAlert' rs = baseActivityAlert
{ alertName = Just SyncAlert
, alertHeader = Just $ tenseWords
[Tensed "Syncing" "Synced", "with", showRemotes rs]
@@ -130,7 +134,12 @@ syncAlert rs = baseActivityAlert
}
syncResultAlert :: [Remote] -> [Remote] -> Alert
-syncResultAlert succeeded failed = makeAlertFiller (not $ null succeeded) $
+syncResultAlert succeeded failed = syncResultAlert'
+ (map Remote.name succeeded)
+ (map Remote.name failed)
+
+syncResultAlert' :: [RemoteName] -> [RemoteName] -> Alert
+syncResultAlert' succeeded failed = makeAlertFiller (not $ null succeeded) $
baseActivityAlert
{ alertName = Just SyncAlert
, alertHeader = Just $ tenseWords msg
@@ -320,10 +329,10 @@ pairRequestAcknowledgedAlert who button = baseActivityAlert
, alertButtons = maybeToList button
}
-xmppNeededAlert :: AlertButton -> Alert
-xmppNeededAlert button = Alert
+connectionNeededAlert :: AlertButton -> Alert
+connectionNeededAlert button = Alert
{ alertHeader = Just "Share with friends, and keep your devices in sync across the cloud."
- , alertIcon = Just TheCloud
+ , alertIcon = Just ConnectionIcon
, alertPriority = High
, alertButtons = [button]
, alertClosable = True
@@ -331,7 +340,7 @@ xmppNeededAlert button = Alert
, alertMessageRender = renderData
, alertCounter = 0
, alertBlockDisplay = True
- , alertName = Just $ XMPPNeededAlert
+ , alertName = Just ConnectionNeededAlert
, alertCombiner = Just $ dataCombiner $ \_old new -> new
, alertData = []
}
diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs
index eb842b7..35f8fc8 100644
--- a/Assistant/DaemonStatus.hs
+++ b/Assistant/DaemonStatus.hs
@@ -26,6 +26,7 @@ import Data.Time.Clock.POSIX
import Data.Time
import System.Locale
import qualified Data.Map as M
+import qualified Data.Set as S
import qualified Data.Text as T
getDaemonStatus :: Assistant DaemonStatus
@@ -78,6 +79,15 @@ updateSyncRemotes = do
M.filter $ \alert ->
alertName alert /= Just CloudRepoNeededAlert
+changeCurrentlyConnected :: (S.Set UUID -> S.Set UUID) -> Assistant ()
+changeCurrentlyConnected sm = do
+ modifyDaemonStatus_ $ \ds -> ds
+ { currentlyConnectedRemotes = sm (currentlyConnectedRemotes ds)
+ }
+ v <- currentlyConnectedRemotes <$> getDaemonStatus
+ debug [show v]
+ liftIO . sendNotification =<< syncRemotesNotifier <$> getDaemonStatus
+
updateScheduleLog :: Assistant ()
updateScheduleLog =
liftIO . sendNotification =<< scheduleLogNotifier <$> getDaemonStatus
diff --git a/Assistant/Install.hs b/Assistant/Install.hs
index 883ca48..afbe5b9 100644
--- a/Assistant/Install.hs
+++ b/Assistant/Install.hs
@@ -30,8 +30,8 @@ standaloneAppBase = getEnv "GIT_ANNEX_APP_BASE"
{- The standalone app does not have an installation process.
- So when it's run, it needs to set up autostarting of the assistant
- - daemon, as well as writing the programFile, and putting a
- - git-annex-shell wrapper into ~/.ssh
+ - daemon, as well as writing the programFile, and putting the
+ - git-annex-shell and git-annex-wrapper wrapper scripts into ~/.ssh
-
- Note that this is done every time it's started, so if the user moves
- it around, the paths this sets up won't break.
@@ -59,30 +59,35 @@ ensureInstalled = go =<< standaloneAppBase
#endif
installAutoStart program autostartfile
- {- This shim is only updated if it doesn't
- - already exist with the right content. -}
sshdir <- sshDir
- let shim = sshdir </> "git-annex-shell"
- let runshell var = "exec " ++ base </> "runshell" ++
- " git-annex-shell -c \"" ++ var ++ "\""
- let content = unlines
+ let runshell var = "exec " ++ base </> "runshell " ++ var
+ let rungitannexshell var = runshell $ "git-annex-shell -c \"" ++ var ++ "\""
+
+ installWrapper (sshdir </> "git-annex-shell") $ unlines
[ shebang_local
, "set -e"
, "if [ \"x$SSH_ORIGINAL_COMMAND\" != \"x\" ]; then"
- , runshell "$SSH_ORIGINAL_COMMAND"
+ , rungitannexshell "$SSH_ORIGINAL_COMMAND"
, "else"
- , runshell "$@"
+ , rungitannexshell "$@"
, "fi"
]
-
- curr <- catchDefaultIO "" $ readFileStrict shim
- when (curr /= content) $ do
- createDirectoryIfMissing True (parentDir shim)
- viaTmp writeFile shim content
- modifyFileMode shim $ addModes [ownerExecuteMode]
+ installWrapper (sshdir </> "git-annex-wrapper") $ unlines
+ [ shebang_local
+ , "set -e"
+ , runshell "\"$@\""
+ ]
installNautilus program
+installWrapper :: FilePath -> String -> IO ()
+installWrapper file content = do
+ curr <- catchDefaultIO "" $ readFileStrict file
+ when (curr /= content) $ do
+ createDirectoryIfMissing True (parentDir file)
+ viaTmp writeFile file content
+ modifyFileMode file $ addModes [ownerExecuteMode]
+
installNautilus :: FilePath -> IO ()
#ifdef linux_HOST_OS
installNautilus program = do
diff --git a/Assistant/Monad.hs b/Assistant/Monad.hs
index 7c28c7f..350e3d3 100644
--- a/Assistant/Monad.hs
+++ b/Assistant/Monad.hs
@@ -43,6 +43,7 @@ import Assistant.Types.RepoProblem
import Assistant.Types.Buddies
import Assistant.Types.NetMessager
import Assistant.Types.ThreadName
+import Assistant.Types.RemoteControl
newtype Assistant a = Assistant { mkAssistant :: ReaderT AssistantData IO a }
deriving (
@@ -68,6 +69,7 @@ data AssistantData = AssistantData
, branchChangeHandle :: BranchChangeHandle
, buddyList :: BuddyList
, netMessager :: NetMessager
+ , remoteControl :: RemoteControl
}
newAssistantData :: ThreadState -> DaemonStatusHandle -> IO AssistantData
@@ -86,6 +88,7 @@ newAssistantData st dstatus = AssistantData
<*> newBranchChangeHandle
<*> newBuddyList
<*> newNetMessager
+ <*> newRemoteControl
runAssistant :: AssistantData -> Assistant a -> IO a
runAssistant d a = runReaderT (mkAssistant a) d
diff --git a/Assistant/RemoteControl.hs b/Assistant/RemoteControl.hs
new file mode 100644
index 0000000..86d13cc
--- /dev/null
+++ b/Assistant/RemoteControl.hs
@@ -0,0 +1,21 @@
+{- git-annex assistant RemoteDaemon control
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.RemoteControl (
+ sendRemoteControl,
+ RemoteDaemon.Consumed(..)
+) where
+
+import Assistant.Common
+import qualified RemoteDaemon.Types as RemoteDaemon
+
+import Control.Concurrent
+
+sendRemoteControl :: RemoteDaemon.Consumed -> Assistant ()
+sendRemoteControl msg = do
+ clicker <- getAssistant remoteControl
+ liftIO $ writeChan clicker msg
diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs
index fc95419..c748f6e 100644
--- a/Assistant/Sync.hs
+++ b/Assistant/Sync.hs
@@ -15,6 +15,7 @@ import Assistant.Alert
import Assistant.Alert.Utility
import Assistant.DaemonStatus
import Assistant.ScanRemotes
+import Assistant.RemoteControl
import qualified Command.Sync
import Utility.Parallel
import qualified Git
@@ -258,6 +259,7 @@ changeSyncable Nothing enable = do
changeSyncable (Just r) True = do
liftAnnex $ changeSyncFlag r True
syncRemote r
+ sendRemoteControl RELOAD
changeSyncable (Just r) False = do
liftAnnex $ changeSyncFlag r False
updateSyncRemotes
diff --git a/Assistant/Threads/NetWatcher.hs b/Assistant/Threads/NetWatcher.hs
index 0b00964..9dd6178 100644
--- a/Assistant/Threads/NetWatcher.hs
+++ b/Assistant/Threads/NetWatcher.hs
@@ -15,13 +15,13 @@ import Assistant.Sync
import Utility.ThreadScheduler
import qualified Types.Remote as Remote
import Assistant.DaemonStatus
+import Assistant.RemoteControl
import Utility.NotificationBroadcaster
#if WITH_DBUS
import Utility.DBus
import DBus.Client
import DBus
-import Data.Word (Word32)
import Assistant.NetMessager
#else
#ifdef linux_HOST_OS
@@ -44,8 +44,9 @@ netWatcherThread = thread noop
- while (despite the local network staying up), are synced with
- periodically.
-
- - Note that it does not call notifyNetMessagerRestart, because
- - it doesn't know that the network has changed.
+ - Note that it does not call notifyNetMessagerRestart, or
+ - signal the RemoteControl, because it doesn't know that the
+ - network has changed.
-}
netWatcherFallbackThread :: NamedThread
netWatcherFallbackThread = namedThread "NetWatcherFallback" $
@@ -61,16 +62,22 @@ dbusThread = do
where
go client = ifM (checkNetMonitor client)
( do
- listenNMConnections client <~> handleconn
- listenWicdConnections client <~> handleconn
+ callback <- asIO1 connchange
+ liftIO $ do
+ listenNMConnections client callback
+ listenWicdConnections client callback
, do
liftAnnex $
warning "No known network monitor available through dbus; falling back to polling"
)
- handleconn = do
+ connchange False = do
+ debug ["detected network disconnection"]
+ sendRemoteControl LOSTNET
+ connchange True = do
debug ["detected network connection"]
notifyNetMessagerRestart
handleConnection
+ sendRemoteControl RESUME
onerr e _ = do
liftAnnex $
warning $ "lost dbus connection; falling back to polling (" ++ show e ++ ")"
@@ -95,37 +102,64 @@ checkNetMonitor client = do
networkmanager = "org.freedesktop.NetworkManager"
wicd = "org.wicd.daemon"
-{- Listens for new NetworkManager connections. -}
-listenNMConnections :: Client -> IO () -> IO ()
-listenNMConnections client callback =
- listen client matcher $ \event ->
- when (Just True == anyM activeconnection (signalBody event)) $
- callback
+{- Listens for NetworkManager connections and diconnections.
+ -
+ - Connection example (once fully connected):
+ - [Variant {"ActivatingConnection": Variant (ObjectPath "/"), "PrimaryConnection": Variant (ObjectPath "/org/freedesktop/NetworkManager/ActiveConnection/34"), "State": Variant 70}]
+ -
+ - Disconnection example:
+ - [Variant {"ActiveConnections": Variant []}]
+ -}
+listenNMConnections :: Client -> (Bool -> IO ()) -> IO ()
+listenNMConnections client setconnected =
+ listen client matcher $ \event -> mapM_ handle
+ (map dictionaryItems $ mapMaybe fromVariant $ signalBody event)
where
matcher = matchAny
- { matchInterface = Just "org.freedesktop.NetworkManager.Connection.Active"
+ { matchInterface = Just "org.freedesktop.NetworkManager"
, matchMember = Just "PropertiesChanged"
}
- nm_connection_activated = toVariant (2 :: Word32)
- nm_state_key = toVariant ("State" :: String)
- activeconnection v = do
- m <- fromVariant v
- vstate <- lookup nm_state_key $ dictionaryItems m
- state <- fromVariant vstate
- return $ state == nm_connection_activated
+ nm_active_connections_key = toVariant ("ActiveConnections" :: String)
+ nm_activatingconnection_key = toVariant ("ActivatingConnection" :: String)
+ noconnections = Just $ toVariant $ toVariant ([] :: [ObjectPath])
+ rootconnection = Just $ toVariant $ toVariant $ objectPath_ "/"
+ handle m
+ | lookup nm_active_connections_key m == noconnections =
+ setconnected False
+ | lookup nm_activatingconnection_key m == rootconnection =
+ setconnected True
+ | otherwise = noop
-{- Listens for new Wicd connections. -}
-listenWicdConnections :: Client -> IO () -> IO ()
-listenWicdConnections client callback =
- listen client matcher $ \event ->
+{- Listens for Wicd connections and disconnections.
+ -
+ - Connection example:
+ - ConnectResultsSent:
+ - Variant "success"
+ -
+ - Diconnection example:
+ - StatusChanged
+ - [Variant 0, Variant [Varient ""]]
+ -}
+listenWicdConnections :: Client -> (Bool -> IO ()) -> IO ()
+listenWicdConnections client setconnected = do
+ listen client connmatcher $ \event ->
when (any (== wicd_success) (signalBody event)) $
- callback
+ setconnected True
+ listen client statusmatcher $ \event -> handle (signalBody event)
where
- matcher = matchAny
+ connmatcher = matchAny
{ matchInterface = Just "org.wicd.daemon"
, matchMember = Just "ConnectResultsSent"
}
+ statusmatcher = matchAny
+ { matchInterface = Just "org.wicd.daemon"
+ , matchMember = Just "StatusChanged"
+ }
wicd_success = toVariant ("success" :: String)
+ wicd_disconnected = toVariant [toVariant ("" :: String)]
+ handle status
+ | any (== wicd_disconnected) status = setconnected False
+ | otherwise = noop
#endif
diff --git a/Assistant/Threads/RemoteControl.hs b/Assistant/Threads/RemoteControl.hs
new file mode 100644
index 0000000..317efe4
--- /dev/null
+++ b/Assistant/Threads/RemoteControl.hs
@@ -0,0 +1,122 @@
+{- git-annex assistant communication with remotedaemon
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.Threads.RemoteControl where
+
+import Assistant.Common
+import RemoteDaemon.Types
+import Config.Files
+import Utility.Batch
+import Utility.SimpleProtocol
+import Assistant.Alert
+import Assistant.Alert.Utility
+import Assistant.DaemonStatus
+import qualified Git
+import qualified Git.Types as Git
+import qualified Remote
+import qualified Types.Remote as Remote
+
+import Control.Concurrent
+import Control.Concurrent.Async
+import System.Process (std_in, std_out)
+import Network.URI
+import qualified Data.Map as M
+import qualified Data.Set as S
+
+remoteControlThread :: NamedThread
+remoteControlThread = namedThread "RemoteControl" $ do
+ program <- liftIO readProgramFile
+ (cmd, params) <- liftIO $ toBatchCommand
+ (program, [Param "remotedaemon"])
+ let p = proc cmd (toCommand params)
+ (Just toh, Just fromh, _, pid) <- liftIO $ createProcess p
+ { std_in = CreatePipe
+ , std_out = CreatePipe
+ }
+
+ urimap <- liftIO . newMVar =<< liftAnnex getURIMap
+
+ controller <- asIO $ remoteControllerThread toh
+ responder <- asIO $ remoteResponderThread fromh urimap
+
+ -- run controller and responder until the remotedaemon dies
+ liftIO $ void $ tryNonAsync $ controller `concurrently` responder
+ debug ["remotedaemon exited"]
+ liftIO $ forceSuccessProcess p pid
+
+-- feed from the remoteControl channel into the remotedaemon
+remoteControllerThread :: Handle -> Assistant ()
+remoteControllerThread toh = do
+ clicker <- getAssistant remoteControl
+ forever $ do
+ msg <- liftIO $ readChan clicker
+ debug [show msg]
+ liftIO $ do
+ hPutStrLn toh $ unwords $ formatMessage msg
+ hFlush toh
+
+-- read status messages emitted by the remotedaemon and handle them
+remoteResponderThread :: Handle -> MVar (M.Map URI Remote) -> Assistant ()
+remoteResponderThread fromh urimap = go M.empty
+ where
+ go syncalerts = do
+ l <- liftIO $ hGetLine fromh
+ debug [l]
+ case parseMessage l of
+ Just (CONNECTED uri) -> changeconnected S.insert uri
+ Just (DISCONNECTED uri) -> changeconnected S.delete uri
+ Just (SYNCING uri) -> withr uri $ \r ->
+ if M.member (Remote.uuid r) syncalerts
+ then go syncalerts
+ else do
+ i <- addAlert $ syncAlert [r]
+ go (M.insert (Remote.uuid r) i syncalerts)
+ Just (DONESYNCING uri status) -> withr uri $ \r ->
+ case M.lookup (Remote.uuid r) syncalerts of
+ Nothing -> cont
+ Just i -> do
+ let (succeeded, failed) = if status
+ then ([r], [])
+ else ([], [r])
+ updateAlertMap $ mergeAlert i $
+ syncResultAlert succeeded failed
+ go (M.delete (Remote.uuid r) syncalerts)
+ Just (WARNING (RemoteURI uri) msg) -> do
+ void $ addAlert $
+ warningAlert ("RemoteControl "++ show uri) msg
+ cont
+ Nothing -> do
+ debug ["protocol error from remotedaemon: ", l]
+ cont
+ where
+ cont = go syncalerts
+ withr uri = withRemote uri urimap cont
+ changeconnected sm uri = withr uri $ \r -> do
+ changeCurrentlyConnected $ sm $ Remote.uuid r
+ cont
+
+getURIMap :: Annex (M.Map URI Remote)
+getURIMap = Remote.remoteMap' id (mkk . Git.location . Remote.repo)
+ where
+ mkk (Git.Url u) = Just u
+ mkk _ = Nothing
+
+withRemote
+ :: RemoteURI
+ -> MVar (M.Map URI Remote)
+ -> Assistant a
+ -> (Remote -> Assistant a)
+ -> Assistant a
+withRemote (RemoteURI uri) remotemap noremote a = do
+ m <- liftIO $ readMVar remotemap
+ case M.lookup uri m of
+ Just r -> a r
+ Nothing -> do
+ {- Reload map, in case a new remote has been added. -}
+ m' <- liftAnnex getURIMap
+ void $ liftIO $ swapMVar remotemap $ m'
+ maybe noremote a (M.lookup uri m')
diff --git a/Assistant/Threads/TransferScanner.hs b/Assistant/Threads/TransferScanner.hs
index 6df9b1e..daced8d 100644
--- a/Assistant/Threads/TransferScanner.hs
+++ b/Assistant/Threads/TransferScanner.hs
@@ -151,7 +151,7 @@ expensiveScan urlrenderer rs = unless onlyweb $ batch <~> do
enqueue f (r, t) =
queueTransferWhenSmall "expensive scan found missing object"
(Just f) t r
- findtransfers f unwanted (key, _) = do
+ findtransfers f unwanted key = do
{- The syncable remotes may have changed since this
- scan began. -}
syncrs <- syncDataRemotes <$> getDaemonStatus
diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs
index 97ccf08..0ed1bd2 100644
--- a/Assistant/Threads/Watcher.hs
+++ b/Assistant/Threads/Watcher.hs
@@ -271,7 +271,7 @@ onAddSymlink :: Bool -> Handler
onAddSymlink isdirect file filestatus = unlessIgnored file $ do
linktarget <- liftIO (catchMaybeIO $ readSymbolicLink file)
kv <- liftAnnex (Backend.lookupFile file)
- onAddSymlink' linktarget (fmap fst kv) isdirect file filestatus
+ onAddSymlink' linktarget kv isdirect file filestatus
onAddSymlink' :: Maybe String -> Maybe Key -> Bool -> Handler
onAddSymlink' linktarget mk isdirect file filestatus = go mk
diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs
index ab4de92..39b0459 100644
--- a/Assistant/Threads/XMPPClient.hs
+++ b/Assistant/Threads/XMPPClient.hs
@@ -42,17 +42,20 @@ xmppClientThread urlrenderer = namedThread "XMPPClient" $
restartableClient . xmppClient urlrenderer =<< getAssistant id
{- Runs the client, handing restart events. -}
-restartableClient :: (XMPPCreds -> IO ()) -> Assistant ()
+restartableClient :: (XMPPCreds -> UUID -> IO ()) -> Assistant ()
restartableClient a = forever $ go =<< liftAnnex getXMPPCreds
where
go Nothing = waitNetMessagerRestart
go (Just creds) = do
- tid <- liftIO $ forkIO $ a creds
+ xmppuuid <- maybe NoUUID Remote.uuid . headMaybe
+ . filter Remote.isXMPPRemote . syncRemotes
+ <$> getDaemonStatus
+ tid <- liftIO $ forkIO $ a creds xmppuuid
waitNetMessagerRestart
liftIO $ killThread tid
-xmppClient :: UrlRenderer -> AssistantData -> XMPPCreds -> IO ()
-xmppClient urlrenderer d creds =
+xmppClient :: UrlRenderer -> AssistantData -> XMPPCreds -> UUID -> IO ()
+xmppClient urlrenderer d creds xmppuuid =
retry (runclient creds) =<< getCurrentTime
where
liftAssistant = runAssistant d
@@ -68,8 +71,11 @@ xmppClient urlrenderer d creds =
liftAssistant $
updateBuddyList (const noBuddies) <<~ buddyList
void client
- liftAssistant $ modifyDaemonStatus_ $ \s -> s
- { xmppClientID = Nothing }
+ liftAssistant $ do
+ modifyDaemonStatus_ $ \s -> s
+ { xmppClientID = Nothing }
+ changeCurrentlyConnected $ S.delete xmppuuid
+
now <- getCurrentTime
if diffUTCTime now starttime > 300
then do
@@ -87,6 +93,7 @@ xmppClient urlrenderer d creds =
inAssistant $ do
modifyDaemonStatus_ $ \s -> s
{ xmppClientID = Just $ xmppJID creds }
+ changeCurrentlyConnected $ S.insert xmppuuid
debug ["connected", logJid selfjid]
lasttraffic <- liftIO $ atomically . newTMVar =<< getCurrentTime
diff --git a/Assistant/Types/Alert.hs b/Assistant/Types/Alert.hs
index 19fe55e..9fd33c7 100644
--- a/Assistant/Types/Alert.hs
+++ b/Assistant/Types/Alert.hs
@@ -26,7 +26,7 @@ data AlertName
| SanityCheckFixAlert
| WarningAlert String
| PairAlert String
- | XMPPNeededAlert
+ | ConnectionNeededAlert
| RemoteRemovalAlert String
| CloudRepoNeededAlert
| SyncAlert
@@ -54,7 +54,7 @@ data Alert = Alert
, alertButtons :: [AlertButton]
}
-data AlertIcon = ActivityIcon | SyncIcon | SuccessIcon | ErrorIcon | InfoIcon | UpgradeIcon | TheCloud
+data AlertIcon = ActivityIcon | SyncIcon | SuccessIcon | ErrorIcon | InfoIcon | UpgradeIcon | ConnectionIcon
type AlertMap = M.Map AlertId Alert
diff --git a/Assistant/Types/DaemonStatus.hs b/Assistant/Types/DaemonStatus.hs
index a618c70..2adad28 100644
--- a/Assistant/Types/DaemonStatus.hs
+++ b/Assistant/Types/DaemonStatus.hs
@@ -52,6 +52,8 @@ data DaemonStatus = DaemonStatus
, syncDataRemotes :: [Remote]
-- Are we syncing to any cloud remotes?
, syncingToCloudRemote :: Bool
+ -- Set of uuids of remotes that are currently connected.
+ , currentlyConnectedRemotes :: S.Set UUID
-- List of uuids of remotes that we may have gotten out of sync with.
, desynced :: S.Set UUID
-- Pairing request that is in progress.
@@ -104,6 +106,7 @@ newDaemonStatus = DaemonStatus
<*> pure []
<*> pure False
<*> pure S.empty
+ <*> pure S.empty
<*> pure Nothing
<*> newNotificationBroadcaster
<*> newNotificationBroadcaster
diff --git a/Assistant/Types/RemoteControl.hs b/Assistant/Types/RemoteControl.hs
new file mode 100644
index 0000000..523cd8b
--- /dev/null
+++ b/Assistant/Types/RemoteControl.hs
@@ -0,0 +1,16 @@
+{- git-annex assistant RemoteDaemon control
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.Types.RemoteControl where
+
+import qualified RemoteDaemon.Types as RemoteDaemon
+import Control.Concurrent
+
+type RemoteControl = Chan RemoteDaemon.Consumed
+
+newRemoteControl :: IO RemoteControl
+newRemoteControl = newChan
diff --git a/Assistant/WebApp/Configurators.hs b/Assistant/WebApp/Configurators.hs
index 625546d..1978e52 100644
--- a/Assistant/WebApp/Configurators.hs
+++ b/Assistant/WebApp/Configurators.hs
@@ -39,6 +39,14 @@ makeMiscRepositories = $(widgetFile "configurators/addrepository/misc")
makeCloudRepositories :: Widget
makeCloudRepositories = $(widgetFile "configurators/addrepository/cloud")
+makeXMPPConnection :: Widget
+makeXMPPConnection = $(widgetFile "configurators/addrepository/xmppconnection")
+
+makeSshRepository :: Widget
+makeSshRepository = $(widgetFile "configurators/addrepository/ssh")
+
+makeConnectionRepositories :: Widget
+makeConnectionRepositories = $(widgetFile "configurators/addrepository/connection")
+
makeArchiveRepositories :: Widget
makeArchiveRepositories = $(widgetFile "configurators/addrepository/archive")
-
diff --git a/Assistant/WebApp/Configurators/Delete.hs b/Assistant/WebApp/Configurators/Delete.hs
index 8d72853..093ccda 100644
--- a/Assistant/WebApp/Configurators/Delete.hs
+++ b/Assistant/WebApp/Configurators/Delete.hs
@@ -39,13 +39,21 @@ notCurrentRepo uuid a = do
go Nothing = error "Unknown UUID"
go (Just _) = a
+handleXMPPRemoval :: UUID -> Handler Html -> Handler Html
+handleXMPPRemoval uuid nonxmpp = do
+ remote <- fromMaybe (error "unknown remote")
+ <$> liftAnnex (Remote.remoteFromUUID uuid)
+ if Remote.isXMPPRemote remote
+ then deletionPage $ $(widgetFile "configurators/delete/xmpp")
+ else nonxmpp
+
getDisableRepositoryR :: UUID -> Handler Html
-getDisableRepositoryR uuid = notCurrentRepo uuid $ do
+getDisableRepositoryR uuid = notCurrentRepo uuid $ handleXMPPRemoval uuid $ do
void $ liftAssistant $ disableRemote uuid
redirect DashboardR
getDeleteRepositoryR :: UUID -> Handler Html
-getDeleteRepositoryR uuid = notCurrentRepo uuid $
+getDeleteRepositoryR uuid = notCurrentRepo uuid $ handleXMPPRemoval uuid $ do
deletionPage $ do
reponame <- liftAnnex $ Remote.prettyUUID uuid
$(widgetFile "configurators/delete/start")
diff --git a/Assistant/WebApp/Configurators/Edit.hs b/Assistant/WebApp/Configurators/Edit.hs
index f005e17..22483dd 100644
--- a/Assistant/WebApp/Configurators/Edit.hs
+++ b/Assistant/WebApp/Configurators/Edit.hs
@@ -11,11 +11,12 @@ module Assistant.WebApp.Configurators.Edit where
import Assistant.WebApp.Common
import Assistant.WebApp.Gpg
+import Assistant.WebApp.Configurators
import Assistant.DaemonStatus
import Assistant.WebApp.MakeRemote (uniqueRemoteName)
-import Assistant.WebApp.Configurators.XMPP (xmppNeeded)
import Assistant.ScanRemotes
import Assistant.Sync
+import Assistant.Alert
import qualified Assistant.WebApp.Configurators.AWS as AWS
import qualified Assistant.WebApp.Configurators.IA as IA
#ifdef WITH_S3
@@ -183,7 +184,7 @@ getEditNewCloudRepositoryR :: UUID -> Handler Html
getEditNewCloudRepositoryR = postEditNewCloudRepositoryR
postEditNewCloudRepositoryR :: UUID -> Handler Html
-postEditNewCloudRepositoryR uuid = xmppNeeded >> editForm True (RepoUUID uuid)
+postEditNewCloudRepositoryR uuid = connectionNeeded >> editForm True (RepoUUID uuid)
editForm :: Bool -> RepoId -> Handler Html
editForm new (RepoUUID uuid) = page "Edit repository" (Just Configuration) $ do
@@ -275,3 +276,23 @@ getUpgradeRepositoryR r = go =<< liftAnnex (repoIdRemote r)
liftAssistant updateSyncRemotes
liftAssistant $ syncRemote rmt
redirect DashboardR
+
+{- If there is no currently connected remote, display an alert suggesting
+ - to set up one. -}
+connectionNeeded :: Handler ()
+connectionNeeded = whenM noconnection $ do
+ urlrender <- getUrlRender
+ void $ liftAssistant $ do
+ close <- asIO1 removeAlert
+ addAlert $ connectionNeededAlert $ AlertButton
+ { buttonLabel = "Connnect"
+ , buttonUrl = urlrender ConnectionNeededR
+ , buttonAction = Just close
+ , buttonPrimary = True
+ }
+ where
+ noconnection = S.null . currentlyConnectedRemotes <$> liftAssistant getDaemonStatus
+
+getConnectionNeededR :: Handler Html
+getConnectionNeededR = page "Connection needed" (Just Configuration) $ do
+ $(widgetFile "configurators/needconnection")
diff --git a/Assistant/WebApp/Configurators/Local.hs b/Assistant/WebApp/Configurators/Local.hs
index 9373116..5dcb920 100644
--- a/Assistant/WebApp/Configurators/Local.hs
+++ b/Assistant/WebApp/Configurators/Local.hs
@@ -27,7 +27,6 @@ import Utility.DiskFree
import Utility.Mounts
#endif
import Utility.DataUnits
-import Utility.Network
import Remote (prettyUUID)
import Annex.UUID
import Annex.Direct
diff --git a/Assistant/WebApp/Configurators/Pairing.hs b/Assistant/WebApp/Configurators/Pairing.hs
index 3dd10c1..c364346 100644
--- a/Assistant/WebApp/Configurators/Pairing.hs
+++ b/Assistant/WebApp/Configurators/Pairing.hs
@@ -21,7 +21,6 @@ import Assistant.Ssh
import Assistant.Alert
import Assistant.DaemonStatus
import Utility.Verifiable
-import Utility.Network
#endif
#ifdef WITH_XMPP
import Assistant.XMPP.Client
diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs
index 90a8c52..d5bde62 100644
--- a/Assistant/WebApp/Configurators/Ssh.hs
+++ b/Assistant/WebApp/Configurators/Ssh.hs
@@ -24,6 +24,7 @@ import Git.Types (RemoteName)
import qualified Remote.GCrypt as GCrypt
import Annex.UUID
import Logs.UUID
+import Assistant.RemoteControl
#ifdef mingw32_HOST_OS
import Utility.Tmp
@@ -155,7 +156,7 @@ postEnableSshGCryptR :: UUID -> Handler Html
postEnableSshGCryptR u = whenGcryptInstalled $
enableSpecialSshRemote getsshinput enableRsyncNetGCrypt enablegcrypt u
where
- enablegcrypt sshdata _ = prepSsh True sshdata $ \sshdata' ->
+ enablegcrypt sshdata _ = prepSsh False sshdata $ \sshdata' ->
sshConfigurator $
checkExistingGCrypt sshdata' $
error "Expected to find an encrypted git repository, but did not."
@@ -194,6 +195,16 @@ enableSpecialSshRemote getsshinput rsyncnetsetup genericsetup u = do
description <- liftAnnex $ T.pack <$> prettyUUID u
$(widgetFile "configurators/ssh/enable")
+{- To deal with git-annex and possibly even git and rsync not being
+ - available in the remote server's PATH, when git-annex was installed
+ - from the standalone tarball etc, look for a ~/.ssh/git-annex-wrapper
+ - and if it's there, use it to run a command. -}
+wrapCommand :: String -> String
+wrapCommand cmd = "if [ -x " ++ commandWrapper ++ " ]; then " ++ commandWrapper ++ " " ++ cmd ++ "; else " ++ cmd ++ "; fi"
+
+commandWrapper :: String
+commandWrapper = "~/.ssh/git-annex-wrapper"
+
{- Test if we can ssh into the server.
-
- Two probe attempts are made. First, try sshing in using the existing
@@ -203,8 +214,11 @@ enableSpecialSshRemote getsshinput rsyncnetsetup genericsetup u = do
-
- Once logged into the server, probe to see if git-annex-shell,
- git, and rsync are available.
+ -
- Note that, ~/.ssh/git-annex-shell may be
- present, while git-annex-shell is not in PATH.
+ - Also, git and rsync may not be in PATH; as long as the commandWrapper
+ - is present, assume it is able to be used to run them.
-
- Also probe to see if there is already a git repository at the location
- with either an annex-uuid or a gcrypt-id set. (If not, returns NoUUID.)
@@ -235,6 +249,7 @@ testServer sshinput@(SshInput { inputHostname = Just hn }) = do
, checkcommand "git"
, checkcommand "rsync"
, checkcommand shim
+ , checkcommand commandWrapper
, getgitconfig (T.unpack <$> inputDirectory sshinput)
]
knownhost <- knownHost hn
@@ -257,6 +272,8 @@ testServer sshinput@(SshInput { inputHostname = Just hn }) = do
, (shim, GitAnnexShellCapable)
, ("git", GitCapable)
, ("rsync", RsyncCapable)
+ , (commandWrapper, GitCapable)
+ , (commandWrapper, RsyncCapable)
]
u = fromMaybe NoUUID $ headMaybe $ mapMaybe finduuid $
map (separate (== '=')) $ lines s
@@ -275,7 +292,7 @@ testServer sshinput@(SshInput { inputHostname = Just hn }) = do
checkcommand c = "if which " ++ c ++ "; then " ++ report c ++ "; fi"
token r = "git-annex-probe " ++ r
- report r = "echo " ++ token r
+ report r = "echo " ++ shellEscape (token r)
shim = "~/.ssh/git-annex-shell"
getgitconfig (Just d)
| not (null d) = "cd " ++ shellEscape d ++ " && git config --list"
@@ -294,7 +311,8 @@ showSshErr :: String -> Handler Html
showSshErr msg = sshConfigurator $
$(widgetFile "configurators/ssh/error")
-{- The UUID will be NoUUID when the repository does not already exist. -}
+{- The UUID will be NoUUID when the repository does not already exist,
+ - or was not a git-annex repository before. -}
getConfirmSshR :: SshData -> UUID -> Handler Html
getConfirmSshR sshdata u
| u == NoUUID = handlenew
@@ -328,8 +346,9 @@ getRetrySshR sshdata = do
s <- liftIO $ testServer $ mkSshInput sshdata
redirect $ either (const $ ConfirmSshR sshdata NoUUID) (uncurry ConfirmSshR) s
+{- Making a new git repository. -}
getMakeSshGitR :: SshData -> Handler Html
-getMakeSshGitR sshdata = prepSsh False sshdata makeSshRepo
+getMakeSshGitR sshdata = prepSsh True sshdata makeSshRepo
getMakeSshRsyncR :: SshData -> Handler Html
getMakeSshRsyncR sshdata = prepSsh False (rsyncOnly sshdata) makeSshRepo
@@ -341,7 +360,7 @@ getMakeSshGCryptR :: SshData -> RepoKey -> Handler Html
getMakeSshGCryptR sshdata NoRepoKey = whenGcryptInstalled $
withNewSecretKey $ getMakeSshGCryptR sshdata . RepoKey
getMakeSshGCryptR sshdata (RepoKey keyid) = whenGcryptInstalled $
- prepSsh True sshdata $ makeGCryptRepo keyid
+ prepSsh False sshdata $ makeGCryptRepo keyid
{- Detect if the user entered a location with an existing, known
- gcrypt repository, and enable it. Otherwise, runs the action. -}
@@ -373,18 +392,18 @@ combineExistingGCrypt sshdata u = do
{- Sets up remote repository for ssh, or directory for rsync. -}
prepSsh :: Bool -> SshData -> (SshData -> Handler Html) -> Handler Html
-prepSsh newgcrypt sshdata a
+prepSsh needsinit sshdata a
| needsPubKey sshdata = do
keypair <- liftIO genSshKeyPair
sshdata' <- liftIO $ setupSshKeyPair keypair sshdata
- prepSsh' newgcrypt sshdata sshdata' (Just keypair) a
+ prepSsh' needsinit sshdata sshdata' (Just keypair) a
| sshPort sshdata /= 22 = do
sshdata' <- liftIO $ setSshConfig sshdata []
- prepSsh' newgcrypt sshdata sshdata' Nothing a
- | otherwise = prepSsh' newgcrypt sshdata sshdata Nothing a
+ prepSsh' needsinit sshdata sshdata' Nothing a
+ | otherwise = prepSsh' needsinit sshdata sshdata Nothing a
prepSsh' :: Bool -> SshData -> SshData -> Maybe SshKeyPair -> (SshData -> Handler Html) -> Handler Html
-prepSsh' newgcrypt origsshdata sshdata keypair a = sshSetup
+prepSsh' needsinit origsshdata sshdata keypair a = sshSetup
[ "-p", show (sshPort origsshdata)
, genSshHost (sshHostName origsshdata) (sshUserName origsshdata)
, remoteCommand
@@ -394,8 +413,14 @@ prepSsh' newgcrypt origsshdata sshdata keypair a = sshSetup
remoteCommand = shellWrap $ intercalate "&&" $ catMaybes
[ Just $ "mkdir -p " ++ shellEscape remotedir
, Just $ "cd " ++ shellEscape remotedir
- , if rsynconly then Nothing else Just "if [ ! -d .git ]; then git init --bare --shared && git config receive.denyNonFastforwards false; fi"
- , if rsynconly || newgcrypt then Nothing else Just "git annex init"
+ , if rsynconly then Nothing else Just $ unwords
+ [ "if [ ! -d .git ]; then"
+ , wrapCommand "git init --bare --shared"
+ , "&&"
+ , wrapCommand "git config receive.denyNonFastforwards"
+ , ";fi"
+ ]
+ , if needsinit then Just (wrapCommand "git annex init") else Nothing
, if needsPubKey origsshdata
then addAuthorizedKeysCommand (hasCapability origsshdata GitAnnexShellCapable) remotedir . sshPubKey <$> keypair
else Nothing
@@ -403,11 +428,21 @@ prepSsh' newgcrypt origsshdata sshdata keypair a = sshSetup
rsynconly = onlyCapability origsshdata RsyncCapable
makeSshRepo :: SshData -> Handler Html
-makeSshRepo sshdata = setupCloudRemote TransferGroup Nothing $
- makeSshRemote sshdata
+makeSshRepo sshdata
+ | onlyCapability sshdata RsyncCapable = setupCloudRemote TransferGroup Nothing go
+ | otherwise = makeSshRepoConnection go
+ where
+ go = makeSshRemote sshdata
+
+makeSshRepoConnection :: Annex RemoteName -> Handler Html
+makeSshRepoConnection a = setupRemote postsetup TransferGroup Nothing a
+ where
+ postsetup u = do
+ liftAssistant $ sendRemoteControl RELOAD
+ redirect $ EditNewRepositoryR u
makeGCryptRepo :: KeyId -> SshData -> Handler Html
-makeGCryptRepo keyid sshdata = setupCloudRemote TransferGroup Nothing $
+makeGCryptRepo keyid sshdata = makeSshRepoConnection $
makeGCryptRemote (sshRepoName sshdata) (genSshUrl sshdata) keyid
getAddRsyncNetR :: Handler Html
diff --git a/Assistant/WebApp/Configurators/XMPP.hs b/Assistant/WebApp/Configurators/XMPP.hs
index e7ba6c0..047e86a 100644
--- a/Assistant/WebApp/Configurators/XMPP.hs
+++ b/Assistant/WebApp/Configurators/XMPP.hs
@@ -25,6 +25,9 @@ import Assistant.WebApp.RepoList
import Assistant.WebApp.Configurators
import Assistant.XMPP
#endif
+import qualified Git.Remote
+import Remote.List
+import Creds
#ifdef WITH_XMPP
import Network.Protocol.XMPP
@@ -32,23 +35,6 @@ import Network
import qualified Data.Text as T
#endif
-{- Displays an alert suggesting to configure XMPP. -}
-xmppNeeded :: Handler ()
-#ifdef WITH_XMPP
-xmppNeeded = whenM (isNothing <$> liftAnnex getXMPPCreds) $ do
- urlrender <- getUrlRender
- void $ liftAssistant $ do
- close <- asIO1 removeAlert
- addAlert $ xmppNeededAlert $ AlertButton
- { buttonLabel = "Configure a Jabber account"
- , buttonUrl = urlrender XMPPConfigR
- , buttonAction = Just close
- , buttonPrimary = True
- }
-#else
-xmppNeeded = return ()
-#endif
-
{- When appropriate, displays an alert suggesting to configure a cloud repo
- to suppliment an XMPP remote. -}
checkCloudRepos :: UrlRenderer -> Remote -> Assistant ()
@@ -219,5 +205,22 @@ testXMPP creds = do
showport (UnixSocket s) = s
#endif
+getDisconnectXMPPR :: Handler Html
+getDisconnectXMPPR = do
+#ifdef WITH_XMPP
+ rs <- filter Remote.isXMPPRemote . syncRemotes
+ <$> liftAssistant getDaemonStatus
+ liftAnnex $ do
+ mapM_ (inRepo . Git.Remote.remove . Remote.name) rs
+ void remoteListRefresh
+ removeCreds xmppCredsFile
+ liftAssistant $ do
+ updateSyncRemotes
+ notifyNetMessagerRestart
+ redirect DashboardR
+#else
+ xmppPage $ $(widgetFile "configurators/xmpp/disabled")
+#endif
+
xmppPage :: Widget -> Handler Html
xmppPage = page "Jabber" (Just Configuration)
diff --git a/Assistant/WebApp/MakeRemote.hs b/Assistant/WebApp/MakeRemote.hs
index 749fbd5..f088b34 100644
--- a/Assistant/WebApp/MakeRemote.hs
+++ b/Assistant/WebApp/MakeRemote.hs
@@ -26,12 +26,18 @@ import Utility.Yesod
{- Runs an action that creates or enables a cloud remote,
- and finishes setting it up, then starts syncing with it,
- - and finishes by displaying the page to edit it. -}
+ - and finishes by displaying the page to edit it.
+ -
+ - This includes displaying the connectionNeeded nudge if appropariate.
+ -}
setupCloudRemote :: StandardGroup -> Maybe Cost -> Annex RemoteName -> Handler a
-setupCloudRemote defaultgroup mcost name = do
- r <- liftAnnex $ addRemote name
+setupCloudRemote = setupRemote $ redirect . EditNewCloudRepositoryR
+
+setupRemote :: (UUID -> Handler a) -> StandardGroup -> Maybe Cost -> Annex RemoteName -> Handler a
+setupRemote postsetup defaultgroup mcost getname = do
+ r <- liftAnnex $ addRemote getname
liftAnnex $ do
setStandardGroup (Remote.uuid r) defaultgroup
maybe noop (Config.setRemoteCost (Remote.repo r)) mcost
liftAssistant $ syncRemote r
- redirect $ EditNewCloudRepositoryR $ Remote.uuid r
+ postsetup $ Remote.uuid r
diff --git a/Assistant/WebApp/RepoList.hs b/Assistant/WebApp/RepoList.hs
index 6a93cb4..1d91659 100644
--- a/Assistant/WebApp/RepoList.hs
+++ b/Assistant/WebApp/RepoList.hs
@@ -33,9 +33,10 @@ import qualified Data.Text as T
import Data.Function
import Control.Concurrent
-type RepoList = [(RepoDesc, RepoId, Actions)]
+type RepoList = [(RepoDesc, RepoId, CurrentlyConnected, Actions)]
type RepoDesc = String
+type CurrentlyConnected = Bool
{- Actions that can be performed on a repo in the list. -}
data Actions
@@ -192,13 +193,19 @@ repoList reposelector
where
getconfig k = M.lookup k =<< M.lookup u m
val iscloud r = Just (iscloud, (RepoUUID u, DisabledRepoActions $ r u))
- list l = liftAnnex $
+ list l = do
+ cc <- currentlyConnectedRemotes <$> liftAssistant getDaemonStatus
forM (nubBy ((==) `on` fst) l) $ \(repoid, actions) ->
- (,,)
- <$> describeRepoId repoid
+ (,,,)
+ <$> liftAnnex (describeRepoId repoid)
<*> pure repoid
+ <*> pure (getCurrentlyConnected repoid cc)
<*> pure actions
+getCurrentlyConnected :: RepoId -> S.Set UUID -> CurrentlyConnected
+getCurrentlyConnected (RepoUUID u) cc = S.member u cc
+getCurrentlyConnected _ _ = False
+
getEnableSyncR :: RepoId -> Handler ()
getEnableSyncR = flipSync True
diff --git a/Assistant/WebApp/SideBar.hs b/Assistant/WebApp/SideBar.hs
index 2c33ec8..a8f0850 100644
--- a/Assistant/WebApp/SideBar.hs
+++ b/Assistant/WebApp/SideBar.hs
@@ -103,8 +103,7 @@ htmlIcon InfoIcon = bootstrapIcon "info-sign"
htmlIcon SuccessIcon = bootstrapIcon "ok"
htmlIcon ErrorIcon = bootstrapIcon "exclamation-sign"
htmlIcon UpgradeIcon = bootstrapIcon "arrow-up"
--- utf-8 umbrella (utf-8 cloud looks too stormy)
-htmlIcon TheCloud = [whamlet|&#9730;|]
+htmlIcon ConnectionIcon = bootstrapIcon "signal"
bootstrapIcon :: Text -> Widget
bootstrapIcon name = [whamlet|<i .icon-#{name}></i>|]
diff --git a/Assistant/WebApp/routes b/Assistant/WebApp/routes
index 44e07c6..dbdaabe 100644
--- a/Assistant/WebApp/routes
+++ b/Assistant/WebApp/routes
@@ -20,6 +20,8 @@
/config/xmpp/for/self XMPPConfigForPairSelfR GET POST
/config/xmpp/for/frield XMPPConfigForPairFriendR GET POST
/config/xmpp/needcloudrepo/#UUID NeedCloudRepoR GET
+/config/xmpp/disconnect DisconnectXMPPR GET
+/config/needconnection ConnectionNeededR GET
/config/fsck ConfigFsckR GET POST
/config/fsck/preferences ConfigFsckPreferencesR POST
/config/upgrade/start/#GitAnnexDistribution ConfigStartUpgradeR GET
diff --git a/Assistant/XMPP/Git.hs b/Assistant/XMPP/Git.hs
index ab34dce..36ada5c 100644
--- a/Assistant/XMPP/Git.hs
+++ b/Assistant/XMPP/Git.hs
@@ -74,7 +74,7 @@ makeXMPPGitRemote :: String -> JID -> UUID -> Assistant Bool
makeXMPPGitRemote buddyname jid u = do
remote <- liftAnnex $ addRemote $
makeGitRemote buddyname $ gitXMPPLocation jid
- liftAnnex $ storeUUID (remoteConfig (Remote.repo remote) "uuid") u
+ liftAnnex $ storeUUIDIn (remoteConfig (Remote.repo remote) "uuid") u
liftAnnex $ void remoteListRefresh
remote' <- liftAnnex $ fromMaybe (error "failed to add remote")
<$> Remote.byName (Just buddyname)
diff --git a/Backend.hs b/Backend.hs
index 3831468..dded0d0 100644
--- a/Backend.hs
+++ b/Backend.hs
@@ -1,6 +1,6 @@
{- git-annex key/value backends
-
- - Copyright 2010,2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2014 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -10,6 +10,7 @@ module Backend (
orderedList,
genKey,
lookupFile,
+ getBackend,
isAnnexLink,
chooseBackend,
lookupBackendName,
@@ -74,7 +75,7 @@ genKey' (b:bs) source = do
| c == '\n' = '_'
| otherwise = c
-{- Looks up the key and backend corresponding to an annexed file,
+{- Looks up the key corresponding to an annexed file,
- by examining what the file links to.
-
- In direct mode, there is often no link on disk, in which case
@@ -82,7 +83,7 @@ genKey' (b:bs) source = do
- on disk still takes precedence over what was committed to git in direct
- mode.
-}
-lookupFile :: FilePath -> Annex (Maybe (Key, Backend))
+lookupFile :: FilePath -> Annex (Maybe Key)
lookupFile file = do
mkey <- isAnnexLink file
case mkey of
@@ -92,14 +93,15 @@ lookupFile file = do
, return Nothing
)
where
- makeret k = let bname = keyBackendName k in
- case maybeLookupBackendName bname of
- Just backend -> return $ Just (k, backend)
- Nothing -> do
- warning $
- "skipping " ++ file ++
- " (unknown backend " ++ bname ++ ")"
- return Nothing
+ makeret k = return $ Just k
+
+getBackend :: FilePath -> Key -> Annex (Maybe Backend)
+getBackend file k = let bname = keyBackendName k in
+ case maybeLookupBackendName bname of
+ Just backend -> return $ Just backend
+ Nothing -> do
+ warning $ "skipping " ++ file ++ " (unknown backend " ++ bname ++ ")"
+ return Nothing
{- Looks up the backend that should be used for a file.
- That can be configured on a per-file basis in the gitattributes file. -}
diff --git a/Build/Configure.hs b/Build/Configure.hs
index 116a442..c5e3b97 100644
--- a/Build/Configure.hs
+++ b/Build/Configure.hs
@@ -7,6 +7,7 @@ import Control.Applicative
import System.Environment (getArgs)
import Control.Monad.IfElse
import Control.Monad
+import System.IO
import Build.TestConfig
import Build.Version
@@ -62,7 +63,11 @@ shaTestCases l = map make l
key = "sha" ++ show n
search [] = return Nothing
search (c:cmds) = do
+ putStr $ "(" ++ c
+ hFlush stdout
sha <- externalSHA c n "/dev/null"
+ putStr $ ":" ++ show sha ++ ")"
+ hFlush stdout
if sha == Right knowngood
then return $ Just c
else search cmds
diff --git a/Build/DistributionUpdate.hs b/Build/DistributionUpdate.hs
index a681ec2..3a4c550 100644
--- a/Build/DistributionUpdate.hs
+++ b/Build/DistributionUpdate.hs
@@ -1,6 +1,9 @@
{- Builds distributon info files for each git-annex release in a directory
- tree, which must itself be part of a git-annex repository. Only files
- - that are present have their info file created. -}
+ - that are present have their info file created.
+ -
+ - Also gpg signs the files.
+ -}
import Common.Annex
import Types.Distribution
@@ -15,6 +18,10 @@ import Git.Command
import Data.Time.Clock
+-- git-annex distribution signing key (for Joey Hess)
+signingKey :: String
+signingKey = "89C809CB"
+
main = do
state <- Annex.new =<< Git.Construct.fromPath =<< getRepoDir
Annex.eval state makeinfos
@@ -36,7 +43,7 @@ makeinfos = do
v <- lookupFile f
case v of
Nothing -> noop
- Just (k, _b) -> whenM (inAnnex k) $ do
+ Just k -> whenM (inAnnex k) $ do
liftIO $ putStrLn f
let infofile = f ++ ".info"
liftIO $ writeFile infofile $ show $ GitAnnexDistribution
@@ -46,7 +53,9 @@ makeinfos = do
, distributionReleasedate = now
, distributionUrgentUpgrade = Nothing
}
- void $ inRepo $ runBool [Param "add", Param infofile]
+ void $ inRepo $ runBool [Param "add", File infofile]
+ signFile infofile
+ signFile f
void $ inRepo $ runBool
[ Param "commit"
, Param "-m"
@@ -81,3 +90,14 @@ getRepoDir = do
mkUrl :: FilePath -> FilePath -> String
mkUrl basedir f = "https://downloads.kitenet.net/" ++ relPathDirToFile basedir f
+
+signFile :: FilePath -> Annex ()
+signFile f = do
+ void $ liftIO $ boolSystem "gpg"
+ [ Param "-a"
+ , Param $ "--default-key=" ++ signingKey
+ , Param "--sign"
+ , File f
+ ]
+ liftIO $ rename (f ++ ".asc") (f ++ ".sig")
+ void $ inRepo $ runBool [Param "add", File (f ++ ".sig")]
diff --git a/CHANGELOG b/CHANGELOG
index a883ddd..8d48162 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -1,3 +1,45 @@
+git-annex (5.20140421) unstable; urgency=medium
+
+ * assistant: Now detects immediately when other repositories push
+ changes to a ssh remote, and pulls.
+ ** XMPP is no longer needed in this configuration! **
+ This requires the remote server have git-annex-shell with
+ notifychanges support (>= 5.20140405)
+ * webapp: Show a network signal icon next to ssh and xmpp remotes that
+ it's currently connected with.
+ * webapp: Rework xmpp nudge to prompt for either xmpp or a ssh remote
+ to be set up.
+ * sync, assistant, remotedaemon: Use ssh connection caching for git pushes
+ and pulls.
+ * remotedaemon: When network connection is lost, close all cached ssh
+ connections.
+ * Improve handling of monthly/yearly scheduling.
+ * Avoid depending on shakespeare except for when building the webapp.
+ * uninit: Avoid making unncessary copies of files.
+ * info: Allow use in a repository where annex.uuid is not set.
+ * reinit: New command that can initialize a new repository using
+ the configuration of a previously known repository.
+ Useful if a repository got deleted and you want
+ to clone it back the way it was.
+ * drop --from: When local repository is untrusted, its copy of a file does
+ not count.
+ * Bring back rsync -p, but only when git-annex is running on a non-crippled
+ file system. This is a better approach to fix #700282 while not
+ unncessarily losing file permissions on non-crippled systems.
+ * webapp: Start even if the current directory is listed in
+ ~/.config/git-annex/autostart but no longer has a git repository in it.
+ * findref: New command, like find but shows files in a specified git ref.
+ * webapp: Fix UI for removing XMPP connection.
+ * When init detects that git is not configured to commit, and sets
+ user.email to work around the problem, also make it set user.name.
+ * webapp: Support using git-annex on a remote server, which was installed
+ from the standalone tarball or OSX app, and so does not have
+ git-annex in PATH (and may also not have git or rsync in PATH).
+ * standalone tarball, OSX app: Install a ~/.ssh/git-annex-wrapper, which
+ can be used to run git-annex, git, rsync, etc.
+
+ -- Joey Hess <joeyh@debian.org> Sun, 20 Apr 2014 19:43:14 -0400
+
git-annex (5.20140412) unstable; urgency=high
* Last release didn't quite fix the high cpu issue in all cases, this should.
diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs
index 9f6eb5f..c37e44a 100644
--- a/CmdLine/GitAnnex.hs
+++ b/CmdLine/GitAnnex.hs
@@ -1,6 +1,6 @@
{- git-annex main program
-
- - Copyright 2010-2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2014 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -12,6 +12,8 @@ module CmdLine.GitAnnex where
import qualified Git.CurrentRepo
import CmdLine
import Command
+import Utility.Env
+import Annex.Ssh
import qualified Command.Add
import qualified Command.Unannex
@@ -47,6 +49,7 @@ import qualified Command.Unlock
import qualified Command.Lock
import qualified Command.PreCommit
import qualified Command.Find
+import qualified Command.FindRef
import qualified Command.Whereis
import qualified Command.List
import qualified Command.Log
@@ -55,6 +58,7 @@ import qualified Command.Info
import qualified Command.Status
import qualified Command.Migrate
import qualified Command.Uninit
+import qualified Command.Reinit
import qualified Command.NumCopies
import qualified Command.Trust
import qualified Command.Untrust
@@ -123,6 +127,7 @@ cmds = concat
, Command.Reinject.def
, Command.Unannex.def
, Command.Uninit.def
+ , Command.Reinit.def
, Command.PreCommit.def
, Command.NumCopies.def
, Command.Trust.def
@@ -154,6 +159,7 @@ cmds = concat
, Command.DropUnused.def
, Command.AddUnused.def
, Command.Find.def
+ , Command.FindRef.def
, Command.Whereis.def
, Command.List.def
, Command.Log.def
@@ -193,4 +199,5 @@ run args = do
#ifdef WITH_EKG
_ <- forkServer "localhost" 4242
#endif
- dispatch True args cmds gitAnnexOptions [] header Git.CurrentRepo.get
+ maybe (dispatch True args cmds gitAnnexOptions [] header Git.CurrentRepo.get)
+ (runSshCaching args) =<< getEnv sshCachingEnv
diff --git a/CmdLine/Seek.hs b/CmdLine/Seek.hs
index abbe52a..431b2e1 100644
--- a/CmdLine/Seek.hs
+++ b/CmdLine/Seek.hs
@@ -19,6 +19,8 @@ import qualified Annex
import qualified Git
import qualified Git.Command
import qualified Git.LsFiles as LsFiles
+import qualified Git.LsTree as LsTree
+import Git.FilePath
import qualified Limit
import CmdLine.Option
import CmdLine.Action
@@ -49,6 +51,20 @@ withFilesNotInGit skipdotfiles a params
go l = seekActions $ prepFiltered a $
return $ concat $ segmentPaths params l
+withFilesInRefs :: (FilePath -> Key -> CommandStart) -> CommandSeek
+withFilesInRefs a = mapM_ go
+ where
+ go r = do
+ matcher <- Limit.getMatcher
+ l <- inRepo $ LsTree.lsTree (Git.Ref r)
+ forM_ l $ \i -> do
+ let f = getTopFilePath $ LsTree.file i
+ v <- catKey (Git.Ref $ LsTree.sha i) (LsTree.mode i)
+ case v of
+ Nothing -> noop
+ Just k -> whenM (matcher $ MatchingKey k) $
+ void $ commandAction $ a f k
+
withPathContents :: ((FilePath, FilePath) -> CommandStart) -> CommandSeek
withPathContents a params = seekActions $
map a . concat <$> liftIO (mapM get params)
diff --git a/CmdLine/Usage.hs b/CmdLine/Usage.hs
index 1d0bba9..6e0a1ca 100644
--- a/CmdLine/Usage.hs
+++ b/CmdLine/Usage.hs
@@ -93,6 +93,8 @@ paramFormat :: String
paramFormat = "FORMAT"
paramFile :: String
paramFile = "FILE"
+paramRef :: String
+paramRef = "REF"
paramGroup :: String
paramGroup = "GROUP"
paramExpression :: String
diff --git a/Command.hs b/Command.hs
index 3faa405..fc440f2 100644
--- a/Command.hs
+++ b/Command.hs
@@ -70,11 +70,11 @@ stopUnless :: Annex Bool -> Annex (Maybe a) -> Annex (Maybe a)
stopUnless c a = ifM c ( a , stop )
{- Modifies an action to only act on files that are already annexed,
- - and passes the key and backend on to it. -}
-whenAnnexed :: (FilePath -> (Key, Backend) -> Annex (Maybe a)) -> FilePath -> Annex (Maybe a)
+ - and passes the key on to it. -}
+whenAnnexed :: (FilePath -> Key -> Annex (Maybe a)) -> FilePath -> Annex (Maybe a)
whenAnnexed a file = ifAnnexed file (a file) (return Nothing)
-ifAnnexed :: FilePath -> ((Key, Backend) -> Annex a) -> Annex a -> Annex a
+ifAnnexed :: FilePath -> (Key -> Annex a) -> Annex a -> Annex a
ifAnnexed file yes no = maybe no yes =<< Backend.lookupFile file
isBareRepo :: Annex Bool
diff --git a/Command/Add.hs b/Command/Add.hs
index f9e2b33..46a8731 100644
--- a/Command/Add.hs
+++ b/Command/Add.hs
@@ -73,7 +73,7 @@ start file = ifAnnexed file addpresent add
| otherwise -> do
showStart "add" file
next $ perform file
- addpresent (key, _) = ifM isDirect
+ addpresent key = ifM isDirect
( ifM (goodContent key file) ( stop , add )
, fixup key
)
diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs
index b108be5..7ffb869 100644
--- a/Command/AddUrl.hs
+++ b/Command/AddUrl.hs
@@ -96,7 +96,7 @@ performQuvi :: Bool -> URLString -> URLString -> FilePath -> CommandPerform
performQuvi relaxed pageurl videourl file = ifAnnexed file addurl geturl
where
quviurl = setDownloader pageurl QuviDownloader
- addurl (key, _backend) = next $ cleanup quviurl file key Nothing
+ addurl key = next $ cleanup quviurl file key Nothing
geturl = next $ addUrlFileQuvi relaxed quviurl videourl file
#endif
@@ -130,7 +130,7 @@ perform :: Bool -> URLString -> FilePath -> CommandPerform
perform relaxed url file = ifAnnexed file addurl geturl
where
geturl = next $ addUrlFile relaxed url file
- addurl (key, _backend)
+ addurl key
| relaxed = do
setUrlPresent key url
next $ return True
diff --git a/Command/Copy.hs b/Command/Copy.hs
index 2960606..ae254aa 100644
--- a/Command/Copy.hs
+++ b/Command/Copy.hs
@@ -30,9 +30,9 @@ seek ps = do
{- A copy is just a move that does not delete the source file.
- However, --auto mode avoids unnecessary copies, and avoids getting or
- sending non-preferred content. -}
-start :: Maybe Remote -> Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart
-start to from file (key, backend) = stopUnless shouldCopy $
- Command.Move.start to from False file (key, backend)
+start :: Maybe Remote -> Maybe Remote -> FilePath -> Key -> CommandStart
+start to from file key = stopUnless shouldCopy $
+ Command.Move.start to from False file key
where
shouldCopy = checkAuto (check <||> numCopiesCheck file key (<))
check = case to of
diff --git a/Command/Direct.hs b/Command/Direct.hs
index 47f622a..9727549 100644
--- a/Command/Direct.hs
+++ b/Command/Direct.hs
@@ -47,7 +47,7 @@ perform = do
void $ liftIO clean
next cleanup
where
- go = whenAnnexed $ \f (k, _) -> do
+ go = whenAnnexed $ \f k -> do
r <- toDirectGen k f
case r of
Nothing -> noop
diff --git a/Command/Drop.hs b/Command/Drop.hs
index 269c4c2..4bac07a 100644
--- a/Command/Drop.hs
+++ b/Command/Drop.hs
@@ -34,8 +34,8 @@ seek ps = do
from <- getOptionField dropFromOption Remote.byNameWithUUID
withFilesInGit (whenAnnexed $ start from) ps
-start :: Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart
-start from file (key, _) = checkDropAuto from file key $ \numcopies ->
+start :: Maybe Remote -> FilePath -> Key -> CommandStart
+start from file key = checkDropAuto from file key $ \numcopies ->
stopUnless (checkAuto $ wantDrop False (Remote.uuid <$> from) (Just key) (Just file)) $
case from of
Nothing -> startLocal (Just file) numcopies key Nothing
@@ -78,12 +78,18 @@ performRemote :: Key -> AssociatedFile -> NumCopies -> Remote -> CommandPerform
performRemote key afile numcopies remote = lockContent key $ do
-- Filter the remote it's being dropped from out of the lists of
-- places assumed to have the key, and places to check.
- -- When the local repo has the key, that's one additional copy.
+ -- When the local repo has the key, that's one additional copy,
+ -- as long asthe local repo is not untrusted.
(remotes, trusteduuids) <- Remote.keyPossibilitiesTrusted key
present <- inAnnex key
u <- getUUID
- let have = filter (/= uuid) $
- if present then u:trusteduuids else trusteduuids
+ trusteduuids' <- if present
+ then ifM ((<= SemiTrusted) <$> lookupTrust u)
+ ( pure (u:trusteduuids)
+ , pure trusteduuids
+ )
+ else pure trusteduuids
+ let have = filter (/= uuid) trusteduuids'
untrusteduuids <- trustGet UnTrusted
let tocheck = filter (/= remote) $
Remote.remotesWithoutUUID remotes (have++untrusteduuids)
diff --git a/Command/Find.hs b/Command/Find.hs
index c6a32a9..c800933 100644
--- a/Command/Find.hs
+++ b/Command/Find.hs
@@ -19,8 +19,10 @@ import Utility.DataUnits
import Types.Key
def :: [Command]
-def = [noCommit $ noMessages $ withOptions [formatOption, print0Option, jsonOption] $
- command "find" paramPaths seek SectionQuery "lists available files"]
+def = [mkCommand $ command "find" paramPaths seek SectionQuery "lists available files"]
+
+mkCommand :: Command -> Command
+mkCommand = noCommit . noMessages . withOptions [formatOption, print0Option, jsonOption]
formatOption :: Option
formatOption = fieldOption [] "format" paramFormat "control format of output"
@@ -39,8 +41,8 @@ seek ps = do
format <- getFormat
withFilesInGit (whenAnnexed $ start format) ps
-start :: Maybe Utility.Format.Format -> FilePath -> (Key, Backend) -> CommandStart
-start format file (key, _) = do
+start :: Maybe Utility.Format.Format -> FilePath -> Key -> CommandStart
+start format file key = do
-- only files inAnnex are shown, unless the user has requested
-- others via a limit
whenM (limited <||> inAnnex key) $
diff --git a/Command/FindRef.hs b/Command/FindRef.hs
new file mode 100644
index 0000000..26007f7
--- /dev/null
+++ b/Command/FindRef.hs
@@ -0,0 +1,20 @@
+{- git-annex command
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.FindRef where
+
+import Command
+import qualified Command.Find as Find
+
+def :: [Command]
+def = [Find.mkCommand $ command "findref" paramRef seek SectionPlumbing
+ "lists files in a git ref"]
+
+seek :: CommandSeek
+seek refs = do
+ format <- Find.getFormat
+ Find.start format `withFilesInRefs` refs
diff --git a/Command/Fix.hs b/Command/Fix.hs
index f730226..0c2bf59 100644
--- a/Command/Fix.hs
+++ b/Command/Fix.hs
@@ -26,8 +26,8 @@ seek :: CommandSeek
seek = withFilesInGit $ whenAnnexed start
{- Fixes the symlink to an annexed file. -}
-start :: FilePath -> (Key, Backend) -> CommandStart
-start file (key, _) = do
+start :: FilePath -> Key -> CommandStart
+start file key = do
link <- inRepo $ gitAnnexLink file key
stopUnless ((/=) (Just link) <$> liftIO (catchMaybeIO $ readSymbolicLink file)) $ do
showStart "fix" file
diff --git a/Command/Fsck.hs b/Command/Fsck.hs
index 88a9915..a17662d 100644
--- a/Command/Fsck.hs
+++ b/Command/Fsck.hs
@@ -104,12 +104,16 @@ getIncremental = do
resetStartTime
return True
-start :: Maybe Remote -> Incremental -> FilePath -> (Key, Backend) -> CommandStart
-start from inc file (key, backend) = do
- numcopies <- getFileNumCopies file
- case from of
- Nothing -> go $ perform key file backend numcopies
- Just r -> go $ performRemote key file backend numcopies r
+start :: Maybe Remote -> Incremental -> FilePath -> Key -> CommandStart
+start from inc file key = do
+ v <- Backend.getBackend file key
+ case v of
+ Nothing -> stop
+ Just backend -> do
+ numcopies <- getFileNumCopies file
+ case from of
+ Nothing -> go $ perform key file backend numcopies
+ Just r -> go $ performRemote key file backend numcopies r
where
go = runFsck inc file key
diff --git a/Command/Get.hs b/Command/Get.hs
index bef4667..d0be200 100644
--- a/Command/Get.hs
+++ b/Command/Get.hs
@@ -31,8 +31,8 @@ seek ps = do
(withFilesInGit $ whenAnnexed $ start from)
ps
-start :: Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart
-start from file (key, _) = start' expensivecheck from key (Just file)
+start :: Maybe Remote -> FilePath -> Key -> CommandStart
+start from file key = start' expensivecheck from key (Just file)
where
expensivecheck = checkAuto (numCopiesCheck file key (<) <||> wantGet False (Just key) (Just file))
diff --git a/Command/ImportFeed.hs b/Command/ImportFeed.hs
index 3f629af..29f2fb1 100644
--- a/Command/ImportFeed.hs
+++ b/Command/ImportFeed.hs
@@ -194,7 +194,7 @@ performDownload relaxed cache todownload = case location todownload of
in d </> show n ++ "_" ++ base
tryanother = makeunique url (n + 1) file
alreadyexists = liftIO $ isJust <$> catchMaybeIO (getSymbolicLinkStatus f)
- checksameurl (k, _) = ifM (elem url <$> getUrls k)
+ checksameurl k = ifM (elem url <$> getUrls k)
( return Nothing
, tryanother
)
@@ -224,11 +224,15 @@ feedFile tmpl i extension = Utility.Format.format tmpl $ M.fromList
fieldMaybe k Nothing = (k, "none")
fieldMaybe k (Just v) = field k v
+#if MIN_VERSION_feed(0,3,9)
pubdate itm = case getItemPublishDate itm :: Maybe (Maybe UTCTime) of
Just (Just d) -> Just $
formatTime defaultTimeLocale "%F" d
-- if date cannot be parsed, use the raw string
_ -> replace "/" "-" <$> getItemPublishDateString itm
+#else
+ pubdate _ = Nothing
+#endif
{- Called when there is a problem with a feed.
- Throws an error if the feed is broken, otherwise shows a warning. -}
diff --git a/Command/Indirect.hs b/Command/Indirect.hs
index c0dd579..acf40c9 100644
--- a/Command/Indirect.hs
+++ b/Command/Indirect.hs
@@ -74,7 +74,7 @@ perform = do
case r of
Just s
| isSymbolicLink s -> void $ flip whenAnnexed f $
- \_ (k, _) -> do
+ \_ k -> do
removeInodeCache k
removeAssociatedFiles k
return Nothing
diff --git a/Command/Info.hs b/Command/Info.hs
index 11ed98c..63bc92b 100644
--- a/Command/Info.hs
+++ b/Command/Info.hs
@@ -70,7 +70,7 @@ data StatInfo = StatInfo
type StatState = StateT StatInfo Annex
def :: [Command]
-def = [noCommit $ withOptions [jsonOption] $
+def = [noCommit $ dontCheck repoExists $ withOptions [jsonOption] $
command "info" paramPaths seek SectionQuery
"shows general information about the annex"]
diff --git a/Command/List.hs b/Command/List.hs
index 1fa2064..d038d6d 100644
--- a/Command/List.hs
+++ b/Command/List.hs
@@ -60,8 +60,8 @@ getList = ifM (Annex.getFlag $ optionName allrepos)
printHeader :: [(UUID, RemoteName, TrustLevel)] -> Annex ()
printHeader l = liftIO $ putStrLn $ header $ map (\(_, n, t) -> (n, t)) l
-start :: [(UUID, RemoteName, TrustLevel)] -> FilePath -> (Key, Backend) -> CommandStart
-start l file (key, _) = do
+start :: [(UUID, RemoteName, TrustLevel)] -> FilePath -> Key -> CommandStart
+start l file key = do
ls <- S.fromList <$> keyLocations key
liftIO $ putStrLn $ format (map (\(u, _, t) -> (t, S.member u ls)) l) file
stop
diff --git a/Command/Log.hs b/Command/Log.hs
index 84583a9..b0109f1 100644
--- a/Command/Log.hs
+++ b/Command/Log.hs
@@ -64,9 +64,15 @@ seek ps = do
Annex.getField (optionName o)
use o v = [Param ("--" ++ optionName o), Param v]
-start :: M.Map UUID String -> TimeZone -> [CommandParam] -> Bool ->
- FilePath -> (Key, Backend) -> CommandStart
-start m zone os gource file (key, _) = do
+start
+ :: M.Map UUID String
+ -> TimeZone
+ -> [CommandParam]
+ -> Bool
+ -> FilePath
+ -> Key
+ -> CommandStart
+start m zone os gource file key = do
showLog output =<< readLog <$> getLog key os
-- getLog produces a zombie; reap it
liftIO reapZombies
diff --git a/Command/MetaData.hs b/Command/MetaData.hs
index d932315..38f9b85 100644
--- a/Command/MetaData.hs
+++ b/Command/MetaData.hs
@@ -63,8 +63,8 @@ seek ps = do
(withFilesInGit (whenAnnexed $ start now getfield modmeta))
ps
-start :: POSIXTime -> Maybe MetaField -> [ModMeta] -> FilePath -> (Key, Backend) -> CommandStart
-start now f ms file (k, _) = start' (Just file) now f ms k
+start :: POSIXTime -> Maybe MetaField -> [ModMeta] -> FilePath -> Key -> CommandStart
+start now f ms file = start' (Just file) now f ms
startKeys :: POSIXTime -> Maybe MetaField -> [ModMeta] -> Key -> CommandStart
startKeys = start' Nothing
diff --git a/Command/Migrate.hs b/Command/Migrate.hs
index c14c07b..18e6e07 100644
--- a/Command/Migrate.hs
+++ b/Command/Migrate.hs
@@ -25,15 +25,19 @@ def = [notDirect $
seek :: CommandSeek
seek = withFilesInGit $ whenAnnexed start
-start :: FilePath -> (Key, Backend) -> CommandStart
-start file (key, oldbackend) = do
- exists <- inAnnex key
- newbackend <- choosebackend =<< chooseBackend file
- if (newbackend /= oldbackend || upgradableKey oldbackend key) && exists
- then do
- showStart "migrate" file
- next $ perform file key oldbackend newbackend
- else stop
+start :: FilePath -> Key -> CommandStart
+start file key = do
+ v <- Backend.getBackend file key
+ case v of
+ Nothing -> stop
+ Just oldbackend -> do
+ exists <- inAnnex key
+ newbackend <- choosebackend =<< chooseBackend file
+ if (newbackend /= oldbackend || upgradableKey oldbackend key) && exists
+ then do
+ showStart "migrate" file
+ next $ perform file key oldbackend newbackend
+ else stop
where
choosebackend Nothing = Prelude.head <$> orderedList
choosebackend (Just backend) = return backend
diff --git a/Command/Mirror.hs b/Command/Mirror.hs
index 4a7a8dd..4e9a850 100644
--- a/Command/Mirror.hs
+++ b/Command/Mirror.hs
@@ -31,8 +31,8 @@ seek ps = do
(withFilesInGit $ whenAnnexed $ start to from)
ps
-start :: Maybe Remote -> Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart
-start to from file (key, _backend) = startKey to from (Just file) key
+start :: Maybe Remote -> Maybe Remote -> FilePath -> Key -> CommandStart
+start to from file key = startKey to from (Just file) key
startKey :: Maybe Remote -> Maybe Remote -> Maybe FilePath -> Key -> CommandStart
startKey to from afile key = do
diff --git a/Command/Move.hs b/Command/Move.hs
index 206a875..396ea4a 100644
--- a/Command/Move.hs
+++ b/Command/Move.hs
@@ -33,8 +33,8 @@ seek ps = do
(withFilesInGit $ whenAnnexed $ start to from True)
ps
-start :: Maybe Remote -> Maybe Remote -> Bool -> FilePath -> (Key, Backend) -> CommandStart
-start to from move file (key, _) = start' to from move (Just file) key
+start :: Maybe Remote -> Maybe Remote -> Bool -> FilePath -> Key -> CommandStart
+start to from move file key = start' to from move (Just file) key
startKey :: Maybe Remote -> Maybe Remote -> Bool -> Key -> CommandStart
startKey to from move = start' to from move Nothing
diff --git a/Command/ReKey.hs b/Command/ReKey.hs
index 805300f..2919a09 100644
--- a/Command/ReKey.hs
+++ b/Command/ReKey.hs
@@ -29,7 +29,7 @@ start :: (FilePath, String) -> CommandStart
start (file, keyname) = ifAnnexed file go stop
where
newkey = fromMaybe (error "bad key") $ file2key keyname
- go (oldkey, _)
+ go oldkey
| oldkey == newkey = stop
| otherwise = do
showStart "rekey" file
diff --git a/Command/Reinit.hs b/Command/Reinit.hs
new file mode 100644
index 0000000..0fc1e83
--- /dev/null
+++ b/Command/Reinit.hs
@@ -0,0 +1,38 @@
+{- git-annex command
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Reinit where
+
+import Common.Annex
+import Command
+import Annex.Init
+import Annex.UUID
+import Types.UUID
+import qualified Remote
+
+def :: [Command]
+def = [dontCheck repoExists $
+ command "reinit" (paramUUID ++ " or " ++ paramDesc) seek SectionUtility ""]
+
+seek :: CommandSeek
+seek = withWords start
+
+start :: [String] -> CommandStart
+start ws = do
+ showStart "reinit" s
+ next $ perform s
+ where
+ s = unwords ws
+
+perform :: String -> CommandPerform
+perform s = do
+ u <- if isUUID s
+ then return $ toUUID s
+ else Remote.nameToUUID s
+ storeUUID u
+ initialize'
+ next $ return True
diff --git a/Command/Reinject.hs b/Command/Reinject.hs
index 1609c60..a516fe9 100644
--- a/Command/Reinject.hs
+++ b/Command/Reinject.hs
@@ -12,6 +12,7 @@ import Command
import Logs.Location
import Annex.Content
import qualified Command.Fsck
+import qualified Backend
def :: [Command]
def = [command "reinject" (paramPair "SRC" "DEST") seek
@@ -33,16 +34,20 @@ start (src:dest:[])
next $ whenAnnexed (perform src) dest
start _ = error "specify a src file and a dest file"
-perform :: FilePath -> FilePath -> (Key, Backend) -> CommandPerform
-perform src _dest (key, backend) =
+perform :: FilePath -> FilePath -> Key -> CommandPerform
+perform src dest key = do
{- Check the content before accepting it. -}
- ifM (Command.Fsck.checkKeySizeOr reject key src
- <&&> Command.Fsck.checkBackendOr reject backend key src)
- ( do
- unlessM move $ error "mv failed!"
- next $ cleanup key
- , error "not reinjecting"
- )
+ v <- Backend.getBackend dest key
+ case v of
+ Nothing -> stop
+ Just backend ->
+ ifM (Command.Fsck.checkKeySizeOr reject key src
+ <&&> Command.Fsck.checkBackendOr reject backend key src)
+ ( do
+ unlessM move $ error "mv failed!"
+ next $ cleanup key
+ , error "not reinjecting"
+ )
where
-- the file might be on a different filesystem,
-- so mv is used rather than simply calling
diff --git a/Command/RmUrl.hs b/Command/RmUrl.hs
index 3f304b7..e961575 100644
--- a/Command/RmUrl.hs
+++ b/Command/RmUrl.hs
@@ -20,7 +20,7 @@ seek :: CommandSeek
seek = withPairs start
start :: (FilePath, String) -> CommandStart
-start (file, url) = flip whenAnnexed file $ \_ (key, _) -> do
+start (file, url) = flip whenAnnexed file $ \_ key -> do
showStart "rmurl" file
next $ next $ cleanup url key
diff --git a/Command/Sync.hs b/Command/Sync.hs
index a400473..a5d6d46 100644
--- a/Command/Sync.hs
+++ b/Command/Sync.hs
@@ -21,7 +21,6 @@ import qualified Git.LsFiles as LsFiles
import qualified Git.Branch
import qualified Git.Ref
import qualified Git
-import qualified Types.Remote
import qualified Remote.Git
import Config
import Annex.Wanted
@@ -32,6 +31,7 @@ import Logs.Location
import Annex.Drop
import Annex.UUID
import Annex.AutoMerge
+import Annex.Ssh
import Control.Concurrent.MVar
@@ -113,11 +113,11 @@ syncRemotes rs = ifM (Annex.getState Annex.fast) ( nub <$> pickfast , wanted )
| null rs = filterM good =<< concat . Remote.byCost <$> available
| otherwise = listed
listed = catMaybes <$> mapM (Remote.byName . Just) rs
- available = filter (remoteAnnexSync . Types.Remote.gitconfig)
+ available = filter (remoteAnnexSync . Remote.gitconfig)
. filter (not . Remote.isXMPPRemote)
<$> Remote.remoteList
good r
- | Remote.gitSyncableRemote r = Remote.Git.repoAvail $ Types.Remote.repo r
+ | Remote.gitSyncableRemote r = Remote.Git.repoAvail $ Remote.repo r
| otherwise = return True
fastest = fromMaybe [] . headMaybe . Remote.byCost
@@ -201,7 +201,7 @@ pullRemote remote branch = do
stopUnless fetch $
next $ mergeRemote remote branch
where
- fetch = inRepo $ Git.Command.runBool
+ fetch = inRepoWithSshCachingTo (Remote.repo remote) $ Git.Command.runBool
[Param "fetch", Param $ Remote.name remote]
{- The remote probably has both a master and a synced/master branch.
@@ -227,14 +227,15 @@ pushRemote _remote Nothing = stop
pushRemote remote (Just branch) = go =<< needpush
where
needpush
- | remoteAnnexReadOnly (Types.Remote.gitconfig remote) = return False
+ | remoteAnnexReadOnly (Remote.gitconfig remote) = return False
| otherwise = anyM (newer remote) [syncBranch branch, Annex.Branch.name]
go False = stop
go True = do
showStart "push" (Remote.name remote)
next $ next $ do
showOutput
- ok <- inRepo $ pushBranch remote branch
+ ok <- inRepoWithSshCachingTo (Remote.repo remote) $
+ pushBranch remote branch
unless ok $ do
warning $ unwords [ "Pushing to " ++ Remote.name remote ++ " failed." ]
showLongNote "(non-fast-forward problems can be solved by setting receive.denyNonFastforwards to false in the remote's git config)"
@@ -337,8 +338,8 @@ seekSyncContent rs = do
(\v -> void (liftIO (tryPutMVar mvar ())) >> syncFile rs f v)
noop
-syncFile :: [Remote] -> FilePath -> (Key, Backend) -> Annex ()
-syncFile rs f (k, _) = do
+syncFile :: [Remote] -> FilePath -> Key -> Annex ()
+syncFile rs f k = do
locs <- loggedLocations k
let (have, lack) = partition (\r -> Remote.uuid r `elem` locs) rs
@@ -367,7 +368,7 @@ syncFile rs f (k, _) = do
next $ next $ getViaTmp k $ \dest -> getKeyFile' k (Just f) dest have
wantput r
- | Remote.readonly r || remoteAnnexReadOnly (Types.Remote.gitconfig r) = return False
+ | Remote.readonly r || remoteAnnexReadOnly (Remote.gitconfig r) = return False
| otherwise = wantSend True (Just k) (Just f) (Remote.uuid r)
handleput lack = ifM (inAnnex k)
( map put <$> filterM wantput lack
diff --git a/Command/Unannex.hs b/Command/Unannex.hs
index 3da7c2a..daa14ce 100644
--- a/Command/Unannex.hs
+++ b/Command/Unannex.hs
@@ -58,8 +58,8 @@ wrapUnannex a = ifM isDirect
then void (liftIO cleanup) >> return True
else void (liftIO cleanup) >> return False
-start :: FilePath -> (Key, Backend) -> CommandStart
-start file (key, _) = stopUnless (inAnnex key) $ do
+start :: FilePath -> Key -> CommandStart
+start file key = stopUnless (inAnnex key) $ do
showStart "unannex" file
next $ ifM isDirect
( performDirect file key
@@ -75,7 +75,16 @@ cleanupIndirect :: FilePath -> Key -> CommandCleanup
cleanupIndirect file key = do
src <- calcRepo $ gitAnnexLocation key
ifM (Annex.getState Annex.fast)
- ( hardlinkfrom src
+ ( do
+ -- Only make a hard link if the annexed file does not
+ -- already have other hard links pointing at it.
+ -- This avoids unannexing (and uninit) ending up
+ -- hard linking files together, which would be
+ -- surprising.
+ s <- liftIO $ getFileStatus src
+ if linkCount s > 1
+ then copyfrom src
+ else hardlinkfrom src
, copyfrom src
)
where
diff --git a/Command/Uninit.hs b/Command/Uninit.hs
index 5b2adf0..0f06281 100644
--- a/Command/Uninit.hs
+++ b/Command/Uninit.hs
@@ -8,6 +8,7 @@
module Command.Uninit where
import Common.Annex
+import qualified Annex
import Command
import qualified Git
import qualified Git.Command
@@ -37,12 +38,13 @@ check = do
seek :: CommandSeek
seek ps = do
withFilesNotInGit False (whenAnnexed startCheckIncomplete) ps
+ Annex.changeState $ \s -> s { Annex.fast = True }
withFilesInGit (whenAnnexed Command.Unannex.start) ps
finish
{- git annex symlinks that are not checked into git could be left by an
- interrupted add. -}
-startCheckIncomplete :: FilePath -> (Key, Backend) -> CommandStart
+startCheckIncomplete :: FilePath -> Key -> CommandStart
startCheckIncomplete file _ = error $ unlines
[ file ++ " points to annexed content, but is not checked into git."
, "Perhaps this was left behind by an interrupted git annex add?"
diff --git a/Command/Unlock.hs b/Command/Unlock.hs
index 4cfe393..0070410 100644
--- a/Command/Unlock.hs
+++ b/Command/Unlock.hs
@@ -25,8 +25,8 @@ seek = withFilesInGit $ whenAnnexed start
{- The unlock subcommand replaces the symlink with a copy of the file's
- content. -}
-start :: FilePath -> (Key, Backend) -> CommandStart
-start file (key, _) = do
+start :: FilePath -> Key -> CommandStart
+start file key = do
showStart "unlock" file
next $ perform file key
diff --git a/Command/Unused.hs b/Command/Unused.hs
index 3e844e5..5815bbf 100644
--- a/Command/Unused.hs
+++ b/Command/Unused.hs
@@ -250,7 +250,7 @@ withKeysReferenced' mdir initial a = do
x <- Backend.lookupFile f
case x of
Nothing -> go v fs
- Just (k, _) -> do
+ Just k -> do
!v' <- a k f v
go v' fs
@@ -294,7 +294,7 @@ withKeysReferencedInGitRef a ref = do
forM_ ts $ tKey lookAtWorkingTree >=> maybe noop a
liftIO $ void clean
where
- tKey True = fmap fst <$$> Backend.lookupFile . getTopFilePath . DiffTree.file
+ tKey True = Backend.lookupFile . getTopFilePath . DiffTree.file
tKey False = fileKey . takeFileName . decodeBS <$$>
catFile ref . getTopFilePath . DiffTree.file
diff --git a/Command/WebApp.hs b/Command/WebApp.hs
index 91c9afc..5256e8b 100644
--- a/Command/WebApp.hs
+++ b/Command/WebApp.hs
@@ -65,7 +65,7 @@ start' allowauto listenhost = do
stop
where
go = do
- cannotrun <- needsUpgrade . fromMaybe (error "no version") =<< getVersion
+ cannotrun <- needsUpgrade . fromMaybe (error "annex.version is not set.. seems this repository has not been initialized by git-annex") =<< getVersion
browser <- fromRepo webBrowser
f <- liftIO . absPath =<< fromRepo gitAnnexHtmlShim
listenhost' <- if isJust listenhost
@@ -98,7 +98,7 @@ start' allowauto listenhost = do
checkshim f = liftIO $ doesFileExist f
{- When run without a repo, start the first available listed repository in
- - the autostart file. If not, it's our first time being run! -}
+ - the autostart file. If none, it's our first time being run! -}
startNoRepo :: CmdParams -> IO ()
startNoRepo _ = do
-- FIXME should be able to reuse regular getopt, but
@@ -107,13 +107,18 @@ startNoRepo _ = do
let listenhost = headMaybe $ map (snd . separate (== '=')) $
filter ("--listen=" `isPrefixOf`) args
- dirs <- liftIO $ filterM doesDirectoryExist =<< readAutoStartFile
- case dirs of
- [] -> firstRun listenhost
- (d:_) -> do
+ go listenhost =<< liftIO (filterM doesDirectoryExist =<< readAutoStartFile)
+ where
+ go listenhost [] = firstRun listenhost
+ go listenhost (d:ds) = do
+ v <- tryNonAsync $ do
setCurrentDirectory d
- state <- Annex.new =<< Git.CurrentRepo.get
- void $ Annex.eval state $ do
+ Annex.new =<< Git.CurrentRepo.get
+ case v of
+ Left e -> do
+ warningIO $ "unable to start webapp in " ++ d ++ ": " ++ show e
+ go listenhost ds
+ Right state -> void $ Annex.eval state $ do
whenM (fromRepo Git.repoIsLocalBare) $
error $ d ++ " is a bare git repository, cannot run the webapp in it"
callCommandAction $
diff --git a/Command/Whereis.hs b/Command/Whereis.hs
index 387ffeb..d2c27eb 100644
--- a/Command/Whereis.hs
+++ b/Command/Whereis.hs
@@ -27,8 +27,8 @@ seek ps = do
(withFilesInGit $ whenAnnexed $ start m)
ps
-start :: M.Map UUID Remote -> FilePath -> (Key, Backend) -> CommandStart
-start remotemap file (key, _) = start' remotemap key (Just file)
+start :: M.Map UUID Remote -> FilePath -> Key -> CommandStart
+start remotemap file key = start' remotemap key (Just file)
startKeys :: M.Map UUID Remote -> Key -> CommandStart
startKeys remotemap key = start' remotemap key Nothing
diff --git a/Common.hs b/Common.hs
index 4d6165a..0f3dc71 100644
--- a/Common.hs
+++ b/Common.hs
@@ -32,5 +32,6 @@ import Utility.Data as X
import Utility.Applicative as X
import Utility.FileSystemEncoding as X
import Utility.PosixFiles as X
+import Utility.Network as X
import Utility.PartialPrelude as X
diff --git a/Creds.hs b/Creds.hs
index 0586f20..7273ed9 100644
--- a/Creds.hs
+++ b/Creds.hs
@@ -14,6 +14,7 @@ module Creds (
getEnvCredPair,
writeCacheCreds,
readCacheCreds,
+ removeCreds,
) where
import Common.Annex
@@ -138,3 +139,9 @@ decodeCredPair :: Creds -> Maybe CredPair
decodeCredPair creds = case lines creds of
l:p:[] -> Just (l, p)
_ -> Nothing
+
+removeCreds :: FilePath -> Annex ()
+removeCreds file = do
+ d <- fromRepo gitAnnexCredsDir
+ let f = d </> file
+ liftIO $ nukeFile f
diff --git a/Git/GCrypt.hs b/Git/GCrypt.hs
index 156441d..fb99cf6 100644
--- a/Git/GCrypt.hs
+++ b/Git/GCrypt.hs
@@ -16,8 +16,11 @@ import qualified Git.Config as Config
import qualified Git.Command as Command
import Utility.Gpg
+urlScheme :: String
+urlScheme = "gcrypt:"
+
urlPrefix :: String
-urlPrefix = "gcrypt::"
+urlPrefix = urlScheme ++ ":"
isEncrypted :: Repo -> Bool
isEncrypted Repo { location = Url url } = urlPrefix `isPrefixOf` show url
diff --git a/Git/Types.hs b/Git/Types.hs
index 950fe4b..838c9e0 100644
--- a/Git/Types.hs
+++ b/Git/Types.hs
@@ -11,6 +11,7 @@ import Network.URI
import qualified Data.Map as M
import System.Posix.Types
import Utility.SafeCommand
+import Utility.URI ()
{- Support repositories on local disk, and repositories accessed via an URL.
-
diff --git a/Limit.hs b/Limit.hs
index b46ff1a..9ac849b 100644
--- a/Limit.hs
+++ b/Limit.hs
@@ -234,10 +234,10 @@ limitSize vs s = case readSize dataUnits s of
Nothing -> Left "bad size"
Just sz -> Right $ go sz
where
- go sz _ (MatchingFile fi) = lookupFile fi >>= check fi sz
+ go sz _ (MatchingFile fi) = lookupFileKey fi >>= check fi sz
go sz _ (MatchingKey key) = checkkey sz key
checkkey sz key = return $ keySize key `vs` Just sz
- check _ sz (Just (key, _)) = checkkey sz key
+ check _ sz (Just key) = checkkey sz key
check fi sz Nothing = do
filesize <- liftIO $ catchMaybeIO $
fromIntegral . fileSize
@@ -272,11 +272,8 @@ addTimeLimit s = do
liftIO $ exitWith $ ExitFailure 101
else return True
-lookupFile :: FileInfo -> Annex (Maybe (Key, Backend))
-lookupFile = Backend.lookupFile . relFile
-
lookupFileKey :: FileInfo -> Annex (Maybe Key)
-lookupFileKey = (fst <$>) <$$> Backend.lookupFile . relFile
+lookupFileKey = Backend.lookupFile . relFile
checkKey :: (Key -> Annex Bool) -> MatchInfo -> Annex Bool
checkKey a (MatchingFile fi) = lookupFileKey fi >>= maybe (return False) a
diff --git a/Makefile b/Makefile
index 5c474e9..cbc3695 100644
--- a/Makefile
+++ b/Makefile
@@ -253,7 +253,7 @@ hdevtools:
distributionupdate:
git pull
cabal configure
- ghc --make Build/DistributionUpdate -XPackageImports
+ ghc --make Build/DistributionUpdate -XPackageImports -optP-include -optPdist/build/autogen/cabal_macros.h
./Build/DistributionUpdate
.PHONY: git-annex git-union-merge git-recover-repository tags build-stamp
diff --git a/Remote.hs b/Remote.hs
index 0f31b99..da33e19 100644
--- a/Remote.hs
+++ b/Remote.hs
@@ -22,6 +22,7 @@ module Remote (
remoteList,
gitSyncableRemote,
remoteMap,
+ remoteMap',
uuidDescriptions,
byName,
byNameOnly,
@@ -64,9 +65,19 @@ import Git.Types (RemoteName)
import qualified Git
{- Map from UUIDs of Remotes to a calculated value. -}
-remoteMap :: (Remote -> a) -> Annex (M.Map UUID a)
-remoteMap c = M.fromList . map (\r -> (uuid r, c r)) .
- filter (\r -> uuid r /= NoUUID) <$> remoteList
+remoteMap :: (Remote -> v) -> Annex (M.Map UUID v)
+remoteMap mkv = remoteMap' mkv mkk
+ where
+ mkk r = case uuid r of
+ NoUUID -> Nothing
+ u -> Just u
+
+remoteMap' :: Ord k => (Remote -> v) -> (Remote -> Maybe k) -> Annex (M.Map k v)
+remoteMap' mkv mkk = M.fromList . mapMaybe mk <$> remoteList
+ where
+ mk r = case mkk r of
+ Nothing -> Nothing
+ Just k -> Just (k, mkv r)
{- Map of UUIDs of remotes and their descriptions.
- The names of Remotes are added to suppliment any description that has
diff --git a/Remote/Git.hs b/Remote/Git.hs
index 209312d..83964e1 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -312,7 +312,7 @@ copyFromRemote r key file dest _p = copyFromRemote' r key file dest
copyFromRemote' :: Remote -> Key -> AssociatedFile -> FilePath -> Annex Bool
copyFromRemote' r key file dest
| not $ Git.repoIsUrl (repo r) = guardUsable (repo r) False $ do
- let params = Ssh.rsyncParams r Download
+ params <- Ssh.rsyncParams r Download
u <- getUUID
-- run copy from perspective of remote
onLocal r $ do
@@ -411,7 +411,7 @@ copyToRemote r key file p
-- the remote's Annex, but it needs access to the current
-- Annex monad's state.
checksuccessio <- Annex.withCurrentState checksuccess
- let params = Ssh.rsyncParams r Upload
+ params <- Ssh.rsyncParams r Upload
u <- getUUID
-- run copy from perspective of remote
onLocal r $ ifM (Annex.Content.inAnnex key)
diff --git a/Remote/Helper/Ssh.hs b/Remote/Helper/Ssh.hs
index 8de8895..6848f72 100644
--- a/Remote/Helper/Ssh.hs
+++ b/Remote/Helper/Ssh.hs
@@ -21,6 +21,7 @@ import Utility.Metered
import Utility.Rsync
import Types.Remote
import Logs.Transfer
+import Config
{- Generates parameters to ssh to a repository's host and run a command.
- Caller is responsible for doing any neccessary shellEscaping of the
@@ -122,7 +123,7 @@ rsyncParamsRemote direct r direction key file afile = do
fields
-- Convert the ssh command into rsync command line.
let eparam = rsyncShell (Param shellcmd:shellparams)
- let o = rsyncParams r direction
+ o <- rsyncParams r direction
return $ if direction == Download
then o ++ rsyncopts eparam dummy (File file)
else o ++ rsyncopts eparam (File file) dummy
@@ -140,9 +141,19 @@ rsyncParamsRemote direct r direction key file afile = do
dummy = Param "dummy:"
-- --inplace to resume partial files
-rsyncParams :: Remote -> Direction -> [CommandParam]
-rsyncParams r direction = Params "--progress --inplace" :
- map Param (remoteAnnexRsyncOptions gc ++ dps)
+--
+-- Only use --perms when not on a crippled file system, as rsync
+-- will fail trying to restore file perms onto a filesystem that does not
+-- support them.
+rsyncParams :: Remote -> Direction -> Annex [CommandParam]
+rsyncParams r direction = do
+ crippled <- crippledFileSystem
+ return $ map Param $ catMaybes
+ [ Just "--progress"
+ , Just "--inplace"
+ , if crippled then Nothing else Just "--perms"
+ ]
+ ++ remoteAnnexRsyncOptions gc ++ dps
where
dps
| direction == Download = remoteAnnexRsyncDownloadOptions gc
diff --git a/RemoteDaemon/Common.hs b/RemoteDaemon/Common.hs
index 29aeb00..e844e2c 100644
--- a/RemoteDaemon/Common.hs
+++ b/RemoteDaemon/Common.hs
@@ -20,7 +20,7 @@ import Annex.CatFile
import Control.Concurrent
-- Runs an Annex action. Long-running actions should be avoided,
--- since only one liftAnnex can be running at a time, amoung all
+-- since only one liftAnnex can be running at a time, across all
-- transports.
liftAnnex :: TransportHandle -> Annex a -> IO a
liftAnnex (TransportHandle _ annexstate) a = do
diff --git a/RemoteDaemon/Core.hs b/RemoteDaemon/Core.hs
index b32be98..60a4d5c 100644
--- a/RemoteDaemon/Core.hs
+++ b/RemoteDaemon/Core.hs
@@ -18,6 +18,7 @@ import qualified Git.Types as Git
import qualified Git.CurrentRepo
import Utility.SimpleProtocol
import Config
+import Annex.Ssh
import Control.Concurrent.Async
import Control.Concurrent
@@ -60,17 +61,24 @@ runController ichan ochan = do
cmd <- readChan ichan
case cmd of
RELOAD -> do
- liftAnnex h reloadConfig
- m' <- genRemoteMap h ochan
+ h' <- updateTransportHandle h
+ m' <- genRemoteMap h' ochan
let common = M.intersection m m'
let new = M.difference m' m
let old = M.difference m m'
- stoprunning old
+ broadcast STOP old
unless paused $
startrunning new
- go h paused (M.union common new)
+ go h' paused (M.union common new)
+ LOSTNET -> do
+ -- force close all cached ssh connections
+ -- (done here so that if there are multiple
+ -- ssh remotes, it's only done once)
+ liftAnnex h forceSshCleanup
+ broadcast LOSTNET m
+ go h True m
PAUSE -> do
- stoprunning m
+ broadcast STOP m
go h True m
RESUME -> do
when paused $
@@ -89,14 +97,14 @@ runController ichan ochan = do
startrunning m = forM_ (M.elems m) startrunning'
startrunning' (transport, _) = void $ async transport
- -- Ask the transport nicely to stop.
- stoprunning m = forM_ (M.elems m) stoprunning'
- stoprunning' (_, c) = writeChan c STOP
+ broadcast msg m = forM_ (M.elems m) send
+ where
+ send (_, c) = writeChan c msg
-- Generates a map with a transport for each supported remote in the git repo,
-- except those that have annex.sync = false
genRemoteMap :: TransportHandle -> Chan Emitted -> IO RemoteMap
-genRemoteMap h@(TransportHandle g _) ochan =
+genRemoteMap h@(TransportHandle g _) ochan =
M.fromList . catMaybes <$> mapM gen (Git.remotes g)
where
gen r = case Git.location r of
@@ -106,7 +114,7 @@ genRemoteMap h@(TransportHandle g _) ochan =
ichan <- newChan :: IO (Chan Consumed)
return $ Just
( r
- , (transport r (Git.repoDescribe r) h ichan ochan, ichan)
+ , (transport r (RemoteURI u) h ichan ochan, ichan)
)
_ -> return Nothing
_ -> return Nothing
@@ -116,3 +124,10 @@ genTransportHandle = do
annexstate <- newMVar =<< Annex.new =<< Git.CurrentRepo.get
g <- Annex.repo <$> readMVar annexstate
return $ TransportHandle g annexstate
+
+updateTransportHandle :: TransportHandle -> IO TransportHandle
+updateTransportHandle h@(TransportHandle _g annexstate) = do
+ g' <- liftAnnex h $ do
+ reloadConfig
+ Annex.fromRepo id
+ return (TransportHandle g' annexstate)
diff --git a/RemoteDaemon/Transport.hs b/RemoteDaemon/Transport.hs
index 1bac7f8..09118ca 100644
--- a/RemoteDaemon/Transport.hs
+++ b/RemoteDaemon/Transport.hs
@@ -9,6 +9,7 @@ module RemoteDaemon.Transport where
import RemoteDaemon.Types
import qualified RemoteDaemon.Transport.Ssh
+import qualified Git.GCrypt
import qualified Data.Map as M
@@ -18,4 +19,5 @@ type TransportScheme = String
remoteTransports :: M.Map TransportScheme Transport
remoteTransports = M.fromList
[ ("ssh:", RemoteDaemon.Transport.Ssh.transport)
+ , (Git.GCrypt.urlScheme, RemoteDaemon.Transport.Ssh.transport)
]
diff --git a/RemoteDaemon/Transport/Ssh.hs b/RemoteDaemon/Transport/Ssh.hs
index 557a3dc..ba03a25 100644
--- a/RemoteDaemon/Transport/Ssh.hs
+++ b/RemoteDaemon/Transport/Ssh.hs
@@ -8,65 +8,117 @@
module RemoteDaemon.Transport.Ssh (transport) where
import Common.Annex
+import Annex.Ssh
import RemoteDaemon.Types
import RemoteDaemon.Common
import Remote.Helper.Ssh
import qualified RemoteDaemon.Transport.Ssh.Types as SshRemote
import Utility.SimpleProtocol
+import qualified Git
import Git.Command
+import Utility.ThreadScheduler
import Control.Concurrent.Chan
import Control.Concurrent.Async
-import System.Process (std_in, std_out)
+import System.Process (std_in, std_out, std_err)
transport :: Transport
-transport r remotename transporthandle ichan ochan = do
+transport r url h@(TransportHandle g s) ichan ochan = do
+ -- enable ssh connection caching wherever inLocalRepo is called
+ g' <- liftAnnex h $ sshCachingTo r g
+ transport' r url (TransportHandle g' s) ichan ochan
+
+transport' :: Transport
+transport' r url transporthandle ichan ochan = do
+
v <- liftAnnex transporthandle $ git_annex_shell r "notifychanges" [] []
case v of
Nothing -> noop
- Just (cmd, params) -> go cmd (toCommand params)
+ Just (cmd, params) -> robustly 1 $
+ connect cmd (toCommand params)
where
- go cmd params = do
- (Just toh, Just fromh, _, pid) <- createProcess (proc cmd params)
+ connect cmd params = do
+ (Just toh, Just fromh, Just errh, pid) <-
+ createProcess (proc cmd params)
{ std_in = CreatePipe
, std_out = CreatePipe
+ , std_err = CreatePipe
}
- let shutdown = do
- hClose toh
- hClose fromh
- void $ waitForProcess pid
- send DISCONNECTED
-
- let fromshell = forever $ do
- l <- hGetLine fromh
- case parseMessage l of
- Just SshRemote.READY -> send CONNECTED
- Just (SshRemote.CHANGED shas) ->
- whenM (checkNewShas transporthandle shas) $
- fetch
- Nothing -> shutdown
+ -- Run all threads until one finishes and get the status
+ -- of the first to finish. Cancel the rest.
+ status <- catchDefaultIO (Right ConnectionClosed) $
+ handlestderr errh
+ `race` handlestdout fromh
+ `race` handlecontrol
- -- The only control message that matters is STOP.
- --
- -- Note that a CHANGED control message is not handled;
- -- we don't push to the ssh remote. The assistant
- -- and git-annex sync both handle pushes, so there's no
- -- need to do it here.
- let handlecontrol = forever $ do
- msg <- readChan ichan
- case msg of
- STOP -> ioError (userError "done")
- _ -> noop
+ send (DISCONNECTED url)
+ hClose toh
+ hClose fromh
+ void $ waitForProcess pid
- -- Run both threads until one finishes.
- void $ tryIO $ concurrently fromshell handlecontrol
- shutdown
+ return $ either (either id id) id status
- send msg = writeChan ochan (msg remotename)
+ send msg = writeChan ochan msg
fetch = do
- send SYNCING
+ send (SYNCING url)
ok <- inLocalRepo transporthandle $
- runBool [Param "fetch", Param remotename]
- send (DONESYNCING ok)
+ runBool [Param "fetch", Param $ Git.repoDescribe r]
+ send (DONESYNCING url ok)
+
+ handlestdout fromh = do
+ l <- hGetLine fromh
+ case parseMessage l of
+ Just SshRemote.READY -> do
+ send (CONNECTED url)
+ handlestdout fromh
+ Just (SshRemote.CHANGED shas) -> do
+ whenM (checkNewShas transporthandle shas) $
+ fetch
+ handlestdout fromh
+ -- avoid reconnect on protocol error
+ Nothing -> return Stopping
+
+ handlecontrol = do
+ msg <- readChan ichan
+ case msg of
+ STOP -> return Stopping
+ LOSTNET -> return Stopping
+ _ -> handlecontrol
+
+ -- Old versions of git-annex-shell that do not support
+ -- the notifychanges command will exit with a not very useful
+ -- error message. Detect that error, and avoid reconnecting.
+ -- Propigate all stderr.
+ handlestderr errh = do
+ s <- hGetSomeString errh 1024
+ hPutStr stderr s
+ hFlush stderr
+ if "git-annex-shell: git-shell failed" `isInfixOf` s
+ then do
+ send $ WARNING url $ unwords
+ [ "Remote", Git.repoDescribe r
+ , "needs its git-annex upgraded"
+ , "to 5.20140405 or newer"
+ ]
+ return Stopping
+ else handlestderr errh
+
+data Status = Stopping | ConnectionClosed
+
+{- Make connection robustly, with exponentioal backoff on failure. -}
+robustly :: Int -> IO Status -> IO ()
+robustly backoff a = handle =<< catchDefaultIO ConnectionClosed a
+ where
+ handle Stopping = return ()
+ handle ConnectionClosed = do
+ threadDelaySeconds (Seconds backoff)
+ robustly increasedbackoff a
+
+ increasedbackoff
+ | b2 > maxbackoff = maxbackoff
+ | otherwise = b2
+ where
+ b2 = backoff * 2
+ maxbackoff = 3600 -- one hour
diff --git a/RemoteDaemon/Types.hs b/RemoteDaemon/Types.hs
index 025c602..0a72695 100644
--- a/RemoteDaemon/Types.hs
+++ b/RemoteDaemon/Types.hs
@@ -10,38 +10,51 @@
module RemoteDaemon.Types where
+import Common
import qualified Annex
import qualified Git.Types as Git
import qualified Utility.SimpleProtocol as Proto
+import Network.URI
import Control.Concurrent
+-- The URI of a remote is used to uniquely identify it (names change..)
+newtype RemoteURI = RemoteURI URI
+ deriving (Show)
+
-- A Transport for a particular git remote consumes some messages
-- from a Chan, and emits others to another Chan.
-type Transport = RemoteRepo -> RemoteName -> TransportHandle -> Chan Consumed -> Chan Emitted -> IO ()
+type Transport = RemoteRepo -> RemoteURI -> TransportHandle -> Chan Consumed -> Chan Emitted -> IO ()
type RemoteRepo = Git.Repo
type LocalRepo = Git.Repo
-- All Transports share a single AnnexState MVar
+--
+-- Different TransportHandles may have different versions of the LocalRepo.
+-- (For example, the ssh transport modifies it to enable ssh connection
+-- caching.)
data TransportHandle = TransportHandle LocalRepo (MVar Annex.AnnexState)
-- Messages that the daemon emits.
data Emitted
- = CONNECTED RemoteName
- | DISCONNECTED RemoteName
- | SYNCING RemoteName
- | DONESYNCING Bool RemoteName
+ = CONNECTED RemoteURI
+ | DISCONNECTED RemoteURI
+ | SYNCING RemoteURI
+ | DONESYNCING RemoteURI Bool
+ | WARNING RemoteURI String
+ deriving (Show)
-- Messages that the deamon consumes.
data Consumed
= PAUSE
+ | LOSTNET
| RESUME
| CHANGED RefList
| RELOAD
| STOP
+ deriving (Show)
-type RemoteName = String
type RefList = [Git.Ref]
instance Proto.Sendable Emitted where
@@ -51,11 +64,14 @@ instance Proto.Sendable Emitted where
["DISCONNECTED", Proto.serialize remote]
formatMessage (SYNCING remote) =
["SYNCING", Proto.serialize remote]
- formatMessage (DONESYNCING status remote) =
- ["DONESYNCING", Proto.serialize status, Proto.serialize remote]
+ formatMessage (DONESYNCING remote status) =
+ ["DONESYNCING", Proto.serialize remote, Proto.serialize status]
+ formatMessage (WARNING remote message) =
+ ["WARNING", Proto.serialize remote, Proto.serialize message]
instance Proto.Sendable Consumed where
formatMessage PAUSE = ["PAUSE"]
+ formatMessage LOSTNET = ["LOSTNET"]
formatMessage RESUME = ["RESUME"]
formatMessage (CHANGED refs) =["CHANGED", Proto.serialize refs]
formatMessage RELOAD = ["RELOAD"]
@@ -66,16 +82,22 @@ instance Proto.Receivable Emitted where
parseCommand "DISCONNECTED" = Proto.parse1 DISCONNECTED
parseCommand "SYNCING" = Proto.parse1 SYNCING
parseCommand "DONESYNCING" = Proto.parse2 DONESYNCING
+ parseCommand "WARNING" = Proto.parse2 WARNING
parseCommand _ = Proto.parseFail
instance Proto.Receivable Consumed where
parseCommand "PAUSE" = Proto.parse0 PAUSE
+ parseCommand "LOSTNET" = Proto.parse0 LOSTNET
parseCommand "RESUME" = Proto.parse0 RESUME
parseCommand "CHANGED" = Proto.parse1 CHANGED
parseCommand "RELOAD" = Proto.parse0 RELOAD
parseCommand "STOP" = Proto.parse0 STOP
parseCommand _ = Proto.parseFail
+instance Proto.Serializable RemoteURI where
+ serialize (RemoteURI u) = show u
+ deserialize = RemoteURI <$$> parseURI
+
instance Proto.Serializable [Char] where
serialize = id
deserialize = Just
diff --git a/Test.hs b/Test.hs
index 8fbaf1d..55546d0 100644
--- a/Test.hs
+++ b/Test.hs
@@ -164,6 +164,7 @@ properties = localOption (QuickCheckTests 1000) $ testGroup "QuickCheck"
, testProperty "prop_parse_show_TrustLog" Logs.Trust.prop_parse_show_TrustLog
, testProperty "prop_hashes_stable" Utility.Hash.prop_hashes_stable
, testProperty "prop_schedule_roundtrips" Utility.Scheduled.prop_schedule_roundtrips
+ , testProperty "prop_past_sane" Utility.Scheduled.prop_past_sane
, testProperty "prop_duration_roundtrips" Utility.HumanTime.prop_duration_roundtrips
, testProperty "prop_metadata_sane" Types.MetaData.prop_metadata_sane
, testProperty "prop_metadata_serialize" Types.MetaData.prop_metadata_serialize
@@ -711,7 +712,7 @@ test_unused env = intmpclonerepoInDirect env $ do
(sort expectedkeys) (sort unusedkeys)
findkey f = do
r <- Backend.lookupFile f
- return $ fst $ fromJust r
+ return $ fromJust r
test_describe :: TestEnv -> Assertion
test_describe env = intmpclonerepo env $ do
@@ -1232,7 +1233,7 @@ test_crypto env = do
(c,k) <- annexeval $ do
uuid <- Remote.nameToUUID "foo"
rs <- Logs.Remote.readRemoteLog
- Just (k,_) <- Backend.lookupFile annexedfile
+ Just k <- Backend.lookupFile annexedfile
return (fromJust $ M.lookup uuid rs, k)
let key = if scheme `elem` ["hybrid","pubkey"]
then Just $ Utility.Gpg.KeyIds [Utility.Gpg.testKeyId]
@@ -1499,7 +1500,7 @@ checklocationlog f expected = do
thisuuid <- annexeval Annex.UUID.getUUID
r <- annexeval $ Backend.lookupFile f
case r of
- Just (k, _) -> do
+ Just k -> do
uuids <- annexeval $ Remote.keyLocations k
assertEqual ("bad content in location log for " ++ f ++ " key " ++ Types.Key.key2file k ++ " uuid " ++ show thisuuid)
expected (thisuuid `elem` uuids)
@@ -1507,9 +1508,9 @@ checklocationlog f expected = do
checkbackend :: FilePath -> Types.Backend -> Assertion
checkbackend file expected = do
- r <- annexeval $ Backend.lookupFile file
- let b = snd $ fromJust r
- assertEqual ("backend for " ++ file) expected b
+ b <- annexeval $ maybe (return Nothing) (Backend.getBackend file)
+ =<< Backend.lookupFile file
+ assertEqual ("backend for " ++ file) (Just expected) b
inlocationlog :: FilePath -> Assertion
inlocationlog f = checklocationlog f True
diff --git a/Types/UUID.hs b/Types/UUID.hs
index 8a304df..df38840 100644
--- a/Types/UUID.hs
+++ b/Types/UUID.hs
@@ -8,6 +8,8 @@
module Types.UUID where
import qualified Data.Map as M
+import qualified Data.UUID as U
+import Data.Maybe
-- A UUID is either an arbitrary opaque string, or UUID info may be missing.
data UUID = NoUUID | UUID String
@@ -21,4 +23,7 @@ toUUID :: String -> UUID
toUUID [] = NoUUID
toUUID s = UUID s
+isUUID :: String -> Bool
+isUUID = isJust . U.fromString
+
type UUIDMap = M.Map UUID String
diff --git a/Utility/Process.hs b/Utility/Process.hs
index 1945e4b..3f93dc2 100644
--- a/Utility/Process.hs
+++ b/Utility/Process.hs
@@ -31,6 +31,7 @@ module Utility.Process (
stdinHandle,
stdoutHandle,
stderrHandle,
+ processHandle,
devNull,
) where
@@ -313,6 +314,9 @@ bothHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> (Han
bothHandles (Just hin, Just hout, _, _) = (hin, hout)
bothHandles _ = error "expected bothHandles"
+processHandle :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> ProcessHandle
+processHandle (_, _, _, pid) = pid
+
{- Debugging trace for a CreateProcess. -}
debugProcess :: CreateProcess -> IO ()
debugProcess p = do
diff --git a/Utility/Scheduled.hs b/Utility/Scheduled.hs
index 1b25cb4..d3ae062 100644
--- a/Utility/Scheduled.hs
+++ b/Utility/Scheduled.hs
@@ -1,6 +1,6 @@
{- scheduled activities
-
- - Copyright 2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2013-2014 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -14,6 +14,7 @@ module Utility.Scheduled (
MonthDay,
YearDay,
nextTime,
+ calcNextTime,
startTime,
fromSchedule,
fromScheduledTime,
@@ -22,7 +23,8 @@ module Utility.Scheduled (
toRecurrance,
toSchedule,
parseSchedule,
- prop_schedule_roundtrips
+ prop_schedule_roundtrips,
+ prop_past_sane,
) where
import Utility.Data
@@ -66,8 +68,8 @@ data ScheduledTime
type Hour = Int
type Minute = Int
-{- Next time a Schedule should take effect. The NextTimeWindow is used
- - when a Schedule is allowed to start at some point within the window. -}
+-- | Next time a Schedule should take effect. The NextTimeWindow is used
+-- when a Schedule is allowed to start at some point within the window.
data NextTime
= NextTimeExactly LocalTime
| NextTimeWindow LocalTime LocalTime
@@ -83,8 +85,8 @@ nextTime schedule lasttime = do
tz <- getTimeZone now
return $ calcNextTime schedule lasttime $ utcToLocalTime tz now
-{- Calculate the next time that fits a Schedule, based on the
- - last time it occurred, and the current time. -}
+-- | Calculate the next time that fits a Schedule, based on the
+-- last time it occurred, and the current time.
calcNextTime :: Schedule -> Maybe LocalTime -> LocalTime -> Maybe NextTime
calcNextTime schedule@(Schedule recurrance scheduledtime) lasttime currenttime
| scheduledtime == AnyTime = do
@@ -97,10 +99,10 @@ calcNextTime schedule@(Schedule recurrance scheduledtime) lasttime currenttime
findfromtoday anytime = findfrom recurrance afterday today
where
today = localDay currenttime
- afterday = sameaslastday || toolatetoday
+ afterday = sameaslastrun || toolatetoday
toolatetoday = not anytime && localTimeOfDay currenttime >= nexttime
- sameaslastday = lastday == Just today
- lastday = localDay <$> lasttime
+ sameaslastrun = lastrun == Just today
+ lastrun = localDay <$> lasttime
nexttime = case scheduledtime of
AnyTime -> TimeOfDay 0 0 0
SpecificTime h m -> TimeOfDay h m 0
@@ -120,21 +122,19 @@ calcNextTime schedule@(Schedule recurrance scheduledtime) lasttime currenttime
| otherwise -> Just $ exactly candidate
Weekly Nothing
| afterday -> skip 1
- | otherwise -> case (wday <$> lastday, wday candidate) of
+ | otherwise -> case (wday <$> lastrun, wday candidate) of
(Nothing, _) -> Just $ window candidate (addDays 6 candidate)
(Just old, curr)
| old == curr -> Just $ window candidate (addDays 6 candidate)
| otherwise -> skip 1
Monthly Nothing
| afterday -> skip 1
- | maybe True (\old -> mday candidate > mday old && mday candidate >= (mday old `mod` minmday)) lastday ->
- -- Window only covers current month,
- -- in case there is a Divisible requirement.
+ | maybe True (candidate `oneMonthPast`) lastrun ->
Just $ window candidate (endOfMonth candidate)
| otherwise -> skip 1
Yearly Nothing
| afterday -> skip 1
- | maybe True (\old -> ynum candidate > ynum old && yday candidate >= (yday old `mod` minyday)) lastday ->
+ | maybe True (candidate `oneYearPast`) lastrun ->
Just $ window candidate (endOfYear candidate)
| otherwise -> skip 1
Weekly (Just w)
@@ -176,6 +176,18 @@ calcNextTime schedule@(Schedule recurrance scheduledtime) lasttime currenttime
getday = localDay . startTime
divisible n v = v `rem` n == 0
+-- Check if the new Day occurs one month or more past the old Day.
+oneMonthPast :: Day -> Day -> Bool
+new `oneMonthPast` old = fromGregorian y (m+1) d <= new
+ where
+ (y,m,d) = toGregorian old
+
+-- Check if the new Day occurs one year or more past the old Day.
+oneYearPast :: Day -> Day -> Bool
+new `oneYearPast` old = fromGregorian (y+1) m d <= new
+ where
+ (y,m,d) = toGregorian old
+
endOfMonth :: Day -> Day
endOfMonth day =
let (y,m,_d) = toGregorian day
@@ -200,17 +212,13 @@ yday = snd . toOrdinalDate
ynum :: Day -> Int
ynum = fromIntegral . fst . toOrdinalDate
-{- Calendar max and mins. -}
+-- Calendar max values.
maxyday :: Int
maxyday = 366 -- with leap days
-minyday :: Int
-minyday = 365
maxwnum :: Int
maxwnum = 53 -- some years have more than 52
maxmday :: Int
maxmday = 31
-minmday :: Int
-minmday = 28
maxmnum :: Int
maxmnum = 12
maxwday :: Int
@@ -362,3 +370,27 @@ instance Arbitrary Recurrance where
prop_schedule_roundtrips :: Schedule -> Bool
prop_schedule_roundtrips s = toSchedule (fromSchedule s) == Just s
+
+prop_past_sane :: Bool
+prop_past_sane = and
+ [ all (checksout oneMonthPast) (mplus1 ++ yplus1)
+ , all (not . (checksout oneMonthPast)) (map swap (mplus1 ++ yplus1))
+ , all (checksout oneYearPast) yplus1
+ , all (not . (checksout oneYearPast)) (map swap yplus1)
+ ]
+ where
+ mplus1 = -- new date old date, 1+ months before it
+ [ (fromGregorian 2014 01 15, fromGregorian 2013 12 15)
+ , (fromGregorian 2014 01 15, fromGregorian 2013 02 15)
+ , (fromGregorian 2014 02 15, fromGregorian 2013 01 15)
+ , (fromGregorian 2014 03 01, fromGregorian 2013 01 15)
+ , (fromGregorian 2014 03 01, fromGregorian 2013 12 15)
+ , (fromGregorian 2015 01 01, fromGregorian 2010 01 01)
+ ]
+ yplus1 = -- new date old date, 1+ years before it
+ [ (fromGregorian 2014 01 15, fromGregorian 2012 01 16)
+ , (fromGregorian 2014 01 15, fromGregorian 2013 01 14)
+ , (fromGregorian 2022 12 31, fromGregorian 2000 01 01)
+ ]
+ checksout cmp (new, old) = new `cmp` old
+ swap (a,b) = (b,a)
diff --git a/Utility/URI.hs b/Utility/URI.hs
new file mode 100644
index 0000000..39c2f22
--- /dev/null
+++ b/Utility/URI.hs
@@ -0,0 +1,18 @@
+{- Network.URI
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Utility.URI where
+
+-- Old versions of network lacked an Ord for URI
+#if ! MIN_VERSION_network(2,4,0)
+import Network.URI
+
+instance Ord URI where
+ a `compare` b = show a `compare` show b
+#endif
diff --git a/debian/changelog b/debian/changelog
index a883ddd..8d48162 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,45 @@
+git-annex (5.20140421) unstable; urgency=medium
+
+ * assistant: Now detects immediately when other repositories push
+ changes to a ssh remote, and pulls.
+ ** XMPP is no longer needed in this configuration! **
+ This requires the remote server have git-annex-shell with
+ notifychanges support (>= 5.20140405)
+ * webapp: Show a network signal icon next to ssh and xmpp remotes that
+ it's currently connected with.
+ * webapp: Rework xmpp nudge to prompt for either xmpp or a ssh remote
+ to be set up.
+ * sync, assistant, remotedaemon: Use ssh connection caching for git pushes
+ and pulls.
+ * remotedaemon: When network connection is lost, close all cached ssh
+ connections.
+ * Improve handling of monthly/yearly scheduling.
+ * Avoid depending on shakespeare except for when building the webapp.
+ * uninit: Avoid making unncessary copies of files.
+ * info: Allow use in a repository where annex.uuid is not set.
+ * reinit: New command that can initialize a new repository using
+ the configuration of a previously known repository.
+ Useful if a repository got deleted and you want
+ to clone it back the way it was.
+ * drop --from: When local repository is untrusted, its copy of a file does
+ not count.
+ * Bring back rsync -p, but only when git-annex is running on a non-crippled
+ file system. This is a better approach to fix #700282 while not
+ unncessarily losing file permissions on non-crippled systems.
+ * webapp: Start even if the current directory is listed in
+ ~/.config/git-annex/autostart but no longer has a git repository in it.
+ * findref: New command, like find but shows files in a specified git ref.
+ * webapp: Fix UI for removing XMPP connection.
+ * When init detects that git is not configured to commit, and sets
+ user.email to work around the problem, also make it set user.name.
+ * webapp: Support using git-annex on a remote server, which was installed
+ from the standalone tarball or OSX app, and so does not have
+ git-annex in PATH (and may also not have git or rsync in PATH).
+ * standalone tarball, OSX app: Install a ~/.ssh/git-annex-wrapper, which
+ can be used to run git-annex, git, rsync, etc.
+
+ -- Joey Hess <joeyh@debian.org> Sun, 20 Apr 2014 19:43:14 -0400
+
git-annex (5.20140412) unstable; urgency=high
* Last release didn't quite fix the high cpu issue in all cases, this should.
diff --git a/debian/control b/debian/control
index 1a2aaed..3c75cdd 100644
--- a/debian/control
+++ b/debian/control
@@ -35,6 +35,7 @@ Build-Depends:
libghc-yesod-static-dev [i386 amd64 kfreebsd-i386 kfreebsd-amd64 powerpc sparc],
libghc-yesod-default-dev [i386 amd64 kfreebsd-amd64 powerpc sparc],
libghc-hamlet-dev [i386 amd64 kfreebsd-i386 kfreebsd-amd64 powerpc sparc],
+ libghc-shakespeare-dev [i386 amd64 kfreebsd-i386 kfreebsd-amd64 powerpc sparc],
libghc-clientsession-dev [i386 amd64 kfreebsd-i386 kfreebsd-amd64 powerpc sparc],
libghc-warp-dev [i386 amd64 kfreebsd-i386 kfreebsd-amd64 powerpc sparc],
libghc-warp-tls-dev [i386 amd64 kfreebsd-i386 kfreebsd-amd64 powerpc sparc],
diff --git a/doc/bugs/Android___91__Terminal_session_finished__93__.mdwn b/doc/bugs/Android___91__Terminal_session_finished__93__.mdwn
new file mode 100644
index 0000000..0eb3a2d
--- /dev/null
+++ b/doc/bugs/Android___91__Terminal_session_finished__93__.mdwn
@@ -0,0 +1,33 @@
+### Please describe the problem.
+
+Launching the Git Annex app on Android, the shell just reads:
+[[!format sh """
+[Terminal session finished]
+"""]]
+
+Attempting to launch /data/data/ga.androidterm/runshell via the adb shell does also not work:
+[[!format sh """
+/system/bin/sh: /data/data/ga.androidterm/runshell: not found
+"""]]
+
+Listing the contents of that directory from the git annex terminal appears to confirm this:
+[[!format sh """
+u0_a172@android:/data/data/ga.androidterm $ ls
+cache
+lib
+shared_prefs
+"""]]
+
+Following the instructions for the similar issue here [[http://git-annex.branchable.com/Android/oldcomments/#comment-4c5a944c1288ddd46108969a4c664584]]:
+[[!format sh """
+u0_a172@android:/ $ ls -ld /data/data/ga.androidterm
+drwxr-x--x u0_a172 u0_a172 2014-04-20 11:12 ga.androidterm
+"""]]
+
+### What version of git-annex are you using? On what operating system?
+
+version 5.20140413 of the Git Annex app (tested using the daily build and regular build).
+
+Samsung Galaxy Tab 3 (GT-P5210) running Android 4.2.2 (without root access).
+
+> [[done|dup]] --[[Joey]]
diff --git a/doc/bugs/Drop_--from_always_trusts_local_repository.mdwn b/doc/bugs/Drop_--from_always_trusts_local_repository.mdwn
new file mode 100644
index 0000000..53bdda3
--- /dev/null
+++ b/doc/bugs/Drop_--from_always_trusts_local_repository.mdwn
@@ -0,0 +1,46 @@
+### Please describe the problem.
+
+The command `git annex drop --from` always trusts the local repository, even if
+it is marked as untrusted.
+
+
+### What steps will reproduce the problem?
+[[!format sh """
+mkdir t u; cd t; git init; git commit --allow-empty -m "Initial commit"; git annex init "Trusted"; date > file; git annex add file; git commit -m "Add file"; cd ../u; git init; git remote add t ../t; git fetch t; git merge t/master; git annex init "Untrusted"; git annex untrust .; git annex get file; cd ../t; git remote add u ../u; git fetch u; cd ..
+"""]]
+
+Create two repositories, *t* (trusted) and *u* (untrusted). A file is in both
+repositories. When performing `git annex drop file` in repository *t*, `git
+annex` will abort because there are not enough copies. But when performing `git
+annex drop --from t file` in *u*, git annex will delete the copy.
+
+
+### What version of git-annex are you using? On what operating system?
+
+Bug was introduced with 6c31e3a8 and still exists in current master (d955cfe7).
+
+
+### Please provide any additional information below.
+
+The following change seems to solve the problem. (First time working with
+Haskell, please excuse the crude code.)
+
+[[!format diff """
+diff --git a/Command/Drop.hs b/Command/Drop.hs
+index 269c4c2..09ea99a 100644
+--- a/Command/Drop.hs
++++ b/Command/Drop.hs
+@@ -82,8 +82,9 @@ performRemote key afile numcopies remote = lockContent key $ do
+ (remotes, trusteduuids) <- Remote.keyPossibilitiesTrusted key
+ present <- inAnnex key
+ u <- getUUID
++ level <- lookupTrust u
+ let have = filter (/= uuid) $
+- if present then u:trusteduuids else trusteduuids
++ if present && level <= SemiTrusted then u:trusteduuids else trusteduuids
+ untrusteduuids <- trustGet UnTrusted
+ let tocheck = filter (/= remote) $
+ Remote.remotesWithoutUUID remotes (have++untrusteduuids)
+"""]]
+
+> [[fixed|done]] --[[Joey]]
diff --git a/doc/bugs/git-annex_branch_shows_commit_with_looong_commitlog.mdwn b/doc/bugs/git-annex_branch_shows_commit_with_looong_commitlog.mdwn
new file mode 100644
index 0000000..1af2b77
--- /dev/null
+++ b/doc/bugs/git-annex_branch_shows_commit_with_looong_commitlog.mdwn
@@ -0,0 +1,72 @@
+### Please describe the problem.
+
+I have found a really weird commit in my git-annex branch:
+
+ * a59dd1c update (il y a 8 heures) <Antoine Beaupré>
+ * 57f887a update (recovery from race) (recovery from race) (recovery from race) [...]
+
+it repeats that for a looong time. about 12 000 times, to be more precise:
+
+[[!format sh """
+anarcat@marcos:video$ git show 57f887a | wc
+ 5 12686 88850
+"""]]
+
+### What steps will reproduce the problem?
+
+Now i have absolutely no idea how I managed that. I got through some pretty dark moments last night trying various levels of git-annex voodoo (including a duplicate repo which was rsync'd to a backup drive so the unique identifier applied to two distinct paths), so I have no idea exactly what happened here.
+
+### What version of git-annex are you using? On what operating system?
+
+debian jessie amd64 5.20140412
+
+### Please provide any additional information below.
+
+[[!format sh """
+anarcat@marcos:video$ git show 57f887a | tail -c 100
+very from race) (recovery from race) (recovery from race) (recovery from race) (recovery from race)
+anarcat@marcos:video$ git show 57f887a | head -c 512
+commit 57f887a9d766829d00832ad1ee23b2785212d055
+Author: Antoine Beaupré <anarcat@koumbit.org>
+Date: Sat Apr 19 01:48:18 2014 -0400
+
+ update (recovery from race) (recovery from race) (recovery from race) (recovery from race) (recovery from race) (recovery from race) (recovery from race) (recovery from race) (recovery from race) (recovery from race) (recovery from race) (recovery from race) (recovery from race) (recovery from race) (recovery from race) (recovery from race) (recovery from race) (recovery
+"""]]
+
+that's 80KB for only one commit here - maybe that should be cleaned up? --[[anarcat]]
+
+Ah! more information: it seems that 01:48 was the moment i shutdown the assistant in yet another panic...
+
+[[!format sh """
+anarcat@marcos:video$ ls -al .git/annex/daemon.log*
+-rw-r--r-- 1 anarcat anarcat 17075 avril 19 09:28 .git/annex/daemon.log
+-rw-r--r-- 1 anarcat anarcat 128367 avril 19 01:48 .git/annex/daemon.log.1
+"""]]
+
+an extract from that second logfile:
+
+[[!format sh """
+19/Apr/2014:01:31:38 -0400 [Error#yesod-core] unknown response from git cat-file ("9a73bf01-ed01-450d-a0ab-f20fff47ed32 encryption=none name=stephc rsyncurl=192.168.0.104:video/ type=rsync timestamp=1397865844.925354s","refs/heads/git-annex:remote.log") @(yesod-core-1.2.3:Yesod.Core.Class.Yesod ./Yesod/Core/Class/Yesod.hs:471:5)
+19/Apr/2014:01:31:50 -0400 [Error#yesod-core] unknown response from git cat-file ("fe428a7a-25a2-4c2e-b01f-315c490cbe45 encryption=none name=myrsync rsyncurl=/home/anarcat/video/ type=rsync timestamp=1397868063.038898s","refs/heads/git-annex:remote.log") @(yesod-core-1.2.3:Yesod.Core.Class.Yesod ./Yesod/Core/Class/Yesod.hs:471:5)
+19/Apr/2014:01:31:57 -0400 [Error#yesod-core] unknown response from git cat-file ("","refs/heads/git-annex:remote.log") @(yesod-core-1.2.3:Yesod.Core.Class.Yesod ./Yesod/Core/Class/Yesod.hs:471:5)
+[2014-04-19 01:32:03 EDT] TransferScanner: Syncing with test, mnt
+Depuis /mnt/video
+ * [nouvelle branche] synced/git-annex -> test/synced/git-annex
+ * [nouvelle branche] synced/master -> test/synced/master
+fatal: 'mnt' does not appear to be a git repository
+fatal: Could not read from remote repository.
+
+Please make sure you have the correct access rights
+and the repository exists.
+Already up-to-date.
+[2014-04-19 01:32:21 EDT] main: warning git-annex has been shut down
+
+(Recording state in git...)
+(Recording state in git...)
+(Recording state in git...)
+(Recording state in git...)
+"""]]
+
+the last line repeats about 4000 times.
+
+i would love to paste the daemon.log.1 file, but it seems like it containts encryption credentials... which i have no idea how to get rid of or change.
diff --git a/doc/bugs/protocol_mismatch_after_interrupt.mdwn b/doc/bugs/protocol_mismatch_after_interrupt.mdwn
new file mode 100644
index 0000000..837690e
--- /dev/null
+++ b/doc/bugs/protocol_mismatch_after_interrupt.mdwn
@@ -0,0 +1,31 @@
+### Please describe the problem.
+
+git annex now fails to transfer a fail with: `protocol version mismatch -- is your shell clean?`
+
+### What steps will reproduce the problem?
+
+start a transfer, then switch between your wireless and wired connexions (I am using network-manager), then interrupt the transfer with control-c.
+
+### What version of git-annex are you using? On what operating system?
+
+on my side: 5.20140306~bpo70 on debian wheezy amd64
+
+on the other side: 4.20130815 on ubuntu saucy i386
+
+### Please provide any additional information below.
+
+[[!format sh """
+anarcat@angela:video$ git annex copy --to t films/foo.mkv
+copy films/foo.mkv (checking t...) (to t...)
+protocol version mismatch -- is your shell clean?
+(see the rsync man page for an explanation)
+rsync error: protocol incompatibility (code 2) at compat.c(174) [sender=3.0.9]
+
+ rsync failed -- run git annex again to resume file transfer
+failed
+git-annex: copy: 1 failed
+"""]]
+
+workaround: `cd .git/annex/; mv transfer transfer.old` on the other side.
+
+-- [[anarcat]]
diff --git a/doc/design/assistant/polls/Android_default_directory.mdwn b/doc/design/assistant/polls/Android_default_directory.mdwn
index 869aedf..6d5a07e 100644
--- a/doc/design/assistant/polls/Android_default_directory.mdwn
+++ b/doc/design/assistant/polls/Android_default_directory.mdwn
@@ -4,4 +4,4 @@ Same as the desktop webapp, users will be able to enter a directory they
want the first time they run it, but to save typing on android, anything
that gets enough votes will be included in a list of choices as well.
-[[!poll open=yes expandable=yes 66 "/sdcard/annex" 6 "Whole /sdcard" 6 "DCIM directory (photos and videos only)" 1 "Same as for regular git-annex. ~/annex/"]]
+[[!poll open=yes expandable=yes 66 "/sdcard/annex" 6 "Whole /sdcard" 7 "DCIM directory (photos and videos only)" 1 "Same as for regular git-annex. ~/annex/"]]
diff --git a/doc/design/assistant/polls/prioritizing_special_remotes.mdwn b/doc/design/assistant/polls/prioritizing_special_remotes.mdwn
index c6dbb37..a87a674 100644
--- a/doc/design/assistant/polls/prioritizing_special_remotes.mdwn
+++ b/doc/design/assistant/polls/prioritizing_special_remotes.mdwn
@@ -6,7 +6,7 @@ locally paired systems, and remote servers with rsync.
Help me prioritize my work: What special remote would you most like
to use with the git-annex assistant?
-[[!poll open=yes 16 "Amazon S3 (done)" 12 "Amazon Glacier (done)" 9 "Box.com (done)" 71 "My phone (or MP3 player)" 25 "Tahoe-LAFS" 10 "OpenStack SWIFT" 33 "Google Drive"]]
+[[!poll open=yes 16 "Amazon S3 (done)" 12 "Amazon Glacier (done)" 9 "Box.com (done)" 72 "My phone (or MP3 player)" 25 "Tahoe-LAFS" 10 "OpenStack SWIFT" 33 "Google Drive"]]
This poll is ordered with the options I consider easiest to build
listed first. Mostly because git-annex already supports them and they
diff --git a/doc/design/assistant/telehash.mdwn b/doc/design/assistant/telehash.mdwn
index 3b427b4..2ecf9ec 100644
--- a/doc/design/assistant/telehash.mdwn
+++ b/doc/design/assistant/telehash.mdwn
@@ -83,7 +83,7 @@ Advantages:
exchange protocols implemented in such a daemon to allow SSH-less
transfers.
* Security holes in telehash would not need to compromise the entire
- git-annex. gathd could be sandboxed in one way or another.
+ git-annex. daemon could be sandboxed in one way or another.
Disadvantages:
diff --git a/doc/design/git-remote-daemon.mdwn b/doc/design/git-remote-daemon.mdwn
index 6b8e064..270ceaa 100644
--- a/doc/design/git-remote-daemon.mdwn
+++ b/doc/design/git-remote-daemon.mdwn
@@ -69,40 +69,44 @@ the webapp.
## emitted messages
-* `CONNECTED $remote`
+* `CONNECTED uri`
Sent when a connection has been made with a remote.
-* `DISCONNECTED $remote`
+* `DISCONNECTED uri`
Sent when connection with a remote has been lost.
-* `SYNCING $remote`
+* `SYNCING uri`
Indicates that a pull or a push with a remote is in progress.
Always followed by DONESYNCING.
-* `DONESYNCING 1|0 $remote`
+* `DONESYNCING uri 1|0`
Indicates that syncing with a remote is done, and either succeeded
(1) or failed (0).
+* `WARNING uri string`
+
+ A message to display to the user about a remote.
+
## consumed messages
* `PAUSE`
- This indicates that the network connection has gone down,
- or the user has requested a pause.
+ The user has requested a pause.
git-remote-daemon should close connections and idle.
- Affects all remotes.
+* `LOSTNET`
-* `RESUME`
+ The network connection has been lost.
+ git-remote-daemon should close connections and idle.
- This indicates that the network connection has come back up, or the user
- has asked it to run again. Start back up network connections.
+* `RESUME`
- Affects all remotes.
+ Undoes PAUSE or LOSTNET.
+ Start back up network connections.
* `CHANGED ref ...`
@@ -133,9 +137,9 @@ encryption. Encryption is not part of this design.
(XMPP does not do end-to-end encryption, but might be supported
transitionally.)
-Ditto for authentication that we're talking to who we indend to talk to.
-Any public key data etc used for authenticion is part of the remote's
-configuration (or hidden away in a secure chmodded file, if neccesary).
+Ditto for authentication that we're talking to who we intend to talk to.
+Any public key data etc used for authentication is part of the remote's
+configuration (or hidden away in a secure chmodded file, if necessary).
This design does not concern itself with authenticating the remote node,
it just takes the auth token and uses it.
@@ -158,15 +162,7 @@ over stdio to inform when refs on the remote have changed.
No pushing is done for CHANGED, since git handles ssh natively.
-TODO:
-
-* Remote system might not be available. Find a smart way to detect it,
- ideally w/o generating network traffic. One way might be to check
- if the ssh connection caching control socket exists, for example.
-* Remote system might be available, and connection get lost. Should
- reconnect, but needs to avoid bad behavior (ie, constant reconnect
- attempts.)
-* Detect if old system had a too old git-annex-shell and avoid bad behavior
+TODO: test!
## telehash
diff --git a/doc/devblog/day_133__db_and_bugfixes.mdwn b/doc/devblog/day_133__db_and_bugfixes.mdwn
index b844708..5ba1df2 100644
--- a/doc/devblog/day_133__db_and_bugfixes.mdwn
+++ b/doc/devblog/day_133__db_and_bugfixes.mdwn
@@ -4,7 +4,7 @@ several stages, starting with using it for generating views, and ending(?)
with using it for direct mode file mappings.
Not sure I'm ready to dive into that yet, so instead spent the rest of the
-day working on small bugfixes and improvemnts. Only two significant ones..
+day working on small bugfixes and improvements. Only two significant ones..
Made the webapp use a constant time string comparison (from `securemem`)
to check if its auth token is valid. This could help avoid a potential
diff --git a/doc/devblog/day_149__signal.mdwn b/doc/devblog/day_149__signal.mdwn
index 7327c67..2bcb01a 100644
--- a/doc/devblog/day_149__signal.mdwn
+++ b/doc/devblog/day_149__signal.mdwn
@@ -1,8 +1,8 @@
[[!meta title="day 150 signal"]]
The git-remote-daemon now robustly handles loss of signal, with
-reconnection backoffs. And it detects if the remote ssh server has a too
-old version of git-annex-shell and the webapp will display a warning
+reconnection backoffs. And it detects if the remote ssh server has too
+old a version of git-annex-shell and the webapp will display a warning
message.
[[!img /assistant/connection.png]]
diff --git a/doc/devblog/day_151__birthday_bug.mdwn b/doc/devblog/day_151__birthday_bug.mdwn
new file mode 100644
index 0000000..251bfb9
--- /dev/null
+++ b/doc/devblog/day_151__birthday_bug.mdwn
@@ -0,0 +1,18 @@
+Pushed out a new release today, fixing two important bugs, followed by a
+second release which fixed the bugs harder.
+
+Automatic upgrading was broken on OSX. The webapp will tell you upgrading
+failed, and you'll need to manually download the .dmg and install it.
+
+With help from Maximiliano Curia, finally tracked down a bug I have been
+chasing for a while where the assistant would start using a lot of CPU
+while not seeming to be busy doing anything. Turned out to be triggered by
+a scheduled fsck that was configured to run once a month with no particular
+day specified.
+
+That bug turned out to affect users who first scheduled such a fsck job
+after the 11th day of the month. So I expedited putting a release out to
+avoid anyone else running into it starting tomorrow.
+
+(Oddly, the 11th day of this month also happens to be my birthday. I did not
+expect to have to cut 2 releases today..)
diff --git a/doc/devblog/day_152__more_ssh_connection_caching.mdwn b/doc/devblog/day_152__more_ssh_connection_caching.mdwn
new file mode 100644
index 0000000..ad472b5
--- /dev/null
+++ b/doc/devblog/day_152__more_ssh_connection_caching.mdwn
@@ -0,0 +1,37 @@
+Made ssh connection caching be used in several more places. `git annex
+sync` will use it when pushing/pulling to a remote, as will the assistant.
+And `git-annex remotedaemon` also uses connection caching. So, when
+a push lands on a ssh remote, the assistant will immediately notice it, and
+pull down the change over the same TCP connection used for the
+notifications.
+
+This was a bit of a pain to do. Had to set `GIT_SSH=git-annex` and then
+when git invokes git-annex as ssh, it runs ssh with the connection caching
+parameters.
+
+Also, improved the network-manager and wicd code, so it detects when a
+connection has gone down. That propagates through to the remote-daemon,
+which closes all ssh connections. I need to also find out how to detect
+network connections/disconnections on OSX..
+
+Otherwise, the remote-control branch seems ready to be merged. But I want
+to test it for a while first.
+
+----
+
+Followed up on yesterday's bug with writing some test cases for
+Utility.Scheduled, which led to some more bug fixes. Luckily nothing
+I need to rush out a release over. In the end, the code got a lot
+simpler and clearer.
+
+[[!format haskell """
+-- Check if the new Day occurs one month or more past the old Day.
+oneMonthPast :: Day -> Day -> Bool
+new `oneMonthPast` old = fromGregorian y (m+1) d <= new
+ where
+ (y,m,d) = toGregorian old
+"""]]
+
+-------
+
+Today's work was sponsored by Asbjørn Sloth Tønnesen.
diff --git a/doc/devblog/day_153__remotedaemon_has_landed.mdwn b/doc/devblog/day_153__remotedaemon_has_landed.mdwn
new file mode 100644
index 0000000..5033b32
--- /dev/null
+++ b/doc/devblog/day_153__remotedaemon_has_landed.mdwn
@@ -0,0 +1,10 @@
+After fixing a few bugs in the `remotecontrol` branch, It's landed in
+`master`. Try a daily build today, and see if the assistant can keep in
+sync using nothing more than a remote ssh repository!
+
+So, now all the groundwork for telehash is laid too. I only need a
+telehash library to start developing on top of. Development on telehash-c
+is continuing, but I'm more excited that
+[htelehash](https://github.com/alanz/htelehash/tree/v2)
+has been revived and is being updated to the v2 protocol, seemingly quite
+quickly.
diff --git a/doc/devblog/day_154__catching_up.mdwn b/doc/devblog/day_154__catching_up.mdwn
new file mode 100644
index 0000000..7c49a78
--- /dev/null
+++ b/doc/devblog/day_154__catching_up.mdwn
@@ -0,0 +1,13 @@
+Worked through message backlog today. Got it down from around 70 to just
+37. Was able to fix some bugs, including making the webapp start up more
+robustly in some misconfigurations.
+
+Added a new `findref` command which may be useful in a git `update` hook to
+deny pushes of refs if the annexed content has not been sent first.
+
+----
+
+BTW, I also added a new `reinit` command a few days ago, which can be
+useful if you're cloning back a deleted repository.
+
+Also a few days ago, I made `uninit` a *lot* faster.
diff --git a/doc/devblog/day_155__missing_bits.mdwn b/doc/devblog/day_155__missing_bits.mdwn
new file mode 100644
index 0000000..aa8fd9d
--- /dev/null
+++ b/doc/devblog/day_155__missing_bits.mdwn
@@ -0,0 +1,27 @@
+Sometimes you don't notice something is missing for a long time until
+it suddenly demands attention. Like today.
+
+Seems the webapp never had a way to stop using XMPP and delete the XMPP
+password. So I added one.
+
+The new support for instantly noticing changes on a ssh remote forgot to
+start up a connection to a new remote after it was created. Fixed that.
+
+(While doing some testing on Android for unrelated reasons, I noticed that
+my android tablet was pushing photos to a ssh server and my laptop
+immediately noticed and downloaded them from tere, which is an excellent
+demo. I will deploy this on my trip in Brazil next week. Yes, I'm spending
+2 weeks in Brazil with git-annex users; more on this later.)
+
+Finally, it turns out that "installing" git-annex from the standalone
+tarball, or DMG, on a server didn't make it usable by the webapp. Because
+git-annex shell is not in PATH on the server, and indeed git and rsync may
+not be in PATH either if they were installed with the git-annex bundle.
+Fixed this by making the bundle install a ~/.ssh/git-annex-wrapper, which
+the webapp will detect and use.
+
+Also, quite a lot of other bug chasing activity.
+
+----
+
+Today's work was sponsored by Thomas Koch.
diff --git a/doc/encryption/comment_2_f19c9bb519a7017f0731fd0e8780ed74._comment b/doc/encryption/comment_2_f19c9bb519a7017f0731fd0e8780ed74._comment
deleted file mode 100644
index bf43303..0000000
--- a/doc/encryption/comment_2_f19c9bb519a7017f0731fd0e8780ed74._comment
+++ /dev/null
@@ -1,22 +0,0 @@
-[[!comment format=mdwn
- username="https://openid.stackexchange.com/user/e65e6d0e-58ba-41de-84cc-1f2ba54cf574"
- nickname="Mica Semrick"
- subject="Encrypt with pub or sub?"
- date="2014-04-08T03:56:36Z"
- content="""
-Forgive me, I'm a bit new to PGP.
-
-I do:
-
- $ gpg --list-keys
- /home/user/.gnupg/pubring.gpg
- ------------------------------
- pub 2048R/41363A6A 2014-04-03
- uid A Guy (git-annex key) <A@guy.com>
- sub 2048R/77998J8TDY 2014-04-03
-
-and see the pub and the sub key.
-
-When I init a new special remote and want encryption, should I give the init command the pub or the sub key? Or does git annex sort that out itself?
-
-"""]]
diff --git a/doc/forum/Big_repository_vs._multiple_small.mdwn b/doc/forum/Big_repository_vs._multiple_small.mdwn
new file mode 100644
index 0000000..c77dd02
--- /dev/null
+++ b/doc/forum/Big_repository_vs._multiple_small.mdwn
@@ -0,0 +1,8 @@
+I am new to git (but extensively used SVN).
+
+In SVN I could have a big fat repository but only check out sub-trees is it.
+Is that also common in git(-annex) / recommended?
+
+E.g., should I create a big-fat repos with all data I have (personal data, music, videos, ...) and check out only the appropriate subtress or create a repository for each purpose? E.g., one for Fotos, Music, OnTheGoData, ebooks, ...
+
+What happens if I have a git-annex repository checked out at my laptop (say, d:\Files) and within it, check out another one (e.g. d:\Files\Library)?
diff --git a/doc/forum/Corrupt_Repository_Invalid_Object.mdwn b/doc/forum/Corrupt_Repository_Invalid_Object.mdwn
new file mode 100644
index 0000000..af6d8e3
--- /dev/null
+++ b/doc/forum/Corrupt_Repository_Invalid_Object.mdwn
@@ -0,0 +1,10 @@
+One of my repositories got corrupted. I am not exactly sure how it happened (was running a series of commands) but I think I accidentally ran regular mv instead of git mv. To fix it I deleted the moved file then checkout the original link however this did not fixed the problem. I ended up with a corrupted repo. Now running any command ends with the following error,
+
+ ga sync
+ (merging origin/git-annex origin/synced/git-annex into git-annex...)
+ (Recording state in git...)
+ error: invalid object 040000 6ad564920e3d78d31c9456f5be3869a0319f9f08 for'3fd/d44'
+ fatal: git-write-tree: error building trees
+ git-annex: failed to read sha from git write-tree
+
+Was wondering how to fix this? I did run git fsck and git annex fsck but non fixed the problem.
diff --git a/doc/forum/Starting_assistant_from_CLI.mdwn b/doc/forum/Starting_assistant_from_CLI.mdwn
new file mode 100644
index 0000000..8a4bc3d
--- /dev/null
+++ b/doc/forum/Starting_assistant_from_CLI.mdwn
@@ -0,0 +1,9 @@
+I am unable to start the git-annex assistant/webapp.
+
+I use OpenBox as desktop manager and the assistant/webapp is not available through the menu.
+
+Trying to use the CLI, all my attempts fail with a message saying that it(?) is not a git repository!? Since the video show that on first start the assistant/webapp allows a choice of a directory and then creates it, I am not sure as to what git initialized directory does the assistant/webapp requires in this instance. And I also guess that means invoking the webapp from that directory rather than from the directory that contains the standalone git-annex.
+
+Any help would be appreciated as git-annex really seems to be the app I am looking for. :)
+
+Thanks
diff --git a/doc/forum/best_practices_for_importing_photos__63__.mdwn b/doc/forum/best_practices_for_importing_photos__63__.mdwn
new file mode 100644
index 0000000..2f57f3b
--- /dev/null
+++ b/doc/forum/best_practices_for_importing_photos__63__.mdwn
@@ -0,0 +1,13 @@
+What are everyone's tips for importing photos to make best use of metadata and views?
+
+Let's assume there's no need to be compatible with a photo manager app, but we may be importing lots of duplicates, and while content deduplication is great, I'd like to avoid naming problems too.
+
+Do you bother to rename your photos?
+
+Do you use EXIF metadata as git-annex metadata? Selectively or wholesale, with all the redundant tags in EXIF?
+
+If you do use a photo manager app, do you need to do anything special to make that work?
+
+Thanks for your responses everyone!
+
+-mike
diff --git a/doc/forum/sync_stages_deletions_on_remote.mdwn b/doc/forum/sync_stages_deletions_on_remote.mdwn
new file mode 100644
index 0000000..73a51d0
--- /dev/null
+++ b/doc/forum/sync_stages_deletions_on_remote.mdwn
@@ -0,0 +1,72 @@
+I'm having an issue with 2 repos: one on my laptop, the other on my NAS. Both are in indirect mode, running Arch Linux, and have the latest Git version. Laptop has git-annex 5.20140411-gda795e0, NAS has 5.20140319-g9aa31b7 (from prebuilt tarballs).
+
+The issue is quite simple. When I `git-annex add` new files on my laptop, commit them, and then `git-annex sync` them, they show up as staged for deletion on my NAS.
+
+ laptop $ git annex add some-file
+ laptop $ git commit -m "Add some-file"
+ laptop $ git annex sync
+ commit ok
+ pull ds413j
+ ok
+ push ds413j
+ Counting objects: 133, done.
+ Delta compression using up to 8 threads.
+ Compressing objects: 100% (78/78), done.
+ Writing objects: 100% (80/80), 10.64 KiB | 0 bytes/s, done.
+ Total 80 (delta 12), reused 0 (delta 0)
+ To ssh://**/**
+ 1dcd188..8ef4249 git-annex -> synced/git-annex
+ c0f45a6..21711d6 master -> synced/master
+ ok
+ laptop $ ssh $NAS
+ nas $ git status
+ On branch master
+ Changes to be committed:
+ (use "git reset HEAD <file>..." to unstage)
+
+ deleted: some-file
+
+ nas $
+
+If I run `git annex sync` on the NAS, it will create a new commit that deletes that file. So I have to play with `git reset`/`git checkout` by hand to make sure that the new file won't be deleted.
+
+I'm not sure when this started, but I think it was after I did some stupid mistake (`git checkout -B master synced/master`, kill a `git annex sync` with Ctrl+C, or something else that even resulted in my non-bare repo to have "bare=true" in .git/config...). And I haven't yet been able to fix this.
+
+Any idea what can have caused this, how to fix it, and how to prevent it from happening again in the future?
+
+.git/config on NAS:
+
+ [core]
+ repositoryformatversion = 0
+ filemode = true
+ logallrefupdates = true
+ [annex]
+ uuid = d54ae60a-1f59-403c-923f-32ea3bf2d00f
+ version = 5
+ diskreserve = 1 megabyte
+ autoupgrade = ask
+ debug = false
+
+.git/config on laptop:
+
+ [core]
+ repositoryformatversion = 0
+ filemode = true
+ bare = false
+ logallrefupdates = true
+ [branch "master"]
+ [annex]
+ uuid = f20cb506-945d-4c78-af1a-0aa884bb899b
+ version = 5
+ diskreserve = 20 gigabytes
+ autoupgrade = ask
+ debug = false
+ expireunused = 7d
+ genmetadata = true
+ [push]
+ default = matching
+ [remote "ds413j"]
+ url = ssh://**/**
+ fetch = +refs/heads/*:refs/remotes/ds413j/*
+ annex-uuid = d54ae60a-1f59-403c-923f-32ea3bf2d00f
+ annex-sync = true
diff --git a/doc/forum/taskwarrior/comment_2_4b3d70501763f6d36c927ae37bbd33c2._comment b/doc/forum/taskwarrior/comment_2_4b3d70501763f6d36c927ae37bbd33c2._comment
new file mode 100644
index 0000000..ec6bcb9
--- /dev/null
+++ b/doc/forum/taskwarrior/comment_2_4b3d70501763f6d36c927ae37bbd33c2._comment
@@ -0,0 +1,8 @@
+[[!comment format=mdwn
+ username="https://me.yahoo.com/a/FHnTlSBo1eCGJRwueeKeB6.RCaPbGMPr5jxx8A--#ce0d8"
+ nickname="Hamza"
+ subject="comment 2"
+ date="2014-04-14T15:27:48Z"
+ content="""
+Using direct mode would replace symlinks with actual files.
+"""]]
diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn
index 03e05d9..d5408a2 100644
--- a/doc/git-annex.mdwn
+++ b/doc/git-annex.mdwn
@@ -845,6 +845,17 @@ subdirectories).
repository, and remove all of git-annex's other data, leaving you with a
git repository plus the previously annexed files.
+* `reinit uuid|description`
+
+ Normally, initializing a repository generates a new, unique identifier
+ (UUID) for that repository. Occasionally it may be useful to reuse a
+ UUID -- for example, if a repository got deleted, and you're
+ setting it back up.
+
+ Use this with caution; it can be confusing to have two existing
+ repositories with the same UUID. Also, you will probably want to run
+ a fsck.
+
# PLUMBING COMMANDS
* `pre-commit [path ...]`
@@ -916,6 +927,14 @@ subdirectories).
With `--force`, even files whose content is not currently available will
be rekeyed. Use with caution.
+* `findref [ref]`
+
+ This is similar to the find command, but instead of finding files in the
+ current work tree, it finds files in the specified git ref.
+
+ Most MATCHING OPTIONS can be used with findref, to limit the files it
+ finds. However, the --include and --exclude options will not work.
+
* `test`
This runs git-annex's built-in test suite.
@@ -924,7 +943,7 @@ subdirectories).
* `remotedaemon`
- Detects when remotes have changed and fetches from them.
+ Detects when network remotes have received git pushes and fetches from them.
* `xmppgit`
diff --git a/doc/news/version_5.20140320.mdwn b/doc/news/version_5.20140320.mdwn
deleted file mode 100644
index ee2e95d..0000000
--- a/doc/news/version_5.20140320.mdwn
+++ /dev/null
@@ -1,37 +0,0 @@
-git-annex 5.20140320 released with [[!toggle text="these changes"]]
-[[!toggleable text="""
- * Fix zombie leak and general inneficiency when copying files to a
- local git repo.
- * Fix ssh connection caching stop method to work with openssh 6.5p1,
- which broke the old method.
- * webapp: Added a "Sync now" item to each repository's menu.
- * webapp: Use securemem for constant time auth token comparisons.
- * copy --fast --to remote: Avoid printing anything for files that
- are already believed to be present on the remote.
- * Commands that allow specifying which repository to act on using
- the repository's description will now fail when multiple repositories
- match, rather than picking a repository at random.
- (So will --in=)
- * Better workaround for problem umasks when eg, setting up ssh keys.
- * "standard" can now be used as a first-class keyword in preferred content
- expressions. For example "standard or (include=otherdir/*)"
- * groupwanted can be used in preferred content expressions.
- * vicfg: Allows editing preferred content expressions for groups.
- * Improve behavior when unable to parse a preferred content expression
- (thanks, ion).
- * metadata: Add --get
- * metadata: Support --key option (and some other ones like --all)
- * For each metadata field, there's now an automatically maintained
- "$field-lastchanged" that gives the date of the last change to that
- field. Also the "lastchanged" field for the date of the last change
- to any of a file's metadata.
- * unused: In direct mode, files that are deleted from the work tree
- and so have no content present are no longer incorrectly detected as
- unused.
- * Avoid encoding errors when using the unused log file.
- * map: Fix crash when one of the remotes of a repo is a local directory
- that does not exist, or is not a git repo.
- * repair: Improve memory usage when git fsck finds a great many broken
- objects.
- * Windows: Fix some filename encoding bugs.
- * rsync special remote: Fix slashes when used on Windows."""]] \ No newline at end of file
diff --git a/doc/news/version_5.20140421.mdwn b/doc/news/version_5.20140421.mdwn
new file mode 100644
index 0000000..3741544
--- /dev/null
+++ b/doc/news/version_5.20140421.mdwn
@@ -0,0 +1,39 @@
+git-annex 5.20140421 released with [[!toggle text="these changes"]]
+[[!toggleable text="""
+ * assistant: Now detects immediately when other repositories push
+ changes to a ssh remote, and pulls.
+ ** XMPP is no longer needed in this configuration! **
+ This requires the remote server have git-annex-shell with
+ notifychanges support (&gt;= 5.20140405)
+ * webapp: Show a network signal icon next to ssh and xmpp remotes that
+ it's currently connected with.
+ * webapp: Rework xmpp nudge to prompt for either xmpp or a ssh remote
+ to be set up.
+ * sync, assistant, remotedaemon: Use ssh connection caching for git pushes
+ and pulls.
+ * remotedaemon: When network connection is lost, close all cached ssh
+ connections.
+ * Improve handling of monthly/yearly scheduling.
+ * Avoid depending on shakespeare except for when building the webapp.
+ * uninit: Avoid making unncessary copies of files.
+ * info: Allow use in a repository where annex.uuid is not set.
+ * reinit: New command that can initialize a new repository using
+ the configuration of a previously known repository.
+ Useful if a repository got deleted and you want
+ to clone it back the way it was.
+ * drop --from: When local repository is untrusted, its copy of a file does
+ not count.
+ * Bring back rsync -p, but only when git-annex is running on a non-crippled
+ file system. This is a better approach to fix #700282 while not
+ unncessarily losing file permissions on non-crippled systems.
+ * webapp: Start even if the current directory is listed in
+ ~/.config/git-annex/autostart but no longer has a git repository in it.
+ * findref: New command, like find but shows files in a specified git ref.
+ * webapp: Fix UI for removing XMPP connection.
+ * When init detects that git is not configured to commit, and sets
+ user.email to work around the problem, also make it set user.name.
+ * webapp: Support using git-annex on a remote server, which was installed
+ from the standalone tarball or OSX app, and so does not have
+ git-annex in PATH (and may also not have git or rsync in PATH).
+ * standalone tarball, OSX app: Install a ~/.ssh/git-annex-wrapper, which
+ can be used to run git-annex, git, rsync, etc."""]] \ No newline at end of file
diff --git a/doc/preferred_content/standard_groups.mdwn b/doc/preferred_content/standard_groups.mdwn
index dd73b66..2a62416 100644
--- a/doc/preferred_content/standard_groups.mdwn
+++ b/doc/preferred_content/standard_groups.mdwn
@@ -13,7 +13,7 @@ any repository that can will back it up.)
All content is wanted, unless it's for a file in a "archive" directory,
which has reached an archive repository, or is unused.
-`(((exclude=*/archive/* and exclude=archive/*) or (not (copies=archive:1 or copies=smallarchive:1))) and not unused) or roughlylackingcopies=1`
+`(((exclude=*/archive/* and exclude=archive/*) or (not (copies=archive:1 or copies=smallarchive:1))) and not unused) or approxlackingcopies=1`
### transfer
diff --git a/doc/tips/automatically_adding_metadata/pre-commit-annex b/doc/tips/automatically_adding_metadata/pre-commit-annex
index f300bd7..fe818d0 100755
--- a/doc/tips/automatically_adding_metadata/pre-commit-annex
+++ b/doc/tips/automatically_adding_metadata/pre-commit-annex
@@ -1,6 +1,11 @@
#!/bin/sh
+#
# This script can be used to add git-annex metadata to files when they're
-# committed.
+# committed. It is typically installed as .git/hooks/pre-commit-annex
+#
+# You can also run this script by hand, passing it the names of files
+# already checked into git-annex, and it will extract/refresh the git-annex
+# metadata from the files.
#
# Copyright 2014 Joey Hess <id@joeyh.name>
# License: GPL-3+
@@ -12,8 +17,6 @@ if [ -z "$want" ]; then
exit 0
fi
-echo "$want"
-
case "$(git config --bool metadata.overwrite || true)" in
true)
overwrite=1
@@ -46,7 +49,8 @@ fi
IFS="
"
-for f in $(git diff-index --name-only --cached $against); do
+
+process () {
if [ -e "$f" ]; then
for l in $(extract "$f" | egrep "$want"); do
field="${l%% - *}"
@@ -54,4 +58,14 @@ for f in $(git diff-index --name-only --cached $against); do
addmeta "$f" "$field" "$value"
done
fi
-done
+}
+
+if [ -n "$*" ]; then
+ for f in $@; do
+ process "$f"
+ done
+else
+ for f in $(git diff-index --name-only --cached $against); do
+ process "$f"
+ done
+fi
diff --git a/doc/tips/file_manager_integration.mdwn b/doc/tips/file_manager_integration.mdwn
index 1a1a557..3fea3e9 100644
--- a/doc/tips/file_manager_integration.mdwn
+++ b/doc/tips/file_manager_integration.mdwn
@@ -91,10 +91,10 @@ Edit this page and add instructions!
If your file manager can run a command on a file, it should be easy to
integrate git-annex with it. A simple script will suffice:
- #!/bun/sh
+ #!/bin/sh
git-annex get --notify-start --notify-finish -- "$@"
The --notify-start and --notify-stop options make git-annex display a
desktop notification. This is useful to give the user an indication that
their action took effect. Desktop notifications are currently only
-implenented for Linux.
+implemented for Linux.
diff --git a/doc/tips/flickrannex/comment_14_c728f10074d194efa8b2c60e97d275e7._comment b/doc/tips/flickrannex/comment_14_c728f10074d194efa8b2c60e97d275e7._comment
new file mode 100644
index 0000000..f625d6b
--- /dev/null
+++ b/doc/tips/flickrannex/comment_14_c728f10074d194efa8b2c60e97d275e7._comment
@@ -0,0 +1,12 @@
+[[!comment format=mdwn
+ username="https://id.koumbit.net/anarcat"
+ ip="72.0.72.144"
+ subject="great job on that plugin!"
+ date="2014-04-15T04:47:17Z"
+ content="""
+it's pretty awesome to have 1TB of free storage like that out there... but for storing photos, it could be improved - I filed a few bugs on the github repo here:
+
+https://github.com/TobiasTheViking/flickrannex/issues/created_by/anarcat?state=open
+
+thanks!
+"""]]
diff --git a/doc/tips/using_Amazon_S3/comment_3_32acba030c2ad252e2f7027075e4303e._comment b/doc/tips/using_Amazon_S3/comment_3_32acba030c2ad252e2f7027075e4303e._comment
new file mode 100644
index 0000000..e83ade0
--- /dev/null
+++ b/doc/tips/using_Amazon_S3/comment_3_32acba030c2ad252e2f7027075e4303e._comment
@@ -0,0 +1,8 @@
+[[!comment format=mdwn
+ username="annexuser"
+ ip="64.71.7.82"
+ subject="Altering AWS credentials"
+ date="2014-04-15T21:59:43Z"
+ content="""
+If I revoke old AWS credentials and create new ones, how would I inform git-annex of the change to `AWS_ACCESS_KEY_ID` and `AWS_SECRET_ACCESS_KEY`?
+"""]]
diff --git a/doc/tips/using_Amazon_S3/comment_4_92df5a9f923beafba55a1c455728112e._comment b/doc/tips/using_Amazon_S3/comment_4_92df5a9f923beafba55a1c455728112e._comment
new file mode 100644
index 0000000..5bcf34b
--- /dev/null
+++ b/doc/tips/using_Amazon_S3/comment_4_92df5a9f923beafba55a1c455728112e._comment
@@ -0,0 +1,13 @@
+[[!comment format=mdwn
+ username="http://joeyh.name/"
+ ip="209.250.56.191"
+ subject="comment 4"
+ date="2014-04-17T19:44:55Z"
+ content="""
+You can use `git annex enableremote` to change an existing remote's configuration. So this should work:
+
+ # export AWS_ACCESS_KEY_ID=\"newRANDOMGOBBLDEYGOOK\"
+ # export AWS_SECRET_ACCESS_KEY=\"news3kr1t\"
+ # git annex enableremote cloud
+
+"""]]
diff --git a/doc/tips/using_gitolite_with_git-annex.mdwn b/doc/tips/using_gitolite_with_git-annex.mdwn
index 746b6b1..31f34c6 100644
--- a/doc/tips/using_gitolite_with_git-annex.mdwn
+++ b/doc/tips/using_gitolite_with_git-annex.mdwn
@@ -9,12 +9,73 @@ file contents, but not change anything.
First, you need new enough versions:
-* gitolite 2.2 is needed -- this version contains a git-annex-shell ADC
- and supports "ua" ADCs. Alternatively, gitoline g3 also recently added
- support for git-annex.
+* the current `master` branch of gitolite works with git-annex (tested 2014-04-19),
+ but v3.5.3 and earlier v3.x require use of the `git-annex` branch.
+* gitolite 2.2 also works -- this version contains a git-annex-shell ADC
+ and supports "ua" ADCs.
* git-annex 3.20111016 or newer needs to be installed on the gitolite
server. Don't install an older version, it wouldn't be secure!
+### Instructions for gitolite `master` branch
+
+To setup gitolite to work with git-annex, you can follow the instructions on the gitolite website,
+and just add `'git-annex-shell ua',` to the ENABLE list in `~/.gitolite.rc`.
+
+Here are more detailed instructions:
+
+1: Create a `git` user
+
+<pre>
+sudo adduser \
+ --system \
+ --shell /bin/bash \
+ --gecos 'git version control' \
+ --group \
+ --disabled-password \
+ --home /home/git git
+</pre>
+
+2: Copy a public SSH key for the user you want to be the gitolite administrator.
+In the instructions below, I placed the key in a file named `/home/git/me.pub`.
+
+3: Clone and install gitolite
+
+First switch to the `git` user (e.g. `sudo su - git`) and then run:
+
+<pre>
+cd
+git clone https://github.com/sitaramc/gitolite.git
+mkdir -p bin
+./gitolite/install -ln
+</pre>
+
+4: Add `~/bin` to `PATH`
+
+Make sure that `~/bin` is in the `PATH`, since that's where gitolite installed its binary. Do something like this:
+
+<pre>
+echo 'export PATH=/home/git/bin:$PATH' >> .profile
+export PATH=/home/git/bin:$PATH
+</pre>
+
+5: Configure gitolite
+
+Edit `~/.gitolite.rc` to enable the git-annex-shell command.
+Find the `ENABLE` list and add this line in there somewhere:
+
+<pre>
+'git-annex-shell ua',
+</pre>
+
+Now run gitolite's setup:
+
+<pre>
+gitolite setup -pk me.pub
+rm me.pub
+</pre>
+
+### Instructions for gitolite 2.2
+
And here's how to set it up. The examples are for gitolite as installed
on Debian with apt-get, but the changes described can be made to any
gitolite installation, just with different paths.
@@ -38,13 +99,6 @@ cd /usr/local/lib/gitolite/adc/ua/
cp gitolite/contrib/adc/git-annex-shell .
</pre>
-If using gitolite g3, an additional setup step is needed:
-In the ENABLE list in the rc file, add an entry like this:
-
-<pre>
- 'git-annex-shell ua',
-</pre>
-
Now all gitolite repositories can be used with git-annex just as any
ssh remote normally would be used. For example:
diff --git a/doc/todo/Time_Stamping_of_Events_in_Webapp.mdwn b/doc/todo/Time_Stamping_of_Events_in_Webapp.mdwn
index a1f3fe6..0762f47 100644
--- a/doc/todo/Time_Stamping_of_Events_in_Webapp.mdwn
+++ b/doc/todo/Time_Stamping_of_Events_in_Webapp.mdwn
@@ -1 +1,3 @@
Currently events happening in the webapp (sync upload etc. on the right) has no time stamp thus user has no way to tell when was the last sync happened. Which is problematic when not using XMPP and repos lag behind.
+
+> [[dup|done]] of <http://git-annex.branchable.com/todo/wishlist__91__minor__93__:_add_time_stamps_to_annex_log_popups_in_webapp/> --[[Joey]]
diff --git a/doc/todo/allow_removing_jabber_configuration.mdwn b/doc/todo/allow_removing_jabber_configuration.mdwn
new file mode 100644
index 0000000..6237025
--- /dev/null
+++ b/doc/todo/allow_removing_jabber_configuration.mdwn
@@ -0,0 +1,5 @@
+right now it is unclear through the webapp how to unconfigure a jabber
+account, which is especially critical considering the password needs to be
+stored in the clear (where?). -- [[anarcat]]
+
+> [[fixed|done]] --[[Joey]]
diff --git a/doc/todo/build_a_user_guide.mdwn b/doc/todo/build_a_user_guide.mdwn
new file mode 100644
index 0000000..9741439
--- /dev/null
+++ b/doc/todo/build_a_user_guide.mdwn
@@ -0,0 +1,3 @@
+there's a lot of good documentation on this wiki, but it's hard to find sometimes. it's also unclear if we should look in the [[git-annex]] manpage or elsewhere in the wiki or where. this is a typical problem with the use of wikis for documentation: it's there, but hard to find. it doesn't mean a wiki shouldn't be used but, as with any user manual, special care needs to be taken about structure, organisation and making sure the manual is exhaustive.
+
+a good example of this problem is [[todo/document_standard_groups_more_extensively_in_the_UI]]. --[[anarcat]]
diff --git a/doc/todo/do_not_bug_me_about_intermediate_files.mdwn b/doc/todo/do_not_bug_me_about_intermediate_files.mdwn
new file mode 100644
index 0000000..6cb71b5
--- /dev/null
+++ b/doc/todo/do_not_bug_me_about_intermediate_files.mdwn
@@ -0,0 +1,7 @@
+[[!meta title="--notify-finish operates on a per-file, not per-process basis"]]
+
+so this is another UX pickyness, but it seems important to me.
+
+i like the new desktop notifications, but they are little too verbose. when i choose "git annex get" on the folder, if there's a lot of files, it will flood me with all the files being transfered in a mostly incomprehensible list of files being transfered.
+
+what i would expect is more: "starting transfer of folder X", "transfer of folder X finished!", only two message per item i chose. this is especially a problem with DVD backups, which have a bunch of small files (screenshots, .nfos and so on) and large video files - so it seems the thing has finished transfering, while it's only partly done. --[[anarcat]]
diff --git a/doc/todo/document_standard_groups_more_extensively_in_the_UI.mdwn b/doc/todo/document_standard_groups_more_extensively_in_the_UI.mdwn
new file mode 100644
index 0000000..1e9afde
--- /dev/null
+++ b/doc/todo/document_standard_groups_more_extensively_in_the_UI.mdwn
@@ -0,0 +1,14 @@
+i have been using git-annex for a while now, yet I still can't quite wrap my head around [[preferred_content/standard groups]], especially how they are documented in about/repogroups in the assistant web interface. i have repeatedly synced files where they shouldn't have been synced (usually by setting the repo as "client" or "transfer") and also destroyed files I wanted to keep by setting it to "unwanted" (actually, that was by pressing the "delete" button on the repo, which i didn't expect to drop the files on the remote...)
+
+i have been able to understand a lot of what's going on by trial and error and by decrypting the [[preferred_content]] expressions on the wiki.
+
+it seems to me the [[preferred_content/standard groups]] wiki page and the `about/repogroups` URL in the assistant should be merged:
+
+ 1. the assistant should be more explicit: maybe it should have examples of what will happen in some cases to give an idea. maybe "stories" like "a transfer repo is for when you have two client repos that can't talk to each other, so you use a transfer repo, e.g. a portable hard drive, to transfer files between them". having the actual, current [[preferred_content]] expressions from the [[preferred_content/standard groups]] groups page would also help, maybe in a smaller font to not scare people of
+ 2. the [[preferred_content/standard groups]] wiki page should be expanded to include narratives like the ones that are in the `about/repogroups` page of the assistant. that way people looking at the software from the outside can understand the mechanics better
+
+ideally, that documentation would be the one and the same so that a change on one side would reflect on the other.
+
+in fact, having an inline manual in the assistant would be a must: we want this thing to work offline, so it should be able to access this wiki, or whatever of it is shipped with git-annex.
+
+that way we wouldn't have this kind of inconsistencies... more generally, maybe we could even [[build a user guide]]! -- [[anarcat]]
diff --git a/doc/todo/sharedRepository_mode_not_supported_by_git-annex.mdwn b/doc/todo/sharedRepository_mode_not_supported_by_git-annex.mdwn
new file mode 100644
index 0000000..85005db
--- /dev/null
+++ b/doc/todo/sharedRepository_mode_not_supported_by_git-annex.mdwn
@@ -0,0 +1,7 @@
+git's core.SharedRepository is supported by git-annex, but only
+with the group/all/world/everybody settings. core.SharedRepository=0644
+etc is not supported.
+
+There's no insormountable reason why not, Joey just hates umask mode math
+stuff and nobody has sent a patch. Note that Annex.Content.freezeContent
+should remove the write bit from files, no matter what.
diff --git a/doc/users/tobiastheviking.mdwn b/doc/users/tobiastheviking.mdwn
index 0629e34..31398da 100644
--- a/doc/users/tobiastheviking.mdwn
+++ b/doc/users/tobiastheviking.mdwn
@@ -2,19 +2,12 @@ Tobias Ussing
See:
-[[https://github.com/TobiasTheViking/flickrannex/]]
-
-[[https://github.com/TobiasTheViking/imapannex]]
-
-[[https://github.com/TobiasTheViking/dropboxannex]]
-
-[[https://github.com/TobiasTheViking/skydriveannex]]
-
-[[https://github.com/TobiasTheViking/googledriveannex]]
-
-[[https://github.com/TobiasTheViking/owncloudannex]]
-
-[[https://github.com/TobiasTheViking/megaannex]]
-
-[[http://git-annex.branchable.com/forum/nntp__47__usenet_special_remote/]]
+* [[tips/flickrannex]] - [[https://github.com/TobiasTheViking/flickrannex/]]
+* [[tips/imapannex]] - [[https://github.com/TobiasTheViking/imapannex]]
+* [[tips/dropboxannex]] - [[https://github.com/TobiasTheViking/dropboxannex]]
+* [[tips/skydriveannex]] - [[https://github.com/TobiasTheViking/skydriveannex]]
+* [[tips/googledriveannex]] - [[https://github.com/TobiasTheViking/googledriveannex]]
+* [[tips/owncloudannex]] - [[https://github.com/TobiasTheViking/owncloudannex]]
+* [[tips/megaannex]] - [[https://github.com/TobiasTheViking/megaannex]]
+* [[forum/nntp__47__usenet_special_remote/]]
diff --git a/git-annex.1 b/git-annex.1
index d7899cc..497f3c6 100644
--- a/git-annex.1
+++ b/git-annex.1
@@ -781,6 +781,16 @@ Use this to stop using git annex. It will unannex every file in the
repository, and remove all of git\-annex's other data, leaving you with a
git repository plus the previously annexed files.
.IP
+.IP "\fBreinit uuid|description\fP"
+Normally, initializing a repository generates a new, unique identifier
+(UUID) for that repository. Occasionally it may be useful to reuse a
+UUID \-\- for example, if a repository got deleted, and you're
+setting it back up.
+.IP
+Use this with caution; it can be confusing to have two existing
+repositories with the same UUID. Also, you will probably want to run
+a fsck.
+.IP
.SH PLUMBING COMMANDS
.IP "\fBpre\-commit [path ...]\fP"
.IP
@@ -844,13 +854,20 @@ both the file, and the new key to use for it.
With \fB\-\-force\fP, even files whose content is not currently available will
be rekeyed. Use with caution.
.IP
+.IP "\fBfindref [ref]\fP"
+This is similar to the find command, but instead of finding files in the
+current work tree, it finds files in the specified git ref.
+.IP
+Most MATCHING OPTIONS can be used with findref, to limit the files it
+finds. However, the \-\-include and \-\-exclude options will not work.
+.IP
.IP "\fBtest\fP"
This runs git\-annex's built\-in test suite.
.IP
There are several parameters, provided by Haskell's tasty test framework.
.IP
.IP "\fBremotedaemon\fP"
-Detects when remotes have changed and fetches from them.
+Detects when network remotes have received git pushes and fetches from them.
.IP
.IP "\fBxmppgit\fP"
This command is used internally to perform git pulls over XMPP.
diff --git a/git-annex.cabal b/git-annex.cabal
index 855fecd..f770333 100644
--- a/git-annex.cabal
+++ b/git-annex.cabal
@@ -1,5 +1,5 @@
Name: git-annex
-Version: 5.20140412
+Version: 5.20140421
Cabal-Version: >= 1.8
License: GPL-3
Maintainer: Joey Hess <joey@kitenet.net>
@@ -101,7 +101,7 @@ Executable git-annex
base (>= 4.5 && < 4.9), monad-control, MonadCatchIO-transformers,
IfElse, text, QuickCheck >= 2.1, bloomfilter, edit-distance, process,
SafeSemaphore, uuid, random, dlist, unix-compat, async, stm (>= 2.3),
- data-default, case-insensitive, shakespeare
+ data-default, case-insensitive
CC-Options: -Wall
GHC-Options: -Wall
Extensions: PackageImports
@@ -191,7 +191,8 @@ Executable git-annex
yesod, yesod-default, yesod-static, yesod-form, yesod-core,
http-types, transformers, wai, wai-logger, warp, warp-tls,
blaze-builder, crypto-api, hamlet, clientsession,
- template-haskell, data-default, aeson, network-conduit
+ template-haskell, data-default, aeson, network-conduit,
+ shakespeare
CPP-Options: -DWITH_WEBAPP
if flag(Webapp) && flag (Webapp-secure)
Build-Depends: warp-tls (>= 1.4), securemem, byteable
@@ -210,7 +211,7 @@ Executable git-annex
CPP-Options: -DWITH_DNS
if flag(Feed)
- Build-Depends: feed (>= 0.3.9.2)
+ Build-Depends: feed
CPP-Options: -DWITH_FEED
if flag(Quvi)
diff --git a/standalone/linux/skel/runshell b/standalone/linux/skel/runshell
index 4481b0d..7370335 100755
--- a/standalone/linux/skel/runshell
+++ b/standalone/linux/skel/runshell
@@ -34,11 +34,26 @@ if [ ! -e "$HOME/.ssh/git-annex-shell" ]; then
(
echo "#!/bin/sh"
echo "set -e"
+ echo "if [ \"x\$SSH_ORIGINAL_COMMAND\" != \"x\" ]; then"
echo "exec $base/runshell git-annex-shell -c \"\$SSH_ORIGINAL_COMMAND\""
+ echo "else"
+ echo "exec $base/runshell git-annex-shell -c \"\$@\""
+ echo "fi"
) > "$HOME/.ssh/git-annex-shell"
chmod +x "$HOME/.ssh/git-annex-shell"
fi
+# And this shim is used by the webapp when adding a remote ssh server.
+if [ ! -e "$HOME/.ssh/git-annex-wrapper" ]; then
+ mkdir "$HOME/.ssh" >/dev/null 2>&1 || true
+ (
+ echo "#!/bin/sh"
+ echo "set -e"
+ echo "exec $base/runshell \"\$@\""
+ ) > "$HOME/.ssh/git-annex-wrapper"
+ chmod +x "$HOME/.ssh/git-annex-wrapper"
+fi
+
# Put our binaries first, to avoid issues with out of date or incompatable
# system binaries.
ORIG_PATH="$PATH"
diff --git a/standalone/osx/git-annex.app/Contents/MacOS/runshell b/standalone/osx/git-annex.app/Contents/MacOS/runshell
index 9f1457e..c5d689c 100755
--- a/standalone/osx/git-annex.app/Contents/MacOS/runshell
+++ b/standalone/osx/git-annex.app/Contents/MacOS/runshell
@@ -36,11 +36,26 @@ if [ ! -e "$HOME/.ssh/git-annex-shell" ]; then
(
echo "#!/bin/sh"
echo "set -e"
+ echo "if [ \"x\$SSH_ORIGINAL_COMMAND\" != \"x\" ]; then"
echo "exec $base/runshell git-annex-shell -c \"\$SSH_ORIGINAL_COMMAND\""
+ echo "else"
+ echo "exec $base/runshell git-annex-shell -c \"\$@\""
+ echo "fi"
) > "$HOME/.ssh/git-annex-shell"
chmod +x "$HOME/.ssh/git-annex-shell"
fi
+# And this shim is used by the webapp when adding a remote ssh server.
+if [ ! -e "$HOME/.ssh/git-annex-wrapper" ]; then
+ mkdir "$HOME/.ssh" >/dev/null 2>&1 || true
+ (
+ echo "#!/bin/sh"
+ echo "set -e"
+ echo "exec $base/runshell \"\$@\""
+ ) > "$HOME/.ssh/git-annex-wrapper"
+ chmod +x "$HOME/.ssh/git-annex-wrapper"
+fi
+
# Put our binaries first, to avoid issues with out of date or incompatable
# system binaries.
ORIG_PATH="$PATH"
diff --git a/templates/configurators/addrepository/cloud.hamlet b/templates/configurators/addrepository/cloud.hamlet
index 22d42fc..c5dad16 100644
--- a/templates/configurators/addrepository/cloud.hamlet
+++ b/templates/configurators/addrepository/cloud.hamlet
@@ -18,9 +18,4 @@
<p>
Good choice for professional quality storage.
-<h3>
- <a href="@{AddSshR}">
- <i .icon-plus-sign></i> Remote server
-<p>
- Set up a repository on a remote server using #
- <tt>ssh</tt>.
+^{makeSshRepository}
diff --git a/templates/configurators/addrepository/connection.hamlet b/templates/configurators/addrepository/connection.hamlet
new file mode 100644
index 0000000..fc111b0
--- /dev/null
+++ b/templates/configurators/addrepository/connection.hamlet
@@ -0,0 +1,3 @@
+^{makeXMPPConnection}
+
+^{makeSshRepository}
diff --git a/templates/configurators/addrepository/misc.hamlet b/templates/configurators/addrepository/misc.hamlet
index 5f0cc6b..79b1937 100644
--- a/templates/configurators/addrepository/misc.hamlet
+++ b/templates/configurators/addrepository/misc.hamlet
@@ -7,17 +7,7 @@
<a href="http://en.wikipedia.org/wiki/Sneakernet">SneakerNet</a> #
between computers.
-<h3>
- <a href="@{StartXMPPPairSelfR}">
- <i .icon-plus-sign></i> Share with your other devices
-<p>
- Keep files in sync between your devices running git-annex.
-
-<h3>
- <a href="@{StartXMPPPairFriendR}">
- <i .icon-plus-sign></i> Share with a friend
-<p>
- Combine your repository with a friend's repository, and share your files.
+^{makeXMPPConnection}
<h3>
<a href="@{StartLocalPairR}">
@@ -31,3 +21,5 @@
<i .icon-plus-sign></i> Add another repository
<p>
Make another repository on your computer.
+
+^{makeSshRepository}
diff --git a/templates/configurators/addrepository/ssh.hamlet b/templates/configurators/addrepository/ssh.hamlet
new file mode 100644
index 0000000..c41ad11
--- /dev/null
+++ b/templates/configurators/addrepository/ssh.hamlet
@@ -0,0 +1,6 @@
+<h3>
+ <a href="@{AddSshR}">
+ <i .icon-plus-sign></i> Remote server
+<p>
+ Set up a repository on a remote server using #
+ <tt>ssh</tt>.
diff --git a/templates/configurators/addrepository/xmppconnection.hamlet b/templates/configurators/addrepository/xmppconnection.hamlet
new file mode 100644
index 0000000..2fae69d
--- /dev/null
+++ b/templates/configurators/addrepository/xmppconnection.hamlet
@@ -0,0 +1,11 @@
+<h3>
+ <a href="@{StartXMPPPairSelfR}">
+ <i .icon-plus-sign></i> Share with your other devices
+<p>
+ Keep files in sync between your devices running git-annex.
+
+<h3>
+ <a href="@{StartXMPPPairFriendR}">
+ <i .icon-plus-sign></i> Share with a friend
+<p>
+ Combine your repository with a friend's repository, and share your files.
diff --git a/templates/configurators/delete/xmpp.hamlet b/templates/configurators/delete/xmpp.hamlet
new file mode 100644
index 0000000..62bd1d9
--- /dev/null
+++ b/templates/configurators/delete/xmpp.hamlet
@@ -0,0 +1,10 @@
+<div .span9 .hero-unit>
+ <h2>
+ Disconnecting from Jabber
+ <p>
+ This won't delete the repository or repositories at the other end
+ of the Jabber connection, but it will disconnect from them, and stop
+ using Jabber.
+ <p>
+ <a .btn .btn-primary href="@{DisconnectXMPPR}">
+ <i .icon-minus></i> Disconnect
diff --git a/templates/configurators/needconnection.hamlet b/templates/configurators/needconnection.hamlet
new file mode 100644
index 0000000..4cb9dc5
--- /dev/null
+++ b/templates/configurators/needconnection.hamlet
@@ -0,0 +1,12 @@
+<div .span9 .hero-unit>
+ <h2>
+ <i .icon-signal></i> Connection needed
+ <p>
+ In order to quickly sync with other repositories, #
+ a direct connection is needed to another git-annex. #
+ <p>
+ You don't currently seem to have such a connection configured -- #
+ or if you do, it's not currently connected!
+ <h2>
+ Add a connection
+ ^{makeConnectionRepositories}
diff --git a/templates/configurators/xmpp.hamlet b/templates/configurators/xmpp.hamlet
index e07fcd6..0f4b0d2 100644
--- a/templates/configurators/xmpp.hamlet
+++ b/templates/configurators/xmpp.hamlet
@@ -25,6 +25,8 @@
<div .form-actions>
<button .btn .btn-primary type=submit onclick="$('#workingmodal').modal('show');">
Use this account
+ <a .btn href="@{DisconnectXMPPR}">
+ Stop using this account
<div .modal .fade #workingmodal>
<div .modal-header>
<h3>
diff --git a/templates/repolist.hamlet b/templates/repolist.hamlet
index 0dc92ed..afc71cd 100644
--- a/templates/repolist.hamlet
+++ b/templates/repolist.hamlet
@@ -11,7 +11,7 @@
Repositories
<table .table .table-condensed>
<tbody #costsortable>
- $forall (name, repoid, actions) <- repolist
+ $forall (name, repoid, currentlyconnected, actions) <- repolist
<tr .repoline ##{show repoid}>
<td .handle>
<a .btn .btn-mini .disabled>
@@ -26,10 +26,17 @@
<i .icon-trash></i> cleaning out..
$else
<a href="@{syncToggleLink actions}">
+ $if currentlyconnected
+ <i .icon-signal></i> #
+ $else
+ $if notSyncing actions
+ <i .icon-ban-circle></i> #
+ $else
+ <i .icon-refresh></i> #
$if notSyncing actions
- <i .icon-ban-circle></i> syncing disabled
+ syncing disabled
$else
- <i .icon-refresh></i> syncing enabled #
+ syncing enabled #
$if lacksUUID repoid
(metadata only)
<td .draghide>