Merge branch 'master' into bootstrap3

Conflicts:
	debian/changelog

Assistant/CredPairCache.hs

@@ -0,0 +1,53 @@
+{- git-annex assistant CredPair cache.
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE BangPatterns #-}
+
+module Assistant.CredPairCache (
+	cacheCred,
+	getCachedCred,
+	expireCachedCred,
+) where
+
+import Assistant.Types.CredPairCache
+import Types.Creds
+import Assistant.Common
+import Utility.ThreadScheduler
+
+import qualified Data.Map as M
+import Control.Concurrent
+
+{- Caches a CredPair, but only for a limited time, after which it
+ - will expire.
+ -
+ - Note that repeatedly caching the same CredPair
+ - does not reset its expiry time.
+ -}
+cacheCred :: CredPair -> Seconds -> Assistant ()
+cacheCred (login, password) expireafter = do
+	cache <- getAssistant credPairCache
+	liftIO $ do
+		changeStrict cache $ M.insert login password
+		void $ forkIO $ do
+			threadDelaySeconds expireafter
+			changeStrict cache $ M.delete login
+
+getCachedCred :: Login -> Assistant (Maybe Password)
+getCachedCred login = do
+	cache <- getAssistant credPairCache
+	liftIO $ M.lookup login <$> readMVar cache
+
+expireCachedCred :: Login -> Assistant ()
+expireCachedCred login = do
+	cache <- getAssistant credPairCache
+	liftIO $ changeStrict cache $ M.delete login
+
+{- Update map strictly to avoid keeping references to old creds in memory. -}
+changeStrict :: CredPairCache -> (M.Map Login Password -> M.Map Login Password) -> IO ()
+changeStrict cache a = modifyMVar_ cache $ \m -> do
+	let !m' = a m
+	return m'

Assistant/Monad.hs

@@ -44,6 +44,7 @@ import Assistant.Types.Buddies
 import Assistant.Types.NetMessager
 import Assistant.Types.ThreadName
 import Assistant.Types.RemoteControl
+import Assistant.Types.CredPairCache
 
 newtype Assistant a = Assistant { mkAssistant :: ReaderT AssistantData IO a }
 	deriving (
@@ -70,6 +71,7 @@ data AssistantData = AssistantData
 	, buddyList :: BuddyList
 	, netMessager :: NetMessager
 	, remoteControl :: RemoteControl
+	, credPairCache :: CredPairCache
 	}
 
 newAssistantData :: ThreadState -> DaemonStatusHandle -> IO AssistantData
@@ -89,6 +91,7 @@ newAssistantData st dstatus = AssistantData
 	<*> newBuddyList
 	<*> newNetMessager
 	<*> newRemoteControl
+	<*> newCredPairCache
 
 runAssistant :: AssistantData -> Assistant a -> IO a
 runAssistant d a = runReaderT (mkAssistant a) d

Assistant/Threads/MountWatcher.hs

@@ -63,7 +63,11 @@ dbusThread urlrenderer = do
 				wasmounted <- liftIO $ swapMVar mvar nowmounted
 				handleMounts urlrenderer wasmounted nowmounted
 			liftIO $ forM_ mountChanged $ \matcher ->
+#if MIN_VERSION_dbus(0,10,7)
+				void $ addMatch client matcher handleevent
+#else
 				listen client matcher handleevent
+#endif
 		, do
 			liftAnnex $
 				warning "No known volume monitor available through dbus; falling back to mtab polling"

Assistant/Threads/NetWatcher.hs

@@ -112,8 +112,13 @@ checkNetMonitor client = do
  -}
 listenNMConnections :: Client -> (Bool -> IO ()) -> IO ()
 listenNMConnections client setconnected =
-	listen client matcher $ \event -> mapM_ handle
-		(map dictionaryItems $ mapMaybe fromVariant $ signalBody event)
+#if MIN_VERSION_dbus(0,10,7)
+	void $ addMatch client matcher
+#else
+	listen client matcher
+#endif
+		$ \event -> mapM_ handle
+			(map dictionaryItems $ mapMaybe fromVariant $ signalBody event)
   where
 	matcher = matchAny
 		{ matchInterface = Just "org.freedesktop.NetworkManager"
@@ -142,10 +147,10 @@ listenNMConnections client setconnected =
  -}
 listenWicdConnections :: Client -> (Bool -> IO ()) -> IO ()
 listenWicdConnections client setconnected = do
-	listen client connmatcher $ \event ->
+	match connmatcher $ \event ->
 		when (any (== wicd_success) (signalBody event)) $
 			setconnected True
-	listen client statusmatcher $ \event -> handle (signalBody event)
+	match statusmatcher $ \event -> handle (signalBody event)
   where
 	connmatcher = matchAny
 		{ matchInterface = Just "org.wicd.daemon"
@@ -160,7 +165,12 @@ listenWicdConnections client setconnected = do
 	handle status
 		| any (== wicd_disconnected) status = setconnected False
 		| otherwise = noop
-
+	match matcher a = 
+#if MIN_VERSION_dbus(0,10,7)
+		void $ addMatch client matcher a
+#else
+		listen client matcher a
+#endif
 #endif
 
 handleConnection :: Assistant ()

Assistant/Threads/SanityChecker.hs

@@ -46,6 +46,7 @@ import Assistant.WebApp.Types
 #ifndef mingw32_HOST_OS
 import Utility.LogFile
 #endif
+import Types.Key (keyBackendName)
 
 import Data.Time.Clock.POSIX
 import qualified Data.Text as T
@@ -82,6 +83,10 @@ sanityCheckerStartupThread startupdelay = namedThreadUnchecked "SanityCheckerSta
 	{- Fix up ssh remotes set up by past versions of the assistant. -}
 	liftIO $ fixUpSshRemotes
 
+	{- Clean up old temp files. -}
+	liftAnnex cleanOldTmpMisc
+	liftAnnex cleanReallyOldTmp
+
 	{- If there's a startup delay, it's done here. -}
 	liftIO $ maybe noop (threadDelaySeconds . Seconds . fromIntegral . durationSeconds) startupdelay
 
@@ -258,3 +263,54 @@ checkOldUnused urlrenderer = go =<< annexExpireUnused <$> liftAnnex Annex.getGit
 #else
 		debug [show $ renderTense Past msg]
 #endif
+
+{- Files may be left in misctmp by eg, an interrupted add of files
+ - by the assistant, which hard links files to there as part of lockdown
+ - checks. Delete these files if they're more than a day old.
+ -
+ - Note that this is not safe to run after the Watcher starts up, since it
+ - will create such files, and due to hard linking they may have old
+ - mtimes. So, this should only be called from the
+ - sanityCheckerStartupThread, which runs before the Watcher starts up.
+ -
+ - Also, if a git-annex add is being run at the same time the assistant
+ - starts up, its tmp files could be deleted. However, the watcher will
+ - come along and add everything once it starts up anyway, so at worst
+ - this would make the git-annex add fail unexpectedly.
+ -}
+cleanOldTmpMisc :: Annex ()
+cleanOldTmpMisc = do
+	now <- liftIO getPOSIXTime
+	let oldenough = now - (60 * 60 * 24)
+	tmp <- fromRepo gitAnnexTmpMiscDir
+	liftIO $ mapM_ (cleanOld (<= oldenough)) =<< dirContentsRecursive tmp
+
+{- While .git/annex/tmp is now only used for storing partially transferred
+ - objects, older versions of git-annex used it for misctemp. Clean up any
+ - files that might be left from that, by looking for files whose names
+ - cannot be the key of an annexed object. Only delete files older than
+ - 1 week old.
+ -
+ - Also, some remotes such as rsync may use this temp directory for storing
+ - eg, encrypted objects that are being transferred. So, delete old
+ - objects that use a GPGHMAC backend.
+ -}
+cleanReallyOldTmp :: Annex ()
+cleanReallyOldTmp = do
+	now <- liftIO getPOSIXTime
+	let oldenough = now - (60 * 60 * 24 * 7)
+	tmp <- fromRepo gitAnnexTmpObjectDir
+	liftIO $ mapM_ (cleanjunk (<= oldenough)) =<< dirContentsRecursive tmp
+  where
+	cleanjunk check f = case fileKey (takeFileName f) of
+		Nothing -> cleanOld check f
+		Just k
+			| "GPGHMAC" `isPrefixOf` keyBackendName k ->
+				cleanOld check f
+			| otherwise -> noop
+
+cleanOld :: (POSIXTime -> Bool) -> FilePath -> IO ()
+cleanOld check f = do
+	mtime <- realToFrac . modificationTime <$> getFileStatus f
+	when (check mtime) $
+		nukeFile f

Assistant/Threads/Upgrader.hs

@@ -18,11 +18,8 @@ import Assistant.Types.UrlRenderer
 import Assistant.DaemonStatus
 import Assistant.Alert
 import Utility.NotificationBroadcaster
-import Utility.Tmp
 import qualified Annex
 import qualified Build.SysConfig
-import qualified Utility.Url as Url
-import qualified Annex.Url as Url
 import qualified Git.Version
 import Types.Distribution
 #ifdef WITH_WEBAPP
@@ -62,7 +59,7 @@ upgraderThread urlrenderer = namedThread "Upgrader" $
 checkUpgrade :: UrlRenderer -> Assistant ()
 checkUpgrade urlrenderer = do
 	debug [ "Checking if an upgrade is available." ]
-	go =<< getDistributionInfo
+	go =<< downloadDistributionInfo
   where
 	go Nothing = debug [ "Failed to check if upgrade is available." ]
 	go (Just d) = do
@@ -86,16 +83,3 @@ canUpgrade urgency urlrenderer d = ifM autoUpgradeEnabled
 		noop
 #endif
 	)
-
-getDistributionInfo :: Assistant (Maybe GitAnnexDistribution)
-getDistributionInfo = do
-	uo <- liftAnnex Url.getUrlOptions
-	liftIO $ withTmpFile "git-annex.tmp" $ \tmpfile h -> do
-		hClose h
-		ifM (Url.downloadQuiet distributionInfoUrl tmpfile uo)
-			( readish <$> readFileStrict tmpfile
-			, return Nothing
-			)
-
-distributionInfoUrl :: String
-distributionInfoUrl = fromJust Build.SysConfig.upgradelocation ++ ".info"

Assistant/Types/CredPairCache.hs

@@ -0,0 +1,18 @@
+{- git-annex assistant CredPair cache.
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.Types.CredPairCache where
+
+import Types.Creds
+
+import Control.Concurrent
+import qualified Data.Map as M
+
+type CredPairCache = MVar (M.Map Login Password)
+
+newCredPairCache :: IO CredPairCache
+newCredPairCache = newMVar M.empty

Assistant/Upgrade.hs

@@ -32,7 +32,11 @@ import Config.Files
 import Utility.ThreadScheduler
 import Utility.Tmp
 import Utility.UserInfo
+import Utility.Gpg
 import qualified Utility.Lsof as Lsof
+import qualified Build.SysConfig
+import qualified Utility.Url as Url
+import qualified Annex.Url as Url
 
 import qualified Data.Map as M
 import Data.Tuple.Utils
@@ -313,3 +317,48 @@ upgradeSanityCheck = ifM usingDistribution
 
 usingDistribution :: IO Bool
 usingDistribution = isJust <$> getEnv "GIT_ANNEX_STANDLONE_ENV"
+
+downloadDistributionInfo :: Assistant (Maybe GitAnnexDistribution)
+downloadDistributionInfo = do
+	uo <- liftAnnex Url.getUrlOptions
+	liftIO $ withTmpDir "git-annex.tmp" $ \tmpdir -> do
+		let infof = tmpdir </> "info"
+		let sigf = infof ++ ".sig"
+		ifM (Url.downloadQuiet distributionInfoUrl infof uo
+			<&&> Url.downloadQuiet distributionInfoSigUrl sigf uo
+			<&&> verifyDistributionSig sigf)
+			( readish <$> readFileStrict infof
+			, return Nothing
+			)
+
+distributionInfoUrl :: String
+distributionInfoUrl = fromJust Build.SysConfig.upgradelocation ++ ".info"
+
+distributionInfoSigUrl :: String
+distributionInfoSigUrl = distributionInfoUrl ++ ".sig"
+
+{- Verifies that a file from the git-annex distribution has a valid
+ - signature. Pass the detached .sig file; the file to be verified should
+ - be located next to it.
+ -
+ - The gpg keyring used to verify the signature is located in
+ - trustedkeys.gpg, next to the git-annex program.
+ -}
+verifyDistributionSig :: FilePath -> IO Bool
+verifyDistributionSig sig = do
+	p <- readProgramFile
+	if isAbsolute p
+		then withTmpDir "git-annex-gpg.tmp" $ \gpgtmp -> do
+			let trustedkeys = takeDirectory p </> "trustedkeys.gpg"
+			boolSystem gpgcmd
+				[ Param "--no-default-keyring"
+				, Param "--no-auto-check-trustdb"
+				, Param "--no-options"
+				, Param "--homedir"
+				, File gpgtmp
+				, Param "--keyring"
+				, File trustedkeys
+				, Param "--verify"
+				, File sig
+				]
+		else return False