packages feed

git-annex 4.20130323 → 4.20130405

raw patch · 237 files changed

+2824/−1102 lines, 237 filesbinary-added

Files

Annex.hs view
@@ -28,6 +28,7 @@ 	gitRepo, 	inRepo, 	fromRepo,+	calcRepo, 	getGitConfig, 	changeGitConfig, 	changeGitRepo,@@ -202,6 +203,11 @@ {- Extracts a value from the annex's git repisitory. -} fromRepo :: (Git.Repo -> a) -> Annex a fromRepo a = a <$> gitRepo++calcRepo :: (Git.Repo -> GitConfig -> IO a) -> Annex a+calcRepo a = do+	s <- getState id+	liftIO $ a (repo s) (gitconfig s)  {- Gets the GitConfig settings. -} getGitConfig :: Annex GitConfig
Annex/Branch.hs view
@@ -189,7 +189,7 @@  {- Records new content of a file into the journal -} set :: FilePath -> String -> Annex ()-set file content = setJournalFile file content+set = setJournalFile  {- Stages the journal, and commits staged changes to the branch. -} commit :: String -> Annex ()@@ -197,7 +197,7 @@ 	cleanjournal <- stageJournal 	ref <- getBranch 	withIndex $ commitBranch ref message [fullname]-	liftIO $ cleanjournal+	liftIO cleanjournal  {- Commits the staged changes in the index to the branch.  - @@ -355,7 +355,7 @@ 		Git.UpdateIndex.streamUpdateIndex g 			[genstream dir h fs] 		hashObjectStop h-	return $ liftIO $ mapM_ removeFile $ map (dir </>) fs+	return $ liftIO $ mapM_ (removeFile . (dir </>)) fs   where 	genstream dir h fs streamer = forM_ fs $ \file -> do 		let path = dir </> file
Annex/Content.hs view
@@ -9,7 +9,6 @@ 	inAnnex, 	inAnnexSafe, 	lockContent,-	calcGitLink, 	getViaTmp, 	getViaTmpChecked, 	getViaTmpUnchecked,@@ -49,8 +48,8 @@ import Annex.Exception import Git.SharedRepository import Annex.Perms+import Annex.Link import Annex.Content.Direct-import Backend  {- Checks if a given key's content is currently present. -} inAnnex :: Key -> Annex Bool@@ -101,7 +100,7 @@  - it. (If the content is not present, no locking is done.) -} lockContent :: Key -> Annex a -> Annex a lockContent key a = do-	file <- inRepo $ gitAnnexLocation key+	file <- calcRepo $ gitAnnexLocation key 	bracketIO (openforlock file >>= lock) unlock a   where 	{- Since files are stored with the write bit disabled, have@@ -123,16 +122,6 @@ 	unlock Nothing = noop 	unlock (Just l) = closeFd l -{- Calculates the relative path to use to link a file to a key. -}-calcGitLink :: FilePath -> Key -> Annex FilePath-calcGitLink file key = do-	cwd <- liftIO getCurrentDirectory-	let absfile = fromMaybe whoops $ absNormPath cwd file-	loc <- inRepo $ gitAnnexLocation key-	return $ relPathDirToFile (parentDir absfile) loc-  where-	whoops = error $ "unable to normalize " ++ file- {- Runs an action, passing it a temporary filename to get,  - and if the action succeeds, moves the temp file into   - the annex as a key's content. -}@@ -251,25 +240,38 @@ 	storedirect fs = storedirect' =<< filterM validsymlink fs 	validsymlink f = (==) (Just key) <$> isAnnexLink f -	storedirect' [] = storeobject =<< inRepo (gitAnnexLocation key)+	storedirect' [] = storeobject =<< calcRepo (gitAnnexLocation key) 	storedirect' (dest:fs) = do 		updateInodeCache key src 		thawContent src 		replaceFile dest $ liftIO . moveFile src+		{- Copy to any other locations. -} 		forM_ fs $ \f -> replaceFile f $-			void . liftIO . copyFileExternal dest+			liftIO . void . copyFileExternal dest -{- Replaces any existing file with a new version, by running an action.- - First, makes sure the file is deleted. Or, if it didn't already exist,- - makes sure the parent directory exists. -}+{- Replaces a possibly already existing file with a new version, + - atomically, by running an action.++ - The action is passed a temp file, which it can write to, and once+ - done the temp file is moved into place.+ -} replaceFile :: FilePath -> (FilePath -> Annex ()) -> Annex () replaceFile file a = do+	tmpdir <- fromRepo gitAnnexTmpDir+	createAnnexDirectory tmpdir+	tmpfile <- liftIO $ do+		(tmpfile, h) <- openTempFileWithDefaultPermissions tmpdir $+			takeFileName file+		hClose h+		return tmpfile+	a tmpfile 	liftIO $ do-		r <- tryIO $ removeFile file+		r <- tryIO $ rename tmpfile file 		case r of-			Left _ -> createDirectoryIfMissing True $ parentDir file+			Left _ -> do+				createDirectoryIfMissing True $ parentDir file+				rename tmpfile file 			_ -> noop-	a file  {- Runs an action to transfer an object's content.  -@@ -307,7 +309,6 @@ 	direct [] = return Nothing 	direct (f:fs) = do 		cache <- recordedInodeCache key-		liftIO $ print ("prepSendAnnex pre cache", cache) 		-- check that we have a good file 		ifM (sameInodeCache f cache) 			( return $ Just (f, sameInodeCache f cache)@@ -329,11 +330,11 @@ 	, goindirect 	)   where-	goindirect = indirect =<< inRepo (gitAnnexLocation key)+	goindirect = indirect =<< calcRepo (gitAnnexLocation key)  cleanObjectLoc :: Key -> Annex () cleanObjectLoc key = do-	file <- inRepo $ gitAnnexLocation key+	file <- calcRepo $ gitAnnexLocation key 	unlessM crippledFileSystem $ 		void $ liftIO $ catchMaybeIO $ allowWrite $ parentDir file 	liftIO $ removeparents file (3 :: Int)@@ -362,18 +363,17 @@ 		removeInodeCache key 		mapM_ (resetfile cache) fs 	resetfile cache f = whenM (sameInodeCache f cache) $ do-		l <- calcGitLink f key+		l <- inRepo $ gitAnnexLink f key 		top <- fromRepo Git.repoPath 		cwd <- liftIO getCurrentDirectory 		let top' = fromMaybe top $ absNormPath cwd top 		let l' = relPathDirToFile top' (fromMaybe l $ absNormPath top' l)-		replaceFile f $ const $-			makeAnnexLink l' f+		replaceFile f $ makeAnnexLink l'  {- Moves a key's file out of .git/annex/objects/ -} fromAnnex :: Key -> FilePath -> Annex () fromAnnex key dest = do-	file <- inRepo $ gitAnnexLocation key+	file <- calcRepo $ gitAnnexLocation key 	unlessM crippledFileSystem $ 		liftIO $ allowWrite $ parentDir file 	thawContent file@@ -384,7 +384,7 @@  - returns the file it was moved to. -} moveBad :: Key -> Annex FilePath moveBad key = do-	src <- inRepo $ gitAnnexLocation key+	src <- calcRepo $ gitAnnexLocation key 	bad <- fromRepo gitAnnexBadDir 	let dest = bad </> takeFileName src 	createAnnexDirectory (parentDir dest)@@ -457,7 +457,7 @@ 	copy = ifM (liftIO $ doesFileExist file) 		( return True 		, do-			s <- inRepo $ gitAnnexLocation key+			s <- calcRepo $ gitAnnexLocation key 			liftIO $ copyFileExternal s file 		)
Annex/Content/Direct.hs view
@@ -42,7 +42,7 @@  - the top of the repo. -} associatedFilesRelative :: Key -> Annex [FilePath]  associatedFilesRelative key = do-	mapping <- inRepo $ gitAnnexMapping key+	mapping <- calcRepo $ gitAnnexMapping key 	liftIO $ catchDefaultIO [] $ do 		h <- openFile mapping ReadMode 		fileEncoding h@@ -52,7 +52,7 @@  - transformation to the list. Returns new associatedFiles value. -} changeAssociatedFiles :: Key -> ([FilePath] -> [FilePath]) -> Annex [FilePath] changeAssociatedFiles key transform = do-	mapping <- inRepo $ gitAnnexMapping key+	mapping <- calcRepo $ gitAnnexMapping key 	files <- associatedFilesRelative key 	let files' = transform files 	when (files /= files') $ do@@ -124,7 +124,7 @@ 	liftIO $ nukeFile f  withInodeCacheFile :: Key -> (FilePath -> Annex a) -> Annex a-withInodeCacheFile key a = a =<< inRepo (gitAnnexInodeCache key)+withInodeCacheFile key a = a =<< calcRepo (gitAnnexInodeCache key)  {- Checks if a InodeCache matches the current version of a file. -} sameInodeCache :: FilePath -> Maybe InodeCache -> Annex Bool@@ -139,11 +139,10 @@ sameFileStatus key status = do 	old <- recordedInodeCache key 	let curr = toInodeCache status-	r <- case (old, curr) of+	case (old, curr) of 		(Just o, Just c) -> compareInodeCaches o c 		(Nothing, Nothing) -> return True 		_ -> return False-	return r  {- If the inodes have changed, only the size and mtime are compared. -} compareInodeCaches :: InodeCache -> InodeCache -> Annex Bool
Annex/Direct.hs view
@@ -89,7 +89,8 @@ 		return False 	got (Just (key, _)) = ifM (sameInodeCache file $ Just cache) 		( do-			stageSymlink file =<< hashSymlink =<< calcGitLink file key+			l <- inRepo $ gitAnnexLink file key+			stageSymlink file =<< hashSymlink l 			writeInodeCache key cache 			void $ addAssociatedFile key file 			logStatus key InfoPresent@@ -122,7 +123,7 @@ mergeDirectCleanup d oldsha newsha = do 	(items, cleanup) <- inRepo $ DiffTree.diffTreeRecursive oldsha newsha 	forM_ items updated-	void $ liftIO $ cleanup+	void $ liftIO cleanup 	liftIO $ removeDirectoryRecursive d   where 	updated item = do@@ -152,9 +153,8 @@ 	 -  	 - Symlinks are replaced with their content, if it's available. -} 	movein k f = do-		l <- calcGitLink f k-		replaceFile f $-			makeAnnexLink l+		l <- inRepo $ gitAnnexLink f k+		replaceFile f $ makeAnnexLink l 		toDirect k f 	 	{- Any new, modified, or renamed files were written to the temp@@ -170,7 +170,7 @@  toDirectGen :: Key -> FilePath -> Annex (Maybe (Annex ())) toDirectGen k f = do-	loc <- inRepo $ gitAnnexLocation k+	loc <- calcRepo $ gitAnnexLocation k 	absf <- liftIO $ absPath f 	locs <- filter (/= absf) <$> addAssociatedFile k f 	case locs of@@ -179,15 +179,14 @@ 				{- Move content from annex to direct file. -} 				updateInodeCache k loc 				thawContent loc-				replaceFile f $-					liftIO . moveFile loc+				replaceFile f $ liftIO . moveFile loc 			, return Nothing 			) 		(loc':_) -> ifM (isNothing <$> getAnnexLinkTarget loc') 			{- Another direct file has the content; copy it. -} 			( return $ Just $ 				replaceFile f $-					void . liftIO . copyFileExternal loc'+					liftIO . void . copyFileExternal loc' 			, return Nothing 			)
+ Annex/FileMatcher.hs view
@@ -0,0 +1,86 @@+{- git-annex file matching+ -+ - Copyright 2012, 2013 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Annex.FileMatcher where++import qualified Data.Map as M++import Common.Annex+import Limit+import Utility.Matcher+import Types.Group+import Logs.Group+import Annex.UUID+import qualified Annex+import Git.FilePath++import Data.Either+import qualified Data.Set as S++type FileMatcher = Matcher MatchFiles++checkFileMatcher :: FileMatcher -> FilePath -> Annex Bool+checkFileMatcher matcher file = checkFileMatcher' matcher file S.empty True++checkFileMatcher' :: FileMatcher -> FilePath -> AssumeNotPresent -> Bool -> Annex Bool+checkFileMatcher' matcher file notpresent def+	| isEmpty matcher = return def+	| otherwise = do+		matchfile <- getTopFilePath <$> inRepo (toTopFilePath file)+		let fi = Annex.FileInfo+			{ Annex.matchFile = matchfile+			, Annex.relFile = file+			}+		matchMrun matcher $ \a -> a notpresent fi++matchAll :: FileMatcher+matchAll = generate []++parsedToMatcher :: [Either String (Token MatchFiles)] -> Either String FileMatcher+parsedToMatcher parsed = case partitionEithers parsed of+	([], vs) -> Right $ generate vs+	(es, _) -> Left $ unwords $ map ("Parse failure: " ++) es++parseToken :: MkLimit -> GroupMap -> String -> Either String (Token MatchFiles)+parseToken checkpresent groupmap t+	| t `elem` tokens = Right $ token t+	| t == "present" = use checkpresent+	| otherwise = maybe (Left $ "near " ++ show t) use $ M.lookup k $+		M.fromList+			[ ("include", limitInclude)+			, ("exclude", limitExclude)+			, ("copies", limitCopies)+			, ("inbackend", limitInBackend)+			, ("largerthan", limitSize (>))+			, ("smallerthan", limitSize (<))+			, ("inallgroup", limitInAllGroup groupmap)+			]+  where+	(k, v) = separate (== '=') t+	use a = Operation <$> a v++{- This is really dumb tokenization; there's no support for quoted values.+ - Open and close parens are always treated as standalone tokens;+ - otherwise tokens must be separated by whitespace. -}+tokenizeMatcher :: String -> [String]+tokenizeMatcher = filter (not . null ) . concatMap splitparens . words+  where+	splitparens = segmentDelim (`elem` "()")++{- Generates a matcher for files large enough (or meeting other criteria)+ - to be added to the annex, rather than directly to git. -}+largeFilesMatcher :: Annex FileMatcher+largeFilesMatcher = go =<< annexLargeFiles <$> Annex.getGitConfig+  where+  	go Nothing = return matchAll+	go (Just expr) = do+		m <- groupMap+		u <- getUUID+		either badexpr return $ parsedToMatcher $+			map (parseToken (limitPresent $ Just u) m)+				(tokenizeMatcher expr)+	badexpr e = error $ "bad annex.largefiles configuration: " ++ e
Annex/Link.hs view
@@ -60,7 +60,9 @@  -} makeAnnexLink :: LinkTarget -> FilePath -> Annex () makeAnnexLink linktarget file = ifM (coreSymlinks <$> Annex.getGitConfig)-	( liftIO $ createSymbolicLink linktarget file+	( liftIO $ do+		void $ tryIO $ removeFile file+		createSymbolicLink linktarget file 	, liftIO $ writeFile file linktarget 	)
Annex/Ssh.hs view
@@ -79,7 +79,7 @@ 	gettmpdir = liftIO $ getEnv "GIT_ANNEX_TMP_DIR" 	usetmpdir tmpdir = liftIO $ catchMaybeIO $ do 		createDirectoryIfMissing True tmpdir-		return $ tmpdir+		return tmpdir  portParams :: Maybe Integer -> [CommandParam] portParams Nothing = []
Assistant.hs view
@@ -152,6 +152,7 @@ #endif #else #warning Building without the webapp. You probably need to install Yesod..+import Assistant.Types.UrlRenderer #endif import Assistant.Environment import qualified Utility.Daemon@@ -159,6 +160,8 @@ import Utility.ThreadScheduler import qualified Build.SysConfig as SysConfig +import System.Log.Logger+ stopDaemon :: Annex () stopDaemon = liftIO . Utility.Daemon.stopDaemon =<< fromRepo gitAnnexPidFile @@ -170,9 +173,11 @@ startDaemon :: Bool -> Bool -> Maybe (Maybe Handle -> Maybe Handle -> String -> FilePath -> IO ()) -> Annex () startDaemon assistant foreground startbrowser = do 	pidfile <- fromRepo gitAnnexPidFile-	logfd <- liftIO . openLog =<< fromRepo gitAnnexLogFile+	logfile <- fromRepo gitAnnexLogFile+	logfd <- liftIO $ openLog logfile 	if foreground 		then do+			liftIO $ debugM desc $ "logging to " ++ logfile 			liftIO $ Utility.Daemon.lockPidFile pidfile 			origout <- liftIO $ catchMaybeIO $  				fdToHandle =<< dup stdOutput@@ -192,21 +197,25 @@ 		| otherwise = "watch" 	start daemonize webappwaiter = withThreadState $ \st -> do 		checkCanWatch-		when assistant $ checkEnvironment+		when assistant+			checkEnvironment 		dstatus <- startDaemonStatus+		logfile <- fromRepo gitAnnexLogFile+		liftIO $ debugM desc $ "logging to " ++ logfile 		liftIO $ daemonize $ 			flip runAssistant (go webappwaiter)  				=<< newAssistantData st dstatus -	go webappwaiter = do-		notice ["starting", desc, "version", SysConfig.packageversion]+ #ifdef WITH_WEBAPP+	go webappwaiter = do 		d <- getAssistant id-		urlrenderer <- liftIO newUrlRenderer-		mapM_ (startthread $ Just urlrenderer) #else-		mapM_ (startthread Nothing)+	go _webappwaiter = do #endif+		notice ["starting", desc, "version", SysConfig.packageversion]+		urlrenderer <- liftIO newUrlRenderer+		mapM_ (startthread urlrenderer) 			[ watch $ commitThread #ifdef WITH_WEBAPP 			, assist $ webAppThread d urlrenderer False Nothing webappwaiter@@ -231,7 +240,7 @@ #endif 			, assist $ netWatcherThread 			, assist $ netWatcherFallbackThread-			, assist $ transferScannerThread+			, assist $ transferScannerThread urlrenderer 			, assist $ configMonitorThread 			, assist $ glacierThread 			, watch $ watchThread
Assistant/Alert.hs view
@@ -1,197 +1,45 @@ {- git-annex assistant alerts  -- - Copyright 2012 Joey Hess <joey@kitenet.net>+ - Copyright 2012, 2013 Joey Hess <joey@kitenet.net>  -  - Licensed under the GNU GPL version 3 or higher.  -} -{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings, CPP #-}  module Assistant.Alert where  import Common.Annex+import Assistant.Types.Alert+import Assistant.Alert.Utility import qualified Remote import Utility.Tense import Logs.Transfer -import qualified Data.Text as T-import Data.Text (Text)-import qualified Data.Map as M import Data.String--{- Different classes of alerts are displayed differently. -}-data AlertClass = Success | Message | Activity | Warning | Error-	deriving (Eq, Ord)--data AlertPriority = Filler | Low | Medium | High | Pinned-	deriving (Eq, Ord)--{- An alert can have an name, which is used to combine it with other similar- - alerts. -}-data AlertName -	= FileAlert TenseChunk-	| SanityCheckFixAlert-	| WarningAlert String-	| PairAlert String-	| XMPPNeededAlert-	| CloudRepoNeededAlert-	| SyncAlert-	deriving (Eq)--{- The first alert is the new alert, the second is an old alert.- - Should return a modified version of the old alert. -}-type AlertCombiner = Alert -> Alert -> Maybe Alert--data Alert = Alert-	{ alertClass :: AlertClass-	, alertHeader :: Maybe TenseText-	, alertMessageRender :: [TenseChunk] -> TenseText-	, alertData :: [TenseChunk]-	, alertBlockDisplay :: Bool-	, alertClosable :: Bool-	, alertPriority :: AlertPriority-	, alertIcon :: Maybe AlertIcon-	, alertCombiner :: Maybe AlertCombiner-	, alertName :: Maybe AlertName-	, alertButton :: Maybe AlertButton-	}--data AlertIcon = ActivityIcon | SuccessIcon | ErrorIcon | InfoIcon | TheCloud--{- When clicked, a button always redirects to a URL- - It may also run an IO action in the background, which is useful- - to make the button close or otherwise change the alert. -}-data AlertButton = AlertButton-	{ buttonLabel :: Text-	, buttonUrl :: Text-	, buttonAction :: Maybe (AlertId -> IO ())-	}--type AlertPair = (AlertId, Alert)--type AlertMap = M.Map AlertId Alert--{- Higher AlertId indicates a more recent alert. -}-newtype AlertId = AlertId Integer-	deriving (Read, Show, Eq, Ord)--firstAlertId :: AlertId-firstAlertId = AlertId 0--nextAlertId :: AlertId -> AlertId-nextAlertId (AlertId i) = AlertId $ succ i--{- This is as many alerts as it makes sense to display at a time.- - A display might be smaller, or larger, the point is to not overwhelm the- - user with a ton of alerts. -}-displayAlerts :: Int-displayAlerts = 6--{- This is not a hard maximum, but there's no point in keeping a great- - many filler alerts in an AlertMap, so when there's more than this many,- - they start being pruned, down toward displayAlerts. -}-maxAlerts :: Int-maxAlerts = displayAlerts * 2--{- The desired order is the reverse of:- -- - - Pinned alerts- - - High priority alerts, newest first- - - Medium priority Activity, newest first (mostly used for Activity)- - - Low priority alerts, newest first- - - Filler priorty alerts, newest first- - - Ties are broken by the AlertClass, with Errors etc coming first.- -}-compareAlertPairs :: AlertPair -> AlertPair -> Ordering-compareAlertPairs-	(aid, Alert { alertClass = aclass, alertPriority = aprio })-	(bid, Alert { alertClass = bclass, alertPriority = bprio })-	 = compare aprio bprio-		`thenOrd` compare aid bid-			`thenOrd` compare aclass bclass--sortAlertPairs :: [AlertPair] -> [AlertPair]-sortAlertPairs = sortBy compareAlertPairs--{- Renders an alert's header for display, if it has one. -}-renderAlertHeader :: Alert -> Maybe Text-renderAlertHeader alert = renderTense (alertTense alert) <$> alertHeader alert--{- Renders an alert's message for display. -}-renderAlertMessage :: Alert -> Text-renderAlertMessage alert = renderTense (alertTense alert) $-	(alertMessageRender alert) (alertData alert)--showAlert :: Alert -> String-showAlert alert = T.unpack $ T.unwords $ catMaybes-	[ renderAlertHeader alert-	, Just $ renderAlertMessage alert-	]--alertTense :: Alert -> Tense-alertTense alert-	| alertClass alert == Activity = Present-	| otherwise = Past+import qualified Data.Text as T -{- Checks if two alerts display the same. -}-effectivelySameAlert :: Alert -> Alert -> Bool-effectivelySameAlert x y = all id -	[ alertClass x == alertClass y-	, alertHeader x == alertHeader y-	, alertData x == alertData y-	, alertBlockDisplay x == alertBlockDisplay y-	, alertClosable x == alertClosable y-	, alertPriority x == alertPriority y-	]+#ifdef WITH_WEBAPP+import Assistant.Monad+import Assistant.DaemonStatus+import Assistant.WebApp.Types+import Assistant.WebApp+import Yesod+#endif -makeAlertFiller :: Bool -> Alert -> Alert-makeAlertFiller success alert-	| isFiller alert = alert-	| otherwise = alert-		{ alertClass = if c == Activity then c' else c-		, alertPriority = Filler-		, alertClosable = True-		, alertButton = Nothing-		, alertIcon = Just $ if success then SuccessIcon else ErrorIcon+{- Makes a button for an alert that opens a Route. The button will+ - close the alert it's attached to when clicked. -}+#ifdef WITH_WEBAPP+mkAlertButton :: T.Text -> UrlRenderer -> Route WebApp -> Assistant AlertButton+mkAlertButton label urlrenderer route = do+	close <- asIO1 removeAlert+	url <- liftIO $ renderUrl urlrenderer route []+	return $ AlertButton+		{ buttonLabel = label+		, buttonUrl = url+		, buttonAction = Just close 		}-  where-	c = alertClass alert-	c'-		| success = Success-		| otherwise = Error--isFiller :: Alert -> Bool-isFiller alert = alertPriority alert == Filler--{- Updates the Alertmap, adding or updating an alert.- -- - Any old filler that looks the same as the alert is removed.- -- - Or, if the alert has an alertCombiner that combines it with- - an old alert, the old alert is replaced with the result, and the- - alert is removed.- -- - Old filler alerts are pruned once maxAlerts is reached.- -}-mergeAlert :: AlertId -> Alert -> AlertMap -> AlertMap-mergeAlert i al m = maybe updatePrune updateCombine (alertCombiner al)-  where-	pruneSame k al' = k == i || not (effectivelySameAlert al al')-	pruneBloat m'-		| bloat > 0 = M.fromList $ pruneold $ M.toList m'-		| otherwise = m'-	  where-		bloat = M.size m' - maxAlerts-		pruneold l =-	 		let (f, rest) = partition (\(_, a) -> isFiller a) l-			in drop bloat f ++ rest-	updatePrune = pruneBloat $ M.filterWithKey pruneSame $-		M.insertWith' const i al m-	updateCombine combiner = -		let combined = M.mapMaybe (combiner al) m-		in if M.null combined-			then updatePrune-			else M.delete i $ M.union combined m+#endif  baseActivityAlert :: Alert baseActivityAlert = Alert@@ -347,6 +195,23 @@ 	, alertMessageRender = tenseWords 	, alertBlockDisplay = True 	, alertName = Just $ CloudRepoNeededAlert+	, alertCombiner = Just $ dataCombiner $ \_old new -> new+	, alertData = []+	}++remoteRemovalAlert :: String -> AlertButton -> Alert+remoteRemovalAlert desc button = Alert+	{ alertHeader = Just $ fromString $+		"The repository \"" ++ desc ++ +		"\" has been emptied, and can now be removed."+	, alertIcon = Just InfoIcon+	, alertPriority = High+	, alertButton = Just button+	, alertClosable = True+	, alertClass = Message+	, alertMessageRender = tenseWords+	, alertBlockDisplay = True+	, alertName = Just $ RemoteRemovalAlert desc 	, alertCombiner = Just $ dataCombiner $ \_old new -> new 	, alertData = [] 	}
+ Assistant/Alert/Utility.hs view
@@ -0,0 +1,130 @@+{- git-annex assistant alert utilities+ -+ - Copyright 2012, 2013 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Assistant.Alert.Utility where++import Common.Annex+import Assistant.Types.Alert+import Utility.Tense++import qualified Data.Text as T+import Data.Text (Text)+import qualified Data.Map as M++{- This is as many alerts as it makes sense to display at a time.+ - A display might be smaller, or larger, the point is to not overwhelm the+ - user with a ton of alerts. -}+displayAlerts :: Int+displayAlerts = 6++{- This is not a hard maximum, but there's no point in keeping a great+ - many filler alerts in an AlertMap, so when there's more than this many,+ - they start being pruned, down toward displayAlerts. -}+maxAlerts :: Int+maxAlerts = displayAlerts * 2++type AlertPair = (AlertId, Alert)++{- The desired order is the reverse of:+ -+ - - Pinned alerts+ - - High priority alerts, newest first+ - - Medium priority Activity, newest first (mostly used for Activity)+ - - Low priority alerts, newest first+ - - Filler priorty alerts, newest first+ - - Ties are broken by the AlertClass, with Errors etc coming first.+ -}+compareAlertPairs :: AlertPair -> AlertPair -> Ordering+compareAlertPairs+	(aid, Alert { alertClass = aclass, alertPriority = aprio })+	(bid, Alert { alertClass = bclass, alertPriority = bprio })+	 = compare aprio bprio+		`thenOrd` compare aid bid+			`thenOrd` compare aclass bclass++sortAlertPairs :: [AlertPair] -> [AlertPair]+sortAlertPairs = sortBy compareAlertPairs++{- Renders an alert's header for display, if it has one. -}+renderAlertHeader :: Alert -> Maybe Text+renderAlertHeader alert = renderTense (alertTense alert) <$> alertHeader alert++{- Renders an alert's message for display. -}+renderAlertMessage :: Alert -> Text+renderAlertMessage alert = renderTense (alertTense alert) $+	(alertMessageRender alert) (alertData alert)++showAlert :: Alert -> String+showAlert alert = T.unpack $ T.unwords $ catMaybes+	[ renderAlertHeader alert+	, Just $ renderAlertMessage alert+	]++alertTense :: Alert -> Tense+alertTense alert+	| alertClass alert == Activity = Present+	| otherwise = Past++{- Checks if two alerts display the same. -}+effectivelySameAlert :: Alert -> Alert -> Bool+effectivelySameAlert x y = all id +	[ alertClass x == alertClass y+	, alertHeader x == alertHeader y+	, alertData x == alertData y+	, alertBlockDisplay x == alertBlockDisplay y+	, alertClosable x == alertClosable y+	, alertPriority x == alertPriority y+	]++makeAlertFiller :: Bool -> Alert -> Alert+makeAlertFiller success alert+	| isFiller alert = alert+	| otherwise = alert+		{ alertClass = if c == Activity then c' else c+		, alertPriority = Filler+		, alertClosable = True+		, alertButton = Nothing+		, alertIcon = Just $ if success then SuccessIcon else ErrorIcon+		}+  where+	c = alertClass alert+	c'+		| success = Success+		| otherwise = Error++isFiller :: Alert -> Bool+isFiller alert = alertPriority alert == Filler++{- Updates the Alertmap, adding or updating an alert.+ -+ - Any old filler that looks the same as the alert is removed.+ -+ - Or, if the alert has an alertCombiner that combines it with+ - an old alert, the old alert is replaced with the result, and the+ - alert is removed.+ -+ - Old filler alerts are pruned once maxAlerts is reached.+ -}+mergeAlert :: AlertId -> Alert -> AlertMap -> AlertMap+mergeAlert i al m = maybe updatePrune updateCombine (alertCombiner al)+  where+	pruneSame k al' = k == i || not (effectivelySameAlert al al')+	pruneBloat m'+		| bloat > 0 = M.fromList $ pruneold $ M.toList m'+		| otherwise = m'+	  where+		bloat = M.size m' - maxAlerts+		pruneold l =+	 		let (f, rest) = partition (\(_, a) -> isFiller a) l+			in drop bloat f ++ rest+	updatePrune = pruneBloat $ M.filterWithKey pruneSame $+		M.insertWith' const i al m+	updateCombine combiner = +		let combined = M.mapMaybe (combiner al) m+		in if M.null combined+			then updatePrune+			else M.delete i $ M.union combined m
Assistant/Common.hs view
@@ -11,3 +11,4 @@ import Assistant.Monad as X import Assistant.Types.DaemonStatus as X import Assistant.Types.NamedThread as X+import Assistant.Types.Alert as X
Assistant/DaemonStatus.hs view
@@ -8,7 +8,7 @@ module Assistant.DaemonStatus where  import Assistant.Common-import Assistant.Alert+import Assistant.Alert.Utility import Utility.TempFile import Assistant.Types.NetMessager import Utility.NotificationBroadcaster@@ -64,7 +64,7 @@   where   	iscloud r = not (Remote.readonly r) && Remote.globallyAvailable r -{- Updates the sycRemotes list from the list of all remotes in Annex state. -}+{- Updates the syncRemotes list from the list of all remotes in Annex state. -} updateSyncRemotes :: Assistant () updateSyncRemotes = do 	modifyDaemonStatus_ =<< liftAnnex calcSyncRemotes@@ -150,6 +150,11 @@ adjustTransfersSTM dstatus a = do 	s <- takeTMVar dstatus 	putTMVar dstatus $ s { currentTransfers = a (currentTransfers s) }++{- Checks if a transfer is currently running. -}+checkRunningTransferSTM :: DaemonStatusHandle -> Transfer -> STM Bool+checkRunningTransferSTM dstatus t = M.member t . currentTransfers+	<$> readTMVar dstatus  {- Alters a transfer's info, if the transfer is in the map. -} alterTransferInfo :: Transfer -> (TransferInfo -> TransferInfo) -> Assistant ()
+ Assistant/DeleteRemote.hs view
@@ -0,0 +1,93 @@+{- git-annex assistant remote deletion utilities+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE CPP #-}++module Assistant.DeleteRemote where++import Assistant.Common+import Assistant.Types.UrlRenderer+import Assistant.TransferQueue+import Logs.Transfer+import Logs.Location+import Assistant.DaemonStatus+import qualified Remote+import Remote.List+import qualified Git.Command+import Logs.Trust+import qualified Annex++#ifdef WITH_WEBAPP+import Assistant.WebApp.Types+import Assistant.Alert+import qualified Data.Text as T+#endif++{- Removes a remote (but leave the repository as-is), and returns the old+ - Remote data. -}+disableRemote :: UUID -> Assistant Remote+disableRemote uuid = do+	remote <- fromMaybe (error "unknown remote")+		<$> liftAnnex (Remote.remoteFromUUID uuid)+	liftAnnex $ do+		inRepo $ Git.Command.run+			[ Param "remote"+			, Param "remove"+			, Param (Remote.name remote)+			]+		void $ remoteListRefresh+	updateSyncRemotes+	return remote++{- Removes a remote, marking it dead .-}+removeRemote :: UUID -> Assistant Remote+removeRemote uuid = do+	liftAnnex $ trustSet uuid DeadTrusted+	disableRemote uuid++{- Called when a Remote is probably empty, to remove it.+ -+ - This does one last check for any objects remaining in the Remote,+ - and if there are any, queues Downloads of them, and defers removing+ - the remote for later. This is to catch any objects not referred to+ - in keys in the current branch.+ -}+removableRemote :: UrlRenderer -> UUID -> Assistant ()+removableRemote urlrenderer uuid = do+	keys <- getkeys+	if null keys+		then finishRemovingRemote urlrenderer uuid+		else do+			r <- fromMaybe (error "unknown remote")+				<$> liftAnnex (Remote.remoteFromUUID uuid)+			mapM_ (queueremaining r) keys+  where+  	queueremaining r k = +		queueTransferWhenSmall "remaining object in unwanted remote"+			Nothing (Transfer Download uuid k) r+	{- Scanning for keys can take a long time; do not tie up+	 - the Annex monad while doing it, so other threads continue to+	 - run. -}+	getkeys = do+		a <- liftAnnex $ Annex.withCurrentState $ loggedKeysFor uuid+		liftIO a++{- With the webapp, this asks the user to click on a button to finish+ - removing the remote.+ -+ - Without the webapp, just do the removal now.+ -}+finishRemovingRemote :: UrlRenderer -> UUID -> Assistant ()+#ifdef WITH_WEBAPP+finishRemovingRemote urlrenderer uuid = do+	desc <- liftAnnex $ Remote.prettyUUID uuid+	button <- mkAlertButton (T.pack "Finish deletion process") urlrenderer $+		FinishDeleteRepositoryR uuid+	void $ addAlert $ remoteRemovalAlert desc button+#else+finishRemovingRemote _ uuid = void $ removeRemote uuid+#endif
Assistant/Drop.hs view
@@ -41,25 +41,39 @@ handleDropsFrom locs rs reason fromhere key (Just f) knownpresentremote 	| fromhere = do 		n <- getcopies-		if checkcopies n+		if checkcopies n Nothing 			then go rs =<< dropl n 			else go rs n 	| otherwise = go rs =<< getcopies   where 	getcopies = liftAnnex $ do-		have <- length <$> trustExclude UnTrusted locs+		(untrusted, have) <- trustPartition UnTrusted locs 		numcopies <- getNumCopies =<< numCopies f-		return (have, numcopies)-	checkcopies (have, numcopies) = have > numcopies-	decrcopies (have, numcopies) = (have - 1, numcopies)+		return (length have, numcopies, S.fromList untrusted) +	{- Check that we have enough copies still to drop the content.+	 - When the remote being dropped from is untrusted, it was not+	 - counted as a copy, so having only numcopies suffices. Otherwise,+	 - we need more than numcopies to safely drop. -}+	checkcopies (have, numcopies, _untrusted) Nothing = have > numcopies+	checkcopies (have, numcopies, untrusted) (Just u)+		| S.member u untrusted = have >= numcopies+		| otherwise = have > numcopies+	+	decrcopies (have, numcopies, untrusted) Nothing =+		(have - 1, numcopies, untrusted)+	decrcopies v@(_have, _numcopies, untrusted) (Just u)+		| S.member u untrusted = v+		| otherwise = decrcopies v Nothing+ 	go [] _ = noop 	go (r:rest) n 		| uuid r `S.notMember` slocs = go rest n-		| checkcopies n = dropr r n >>= go rest+		| checkcopies n (Just $ Remote.uuid r) =+			dropr r n >>= go rest 		| otherwise = noop -	checkdrop n@(have, numcopies) u a =+	checkdrop n@(have, numcopies, _untrusted) u a = 		ifM (liftAnnex $ wantDrop True u (Just f)) 			( ifM (liftAnnex $ safely $ doCommand $ a (Just numcopies)) 				( do@@ -70,7 +84,7 @@ 						, "(copies now " ++ show (have - 1) ++ ")" 						, ": " ++ reason 						]-					return $ decrcopies n+					return $ decrcopies n u 				, return n 				) 			, return n
Assistant/NamedThread.hs view
@@ -13,6 +13,7 @@ import Assistant.Types.NamedThread import Assistant.Types.ThreadName import Assistant.Types.DaemonStatus+import Assistant.Types.UrlRenderer import Assistant.DaemonStatus import Assistant.Monad @@ -22,8 +23,8 @@ import qualified Control.Exception as E  #ifdef WITH_WEBAPP-import Assistant.WebApp import Assistant.WebApp.Types+import Assistant.Types.Alert import Assistant.Alert import qualified Data.Text as T #endif@@ -32,13 +33,8 @@  -  - Named threads are run by a management thread, so if they crash  - an alert is displayed, allowing the thread to be restarted. -}-#ifdef WITH_WEBAPP-startNamedThread :: Maybe UrlRenderer -> NamedThread -> Assistant ()-startNamedThread urlrenderer namedthread@(NamedThread name a) = do-#else-startNamedThread :: Maybe Bool -> NamedThread -> Assistant ()+startNamedThread :: UrlRenderer -> NamedThread -> Assistant () startNamedThread urlrenderer namedthread@(NamedThread name a) = do-#endif 	m <- startedThreads <$> getDaemonStatus 	case M.lookup name m of 		Nothing -> start@@ -69,20 +65,13 @@ 					] 				hPutStrLn stderr msg #ifdef WITH_WEBAPP-				button <- runAssistant d $-					case urlrenderer of-						Nothing -> return Nothing-						Just renderer -> do-							close <- asIO1 removeAlert-							url <- liftIO $ renderUrl renderer (RestartThreadR name) []-							return $ Just $ AlertButton-								{ buttonLabel = T.pack "Restart Thread"-								, buttonUrl = url-								, buttonAction = Just close-								}-				runAssistant d $ void $-					addAlert $ (warningAlert (fromThreadName name) msg)-						{ alertButton = button }+				button <- runAssistant d $ mkAlertButton+					(T.pack "Restart Thread")+					urlrenderer +					(RestartThreadR name)+				runAssistant d $ void $ addAlert $+					(warningAlert (fromThreadName name) msg)+						{ alertButton = Just button } #endif  namedThreadId :: NamedThread -> Assistant (Maybe ThreadId)
Assistant/Sync.hs view
@@ -12,6 +12,7 @@ import Assistant.NetMessager import Assistant.Types.NetMessager import Assistant.Alert+import Assistant.Alert.Utility import Assistant.DaemonStatus import Assistant.ScanRemotes import qualified Command.Sync@@ -158,20 +159,25 @@  - XMPP remotes are handled specially; since the action can only start  - an async process for them, they are not included in the alert, but are  - still passed to the action.+ -+ - Readonly remotes are also hidden (to hide the web special remote).  -} syncAction :: [Remote] -> ([Remote] -> Assistant [Remote]) -> Assistant [Remote] syncAction rs a-	| null nonxmppremotes = a rs+	| null visibleremotes = a rs 	| otherwise = do-		i <- addAlert $ syncAlert nonxmppremotes+		i <- addAlert $ syncAlert visibleremotes 		failed <- a rs-		let failed' = filter (Git.repoIsLocalUnknown . Remote.repo) failed-		let succeeded = filter (`notElem` failed) nonxmppremotes-		updateAlertMap $ mergeAlert i $-			syncResultAlert succeeded failed'+		let failed' = filter (not . Git.repoIsLocalUnknown . Remote.repo) failed+		let succeeded = filter (`notElem` failed) visibleremotes+		if null succeeded && null failed'+			then removeAlert i+			else updateAlertMap $ mergeAlert i $+				syncResultAlert succeeded failed' 		return failed   where-	nonxmppremotes = filter (not . isXMPPRemote) rs+	visibleremotes = filter (not . Remote.readonly) $+		filter (not . isXMPPRemote) rs  {- Manually pull from remotes and merge their branches. Returns any  - remotes that it failed to pull from, and a Bool indicating
Assistant/Threads/Committer.hs view
@@ -312,7 +312,7 @@ 	done change file key = liftAnnex $ do 		logStatus key InfoPresent 		link <- ifM isDirect-			( calcGitLink file key+			( inRepo $ gitAnnexLink file key 			, Command.Add.link file key True 			) 		whenM (pure DirWatcher.eventsCoalesce <||> isDirect) $ do
Assistant/Threads/DaemonStatus.hs view
@@ -17,7 +17,7 @@  -} daemonStatusThread :: NamedThread daemonStatusThread = namedThread "DaemonStatus" $ do-	notifier <- liftIO . newNotificationHandle+	notifier <- liftIO . newNotificationHandle False 		=<< changeNotifier <$> getDaemonStatus 	checkpoint 	runEvery (Seconds tenMinutes) <~> do
Assistant/Threads/PairListener.hs view
@@ -11,7 +11,7 @@ import Assistant.Pairing import Assistant.Pairing.Network import Assistant.Pairing.MakeRemote-import Assistant.WebApp (UrlRenderer, renderUrl)+import Assistant.WebApp (UrlRenderer) import Assistant.WebApp.Types import Assistant.Alert import Assistant.DaemonStatus@@ -101,14 +101,8 @@ pairReqReceived :: Bool -> UrlRenderer -> PairMsg -> Assistant () pairReqReceived True _ _ = noop -- ignore our own PairReq pairReqReceived False urlrenderer msg = do-	url <- liftIO $ renderUrl urlrenderer (FinishLocalPairR msg) []-	closealert <- asIO1 removeAlert-	void $ addAlert $ pairRequestReceivedAlert repo-		AlertButton-			{ buttonUrl = url-			, buttonLabel = T.pack "Respond"-			, buttonAction = Just closealert-			}+	button <- mkAlertButton (T.pack "Respond") urlrenderer (FinishLocalPairR msg)+	void $ addAlert $ pairRequestReceivedAlert repo button   where 	repo = pairRepo msg
Assistant/Threads/TransferPoller.hs view
@@ -21,7 +21,7 @@ transferPollerThread :: NamedThread transferPollerThread = namedThread "TransferPoller" $ do 	g <- liftAnnex gitRepo-	tn <- liftIO . newNotificationHandle =<<+	tn <- liftIO . newNotificationHandle True =<< 		transferNotifier <$> getDaemonStatus 	forever $ do 		liftIO $ threadDelay 500000 -- 0.5 seconds
Assistant/Threads/TransferScanner.hs view
@@ -14,8 +14,11 @@ import Assistant.DaemonStatus import Assistant.Drop import Assistant.Sync+import Assistant.DeleteRemote+import Assistant.Types.UrlRenderer import Logs.Transfer import Logs.Location+import Logs.Group import Logs.Web (webUUID) import qualified Remote import qualified Types.Remote as Remote@@ -31,8 +34,8 @@ {- This thread waits until a remote needs to be scanned, to find transfers  - that need to be made, to keep data in sync.  -}-transferScannerThread :: NamedThread-transferScannerThread = namedThread "TransferScanner" $ do+transferScannerThread :: UrlRenderer -> NamedThread+transferScannerThread urlrenderer = namedThread "TransferScanner" $ do 	startupScan 	go S.empty   where@@ -43,7 +46,7 @@ 		scanrunning True 		if any fullScan infos || any (`S.notMember` scanned) rs 			then do-				expensiveScan rs+				expensiveScan urlrenderer rs 				go $ scanned `S.union` S.fromList rs 			else do 				mapM_ failedTransferScan rs@@ -67,6 +70,8 @@ 	 - * We may have run before, and had transfers queued, 	 -   and then the system (or us) crashed, and that info was 	 -   lost.+	 - * A remote may be in the unwanted group, and this is a chance+	 -   to determine if the remote has been emptied. 	 -} 	startupScan = do 		reconnectRemotes True =<< syncGitRemotes <$> getDaemonStatus@@ -103,26 +108,45 @@  -  - TODO: It would be better to first drop as much as we can, before  - transferring much, to minimise disk use.+ - + - During the scan, we'll also check if any unwanted repositories are empty,+ - and can be removed. While unrelated, this is a cheap place to do it,+ - since we need to look at the locations of all keys anyway.  -}-expensiveScan :: [Remote] -> Assistant ()-expensiveScan rs = unless onlyweb $ do+expensiveScan :: UrlRenderer -> [Remote] -> Assistant ()+expensiveScan urlrenderer rs = unless onlyweb $ do 	debug ["starting scan of", show visiblers]++	unwantedrs <- liftAnnex $ S.fromList+		<$> filterM inUnwantedGroup (map Remote.uuid rs)+ 	g <- liftAnnex gitRepo 	(files, cleanup) <- liftIO $ LsFiles.inRepo [] g-	forM_ files $ \f -> do-		ts <- maybe (return []) (findtransfers f)-			=<< liftAnnex (Backend.lookupFile f)-		mapM_ (enqueue f) ts+	removablers <- scan unwantedrs files 	void $ liftIO cleanup+ 	debug ["finished scan of", show visiblers]++	remove <- asIO1 $ removableRemote urlrenderer+	liftIO $ mapM_ (void . tryNonAsync . remove) $ S.toList removablers   where 	onlyweb = all (== webUUID) $ map Remote.uuid rs 	visiblers = let rs' = filter (not . Remote.readonly) rs 		in if null rs' then rs else rs'++	scan unwanted [] = return unwanted+	scan unwanted (f:fs) = do+		(unwanted', ts) <- maybe+			(return (unwanted, []))+			(findtransfers f unwanted)+				=<< liftAnnex (Backend.lookupFile f)+		mapM_ (enqueue f) ts+		scan unwanted' fs+ 	enqueue f (r, t) = 		queueTransferWhenSmall "expensive scan found missing object" 			(Just f) t r-	findtransfers f (key, _) = do+	findtransfers f unwanted (key, _) = do 		{- The syncable remotes may have changed since this 		 - scan began. -} 		syncrs <- syncDataRemotes <$> getDaemonStatus@@ -134,11 +158,13 @@ 		liftAnnex $ do 			let slocs = S.fromList locs 			let use a = return $ catMaybes $ map (a key slocs) syncrs-			if present+			ts <- if present 				then filterM (wantSend True (Just f) . Remote.uuid . fst) 					=<< use (genTransfer Upload False) 				else ifM (wantGet True $ Just f) 					( use (genTransfer Download True) , return [] )+			let unwanted' = S.difference unwanted slocs+			return (unwanted', ts)  genTransfer :: Direction -> Bool -> Key -> S.Set UUID -> Remote -> Maybe (Remote, Transfer) genTransfer direction want key slocs r
Assistant/Threads/TransferWatcher.hs view
@@ -62,10 +62,8 @@ 	go _ Nothing = noop -- transfer already finished 	go t (Just info) = do 		debug [ "transfer starting:", describeTransfer t info ]-		r <- headMaybe . filter (sameuuid t)-			<$> liftAnnex Remote.remoteList+		r <- liftAnnex $ Remote.remoteFromUUID $ transferUUID t 		updateTransferInfo t info { transferRemote = r }-	sameuuid t r = Remote.uuid r == transferUUID t  {- Called when a transfer information file is updated.  -
Assistant/Threads/Transferrer.hs view
@@ -12,6 +12,7 @@ import Assistant.TransferQueue import Assistant.TransferSlots import Assistant.Alert+import Assistant.Alert.Utility import Assistant.Commits import Assistant.Drop import Assistant.TransferrerPool@@ -82,7 +83,8 @@ 	 - so remove the transfer from the list of current 	 - transfers, just in case it didn't stop 	 - in a way that lets the TransferWatcher do its-	 - usual cleanup.+	 - usual cleanup. However, first check if something else is+	 - running the transfer, to avoid removing active transfers. 	 -} 	go remote file transferrer = ifM (liftIO $ performTransfer transferrer t $ associatedFile info) 		( do@@ -95,7 +97,8 @@ 					(associatedFile info) 					(Just remote) 			void $ recordCommit-		, void $ removeTransfer t+		, whenM (liftAnnex $ isNothing <$> checkTransfer t) $+			void $ removeTransfer t 		)  {- Called right before a transfer begins, this is a last chance to avoid
Assistant/Threads/Watcher.hs view
@@ -35,6 +35,7 @@ import Annex.Content.Direct import Annex.CatFile import Annex.Link+import Annex.FileMatcher import Git.Types import Config import Utility.ThreadScheduler@@ -77,8 +78,9 @@ runWatcher :: Assistant () runWatcher = do 	startup <- asIO1 startupScan+	matcher <- liftAnnex $ largeFilesMatcher 	direct <- liftAnnex isDirect-	addhook <- hook $ if direct then onAddDirect else onAdd+	addhook <- hook $ if direct then onAddDirect matcher else onAdd matcher 	delhook <- hook onDel 	addsymlinkhook <- hook $ onAddSymlink direct 	deldirhook <- hook onDelDir@@ -156,7 +158,7 @@  -} runHandler :: Handler -> FilePath -> Maybe FileStatus -> Assistant () runHandler handler file filestatus = void $ do-	r <- tryIO <~> handler file filestatus+	r <- tryIO <~> handler (normalize file) filestatus 	case r of 		Left e -> liftIO $ print e 		Right Nothing -> noop@@ -165,28 +167,50 @@ 			-- flushing the queue fast enough. 			liftAnnex $ Annex.Queue.flushWhenFull 			recordChange change+  where+  	normalize f+		| "./" `isPrefixOf` file = drop 2 f+		| otherwise = f -onAdd :: Handler-onAdd file filestatus-	| maybe False isRegularFile filestatus = pendingAddChange file+{- Small files are added to git as-is, while large ones go into the annex. -}+add :: FileMatcher -> FilePath -> Assistant (Maybe Change)+add bigfilematcher file = ifM (liftAnnex $ checkFileMatcher bigfilematcher file)+	( pendingAddChange file+	, do+		liftAnnex $ Annex.Queue.addCommand "add"+			[Params "--force --"] [file]+		madeChange file AddFileChange+	)++onAdd :: FileMatcher -> Handler+onAdd matcher file filestatus+	| maybe False isRegularFile filestatus = add matcher file 	| otherwise = noChange  {- In direct mode, add events are received for both new files, and- - modified existing files. Or, in some cases, existing files that have not- - really been modified. -}-onAddDirect :: Handler-onAddDirect file fs = do-	debug ["add direct", file]+ - modified existing files. -}+onAddDirect :: FileMatcher -> Handler+onAddDirect matcher file fs = do 	v <- liftAnnex $ catKeyFile file 	case (v, fs) of 		(Just key, Just filestatus) -> 			ifM (liftAnnex $ sameFileStatus key filestatus)-				( noChange+				{- It's possible to get an add event for+				 - an existing file that is not+				 - really modified, but it might have+				 - just been deleted and been put back,+				 - so it symlink is restaged to make sure. -}+				( do+					link <- liftAnnex $ inRepo $ gitAnnexLink file key+					addLink file link (Just key) 				, do+					debug ["changed direct", file] 					liftAnnex $ changedDirect key file-					pendingAddChange file+					add matcher file 				)-		_ -> pendingAddChange file+		_ -> do+			debug ["add direct", file]+			add matcher file  {- A symlink might be an arbitrary symlink, which is just added.  - Or, if it is a git-annex symlink, ensure it points to the content@@ -198,14 +222,14 @@ 	go (Just (key, _)) = do 		when isdirect $ 			liftAnnex $ void $ addAssociatedFile key file-		link <- liftAnnex $ calcGitLink file key+		link <- liftAnnex $ inRepo $ gitAnnexLink file key 		ifM ((==) (Just link) <$> liftIO (catchMaybeIO $ readSymbolicLink file)) 			( ensurestaged (Just link) (Just key) =<< getDaemonStatus 			, do-				unless isdirect $ do-					liftIO $ removeFile file-					liftAnnex $ Backend.makeAnnexLink link file-				addlink link (Just key)+				unless isdirect $+					liftAnnex $ replaceFile file $+						makeAnnexLink link+				addLink file link (Just key) 			) 	go Nothing = do -- other symlink 		mlink <- liftIO (catchMaybeIO $ readSymbolicLink file)@@ -223,24 +247,25 @@ 	 - links too.) 	 -} 	ensurestaged (Just link) mk daemonstatus-		| scanComplete daemonstatus = addlink link mk+		| scanComplete daemonstatus = addLink file link mk 		| otherwise = case filestatus of 			Just s 				| not (afterLastDaemonRun (statusChangeTime s) daemonstatus) -> noChange-			_ -> addlink link mk+			_ -> addLink file link mk 	ensurestaged Nothing _ _ = noChange -	{- For speed, tries to reuse the existing blob for symlink target. -}-	addlink link mk = do-		debug ["add symlink", file]-		liftAnnex $ do-			v <- catObjectDetails $ Ref $ ':':file-			case v of-				Just (currlink, sha)-					| s2w8 link == L.unpack currlink ->-						stageSymlink file sha-				_ -> stageSymlink file =<< hashSymlink link-		madeChange file $ LinkChange mk+{- For speed, tries to reuse the existing blob for symlink target. -}+addLink :: FilePath -> FilePath -> Maybe Key -> Assistant (Maybe Change)+addLink file link mk = do+	debug ["add symlink", file]+	liftAnnex $ do+		v <- catObjectDetails $ Ref $ ':':file+		case v of+			Just (currlink, sha)+				| s2w8 link == L.unpack currlink ->+					stageSymlink file sha+			_ -> stageSymlink file =<< hashSymlink link+	madeChange file $ LinkChange mk  onDel :: Handler onDel file _ = do
Assistant/Threads/WebApp.hs view
@@ -18,7 +18,6 @@ import Assistant.WebApp.Notifications import Assistant.WebApp.RepoList import Assistant.WebApp.Configurators-import Assistant.WebApp.Configurators.Edit import Assistant.WebApp.Configurators.Local import Assistant.WebApp.Configurators.Ssh import Assistant.WebApp.Configurators.Pairing@@ -26,6 +25,8 @@ import Assistant.WebApp.Configurators.WebDAV import Assistant.WebApp.Configurators.XMPP import Assistant.WebApp.Configurators.Preferences+import Assistant.WebApp.Configurators.Edit+import Assistant.WebApp.Configurators.Delete import Assistant.WebApp.Documentation import Assistant.WebApp.Control import Assistant.WebApp.OtherRepos
Assistant/Threads/XMPPClient.hs view
@@ -18,8 +18,9 @@ import Assistant.DaemonStatus import qualified Remote import Utility.ThreadScheduler-import Assistant.WebApp (UrlRenderer, renderUrl)+import Assistant.WebApp (UrlRenderer) import Assistant.WebApp.Types hiding (liftAssistant)+import Assistant.WebApp.Configurators.XMPP (checkCloudRepos) import Assistant.Alert import Assistant.Pairing import Assistant.XMPP.Git@@ -106,8 +107,9 @@ 		maybe noop (inAssistant . pairMsgReceived urlrenderer stage u selfjid) (parseJID c) 	handle _ (GotNetMessage m@(Pushing _ pushstage)) 		| isPushInitiation pushstage = inAssistant $-			unlessM (queueNetPushMessage m) $ -				void $ forkIO <~> handlePushInitiation urlrenderer m+			unlessM (queueNetPushMessage m) $ do+				let checker = checkCloudRepos urlrenderer+				void $ forkIO <~> handlePushInitiation checker m 		| otherwise = void $ inAssistant $ queueNetPushMessage m 	handle _ (Ignorable _) = noop 	handle _ (Unknown _) = noop@@ -279,16 +281,12 @@ 		finishXMPPPairing theirjid theiruuid 	-- Show an alert to let the user decide if they want to pair. 	showalert = do-		let route = ConfirmXMPPPairFriendR $-			PairKey theiruuid $ formatJID theirjid-		url <- liftIO $ renderUrl urlrenderer route []-		close <- asIO1 removeAlert-		void $ addAlert $ pairRequestReceivedAlert (T.unpack $ buddyName theirjid)-			AlertButton-				{ buttonUrl = url-				, buttonLabel = T.pack "Respond"-				, buttonAction = Just close-				}+		button <- mkAlertButton (T.pack "Respond") urlrenderer $+			ConfirmXMPPPairFriendR $+				PairKey theiruuid $ formatJID theirjid+		void $ addAlert $ pairRequestReceivedAlert+			(T.unpack $ buddyName theirjid)+			button  pairMsgReceived _ PairAck theiruuid _selfjid theirjid = 	{- PairAck must come from one of the buddies we are pairing with;
Assistant/TransferQueue.hs view
@@ -32,6 +32,7 @@  import Control.Concurrent.STM import qualified Data.Map as M+import qualified Data.Set as S  type Reason = String @@ -58,6 +59,7 @@ 	| otherwise = go   where 	go = do+		 		rs <- liftAnnex . selectremotes 			=<< syncDataRemotes <$> getDaemonStatus 		let matchingrs = filter (matching . Remote.uuid) rs@@ -67,15 +69,21 @@ 				enqueue reason schedule (gentransfer r) (stubInfo f r) 	selectremotes rs 		{- Queue downloads from all remotes that-		 - have the key, with the cheapest ones first.-		 - More expensive ones will only be tried if-		 - downloading from a cheap one fails. -}+		 - have the key. The list of remotes is ordered with+		 - cheapest first. More expensive ones will only be tried+		 - if downloading from a cheap one fails. -} 		| direction == Download = do-			uuids <- Remote.keyLocations k-			return $ filter (\r -> uuid r `elem` uuids) rs-		{- Upload to all remotes that want the content. -}-		| otherwise = filterM (wantSend True f . Remote.uuid) $-			filter (not . Remote.readonly) rs+			s <- locs+			return $ filter (inset s) rs+		{- Upload to all remotes that want the content and don't+		 - already have it. -}+		| otherwise = do+			s <- locs+			filterM (wantSend True f . Remote.uuid) $+				filter (\r -> not (inset s r || Remote.readonly r)) rs+	  where+	  	locs = S.fromList <$> Remote.keyLocations k+		inset s r = S.member (Remote.uuid r) s 	gentransfer r = Transfer 		{ transferDirection = direction 		, transferKey = k@@ -128,14 +136,18 @@ 		notifyTransfer 	add modlist = do 		q <- getAssistant transferQueue-		liftIO $ atomically $ do-			l <- readTVar (queuelist q)-			if (new `notElem` l)-				then do	-					void $ modifyTVar' (queuesize q) succ-					void $ modifyTVar' (queuelist q) modlist-					return True-				else return False+		dstatus <- getAssistant daemonStatusHandle+		liftIO $ atomically $ ifM (checkRunningTransferSTM dstatus t)+			( return False+			, do+				l <- readTVar (queuelist q)+				if (t `notElem` map fst l)+					then do	+						void $ modifyTVar' (queuesize q) succ+						void $ modifyTVar' (queuelist q) modlist+						return True+					else return False+			)  {- Adds a transfer to the queue. -} queueTransfer :: Reason -> Schedule -> AssociatedFile -> Transfer -> Remote -> Assistant ()
+ Assistant/Types/Alert.hs view
@@ -0,0 +1,74 @@+{- git-annex assistant alert types+ -+ - Copyright 2013 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Assistant.Types.Alert where++import Utility.Tense++import Data.Text (Text)+import qualified Data.Map as M++{- Different classes of alerts are displayed differently. -}+data AlertClass = Success | Message | Activity | Warning | Error+	deriving (Eq, Ord)++data AlertPriority = Filler | Low | Medium | High | Pinned+	deriving (Eq, Ord)++{- An alert can have an name, which is used to combine it with other similar+ - alerts. -}+data AlertName +	= FileAlert TenseChunk+	| SanityCheckFixAlert+	| WarningAlert String+	| PairAlert String+	| XMPPNeededAlert+	| RemoteRemovalAlert String+	| CloudRepoNeededAlert+	| SyncAlert+	deriving (Eq)++{- The first alert is the new alert, the second is an old alert.+ - Should return a modified version of the old alert. -}+type AlertCombiner = Alert -> Alert -> Maybe Alert++data Alert = Alert+	{ alertClass :: AlertClass+	, alertHeader :: Maybe TenseText+	, alertMessageRender :: [TenseChunk] -> TenseText+	, alertData :: [TenseChunk]+	, alertBlockDisplay :: Bool+	, alertClosable :: Bool+	, alertPriority :: AlertPriority+	, alertIcon :: Maybe AlertIcon+	, alertCombiner :: Maybe AlertCombiner+	, alertName :: Maybe AlertName+	, alertButton :: Maybe AlertButton+	}++data AlertIcon = ActivityIcon | SuccessIcon | ErrorIcon | InfoIcon | TheCloud++type AlertMap = M.Map AlertId Alert++{- Higher AlertId indicates a more recent alert. -}+newtype AlertId = AlertId Integer+	deriving (Read, Show, Eq, Ord)++firstAlertId :: AlertId+firstAlertId = AlertId 0++nextAlertId :: AlertId -> AlertId+nextAlertId (AlertId i) = AlertId $ succ i++{- When clicked, a button always redirects to a URL+ - It may also run an IO action in the background, which is useful+ - to make the button close or otherwise change the alert. -}+data AlertButton = AlertButton+	{ buttonLabel :: Text+	, buttonUrl :: Text+	, buttonAction :: Maybe (AlertId -> IO ())+	}
Assistant/Types/Changes.hs view
@@ -14,11 +14,11 @@ import Data.Time.Clock import Control.Concurrent.STM -data ChangeInfo = AddChange Key | LinkChange (Maybe Key) | RmChange+data ChangeInfo = AddKeyChange Key | AddFileChange | LinkChange (Maybe Key) | RmChange 	deriving (Show, Eq)  changeInfoKey :: ChangeInfo -> Maybe Key-changeInfoKey (AddChange k) = Just k+changeInfoKey (AddKeyChange k) = Just k changeInfoKey (LinkChange (Just k)) = Just k changeInfoKey _ = Nothing @@ -60,6 +60,6 @@ finishedChange c@(InProcessAddChange { keySource = ks }) k = Change 	{ changeTime = changeTime c 	, _changeFile = keyFilename ks-	, changeInfo = AddChange k+	, changeInfo = AddKeyChange k 	} finishedChange c _ = c
Assistant/Types/DaemonStatus.hs view
@@ -10,12 +10,12 @@ module Assistant.Types.DaemonStatus where  import Common.Annex-import Assistant.Alert import Assistant.Pairing import Utility.NotificationBroadcaster import Logs.Transfer import Assistant.Types.ThreadName import Assistant.Types.NetMessager+import Assistant.Types.Alert  import Control.Concurrent.STM import Control.Concurrent.Async
Assistant/Types/NamedThread.hs view
@@ -14,4 +14,4 @@ data NamedThread = NamedThread ThreadName (Assistant ())  namedThread :: String -> Assistant () -> NamedThread-namedThread name a = NamedThread (ThreadName name) a+namedThread = NamedThread . ThreadName
Assistant/Types/NetMessager.hs view
@@ -104,7 +104,7 @@  data NetMessager = NetMessager 	-- outgoing messages-	{ netMessages :: TChan (NetMessage)+	{ netMessages :: TChan NetMessage 	-- important messages for each client 	, importantNetMessages :: TMVar (M.Map ClientID (S.Set NetMessage)) 	-- important messages that are believed to have been sent to a client
+ Assistant/Types/UrlRenderer.hs view
@@ -0,0 +1,26 @@+{- webapp url renderer access from the assistant+ -+ - Copyright 2013 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE CPP #-}++module Assistant.Types.UrlRenderer (+	UrlRenderer,+	newUrlRenderer+) where++#ifdef WITH_WEBAPP++import Assistant.WebApp (UrlRenderer, newUrlRenderer)++#else++data UrlRenderer = UrlRenderer -- dummy type++newUrlRenderer :: IO UrlRenderer+newUrlRenderer = return UrlRenderer++#endif
Assistant/WebApp.hs view
@@ -30,7 +30,7 @@ newNotifier :: forall sub. (Assistant NotificationBroadcaster) -> GHandler sub WebApp NotificationId newNotifier getbroadcaster = liftAssistant $ do 	b <- getbroadcaster-	liftIO $ notificationHandleToId <$> newNotificationHandle b+	liftIO $ notificationHandleToId <$> newNotificationHandle True b  {- Adds the auth parameter as a hidden field on a form. Must be put into  - every form. -}
Assistant/WebApp/Configurators/AWS.hs view
@@ -180,7 +180,7 @@ 			makeAWSRemote remotetype creds name (const noop) M.empty 		_ -> do 			description <- liftAnnex $-				T.pack . concat <$> Remote.prettyListUUIDs [uuid]+				T.pack <$> Remote.prettyUUID uuid 			$(widgetFile "configurators/enableaws")  makeAWSRemote :: RemoteType -> AWSCreds -> String -> (Remote -> Handler ()) -> RemoteConfig -> Handler ()
+ Assistant/WebApp/Configurators/Delete.hs view
@@ -0,0 +1,125 @@+{- git-annex assistant webapp repository deletion+ -+ - Copyright 2013 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}++module Assistant.WebApp.Configurators.Delete where++import Assistant.WebApp.Common+import Assistant.DeleteRemote+import Assistant.WebApp.Utility+import Assistant.DaemonStatus+import Assistant.ScanRemotes+import qualified Remote+import qualified Git+import Locations.UserConfig+import Utility.FileMode+import Logs.Trust+import Logs.Remote+import Logs.PreferredContent+import Types.StandardGroups++import System.IO.HVFS (SystemFS(..))+import qualified Data.Text as T+import qualified Data.Map as M++notCurrentRepo :: UUID -> Handler RepHtml -> Handler RepHtml+notCurrentRepo uuid a = go =<< liftAnnex (Remote.remoteFromUUID uuid)+  where+  	go Nothing = redirect DeleteCurrentRepositoryR+	go (Just _) = a++getDisableRepositoryR :: UUID -> Handler RepHtml+getDisableRepositoryR uuid = notCurrentRepo uuid $ do+	void $ liftAssistant $ disableRemote uuid+	redirect DashboardR++getDeleteRepositoryR :: UUID -> Handler RepHtml+getDeleteRepositoryR uuid = notCurrentRepo uuid $+	deletionPage $ do+		reponame <- liftAnnex $ Remote.prettyUUID uuid+		$(widgetFile "configurators/delete/start")++getStartDeleteRepositoryR :: UUID -> Handler RepHtml+getStartDeleteRepositoryR uuid = do+	remote <- fromMaybe (error "unknown remote")+		<$> liftAnnex (Remote.remoteFromUUID uuid)+	liftAnnex $ do+		trustSet uuid UnTrusted+		setStandardGroup uuid UnwantedGroup+	liftAssistant $ addScanRemotes True [remote]+	redirect DashboardR++getFinishDeleteRepositoryR :: UUID -> Handler RepHtml+getFinishDeleteRepositoryR uuid = deletionPage $ do+	void $ liftAssistant $ removeRemote uuid++	reponame <- liftAnnex $ Remote.prettyUUID uuid+	{- If it's not listed in the remote log, it must be a git repo. -}+	gitrepo <- liftAnnex $ M.notMember uuid <$> readRemoteLog+	$(widgetFile "configurators/delete/finished")	++getDeleteCurrentRepositoryR :: Handler RepHtml+getDeleteCurrentRepositoryR = deleteCurrentRepository++postDeleteCurrentRepositoryR :: Handler RepHtml+postDeleteCurrentRepositoryR = deleteCurrentRepository++deleteCurrentRepository :: Handler RepHtml+deleteCurrentRepository = dangerPage $ do+	reldir <- fromJust . relDir <$> lift getYesod+	havegitremotes <- haveremotes syncGitRemotes+	havedataremotes <- haveremotes syncDataRemotes+	((result, form), enctype) <- lift $+		runFormPost $ renderBootstrap $ sanityVerifierAForm $+			SanityVerifier magicphrase+	case result of+		FormSuccess _ -> lift $ do+			dir <- liftAnnex $ fromRepo Git.repoPath+			liftIO $ removeAutoStartFile dir++			{- Disable syncing to this repository, and all+			 - remotes. This stops all transfers, and all+			 - file watching. -}+			changeSyncable Nothing False+			rs <- liftAssistant $ syncRemotes <$> getDaemonStatus+			mapM_ (\r -> changeSyncable (Just r) False) rs++			{- Make all directories writable, so all annexed+			 - content can be deleted. -}+			liftIO $ do+				recurseDir SystemFS dir >>=+					filterM doesDirectoryExist >>=+						mapM_ allowWrite+				removeDirectoryRecursive dir+			+			redirect ShutdownConfirmedR+		_ -> $(widgetFile "configurators/delete/currentrepository")+  where+	haveremotes selector = not . null . selector+		<$> liftAssistant getDaemonStatus++data SanityVerifier = SanityVerifier T.Text+	deriving (Eq)++sanityVerifierAForm :: SanityVerifier -> AForm WebApp WebApp SanityVerifier+sanityVerifierAForm template = SanityVerifier+	<$> areq checksanity "Confirm deletion?" Nothing+  where+	checksanity = checkBool (\input -> SanityVerifier input == template)+		insane textField+	+	insane = "Maybe this is not a good idea..." :: Text++deletionPage :: Widget -> Handler RepHtml+deletionPage = page "Delete repository" (Just Configuration)++dangerPage :: Widget -> Handler RepHtml+dangerPage = page "Danger danger danger" (Just Configuration)++magicphrase :: Text+magicphrase = "Yes, please do as I say!"
Assistant/WebApp/Configurators/Local.hs view
@@ -27,7 +27,7 @@ import Utility.DiskFree import Utility.DataUnits import Utility.Network-import Remote (prettyListUUIDs)+import Remote (prettyUUID) import Annex.UUID import Types.StandardGroups import Logs.PreferredContent@@ -261,8 +261,7 @@  getEnableDirectoryR :: UUID -> Handler RepHtml getEnableDirectoryR uuid = page "Enable a repository" (Just Configuration) $ do-	description <- liftAnnex $-		T.pack . concat <$> prettyListUUIDs [uuid]+	description <- liftAnnex $ T.pack <$> prettyUUID uuid 	$(widgetFile "configurators/enabledirectory")  {- List of removable drives. -}
Assistant/WebApp/Configurators/Ssh.hs view
@@ -148,8 +148,7 @@ 		_ -> redirect AddSshR   where 	showform form enctype status = do-		description <- liftAnnex $-			T.pack . concat <$> prettyListUUIDs [u]+		description <- liftAnnex $ T.pack <$> prettyUUID u 		$(widgetFile "configurators/ssh/enable") 	enable sshdata = lift $ redirect $ ConfirmSshR $ 		sshdata { rsyncOnly = True }@@ -206,7 +205,7 @@ 		, rsyncOnly = status == UsableRsyncServer 		} 	probe extraopts = do-		let remotecommand = join ";"+		let remotecommand = shellWrap $ join ";" 			[ report "loggedin" 			, checkcommand "git-annex-shell" 			, checkcommand "rsync"@@ -236,6 +235,7 @@ 			"Failed to ssh to the server. Transcript: " ++ s 	  where 		reported r = token r `isInfixOf` s+	 	checkcommand c = "if which " ++ c ++ "; then " ++ report c ++ "; fi" 	token r = "git-annex-probe " ++ r 	report r = "echo " ++ token r@@ -287,7 +287,7 @@   where 	sshhost = genSshHost (sshHostName sshdata) (sshUserName sshdata) 	remotedir = T.unpack $ sshDirectory sshdata-	remoteCommand = join "&&" $ catMaybes+	remoteCommand = shellWrap $ join "&&" $ catMaybes 		[ Just $ "mkdir -p " ++ shellEscape remotedir 		, Just $ "cd " ++ shellEscape remotedir 		, if rsync then Nothing else Just "git init --bare --shared"
Assistant/WebApp/Configurators/WebDAV.hs view
@@ -46,7 +46,7 @@ boxComAForm = WebDAVInput 	<$> areq textField "Username or Email" Nothing 	<*> areq passwordField "Box.com Password" Nothing-	<*> areq checkBoxField "Share this account with friends?" (Just True)+	<*> areq checkBoxField "Share this account with other devices and friends?" (Just True) 	<*> areq textField "Directory" (Just "annex") 	<*> enableEncryptionField @@ -113,7 +113,7 @@ 				makeWebDavRemote name (toCredPair input) (const noop) M.empty 			_ -> do 				description <- liftAnnex $-					T.pack . concat <$> Remote.prettyListUUIDs [uuid]+					T.pack <$> Remote.prettyUUID uuid 				$(widgetFile "configurators/enablewebdav") #else postEnableWebDAVR _ = error "WebDAV not supported by this build"
Assistant/WebApp/Configurators/XMPP.hs view
@@ -50,21 +50,18 @@ xmppNeeded = return () #endif -{- Displays an alert suggesting to configure a cloud repo+{- When appropriate, displays an alert suggesting to configure a cloud repo  - to suppliment an XMPP remote. -}-cloudRepoNeeded :: UrlRenderer -> UUID -> Assistant ()+checkCloudRepos :: UrlRenderer -> Remote -> Assistant () #ifdef WITH_XMPP-cloudRepoNeeded urlrenderer for = do-	buddyname <- getBuddyName for-	url <- liftIO $ renderUrl urlrenderer (NeedCloudRepoR for) []-	close <- asIO1 removeAlert-	void $ addAlert $ cloudRepoNeededAlert buddyname $ AlertButton-		{ buttonLabel = "Add a cloud repository"-		, buttonUrl = url-		, buttonAction = Just close-		}+checkCloudRepos urlrenderer r =+	unlessM (syncingToCloudRemote <$> getDaemonStatus) $ do+		buddyname <- getBuddyName $ Remote.uuid r+		button <- mkAlertButton "Add a cloud repository" urlrenderer $+			NeedCloudRepoR $ Remote.uuid r+		void $ addAlert $ cloudRepoNeededAlert buddyname button #else-cloudRepoNeeded = return ()+checkCloudRepos _ _ = noop #endif  {- Returns the name of the friend corresponding to a@@ -88,7 +85,7 @@ 	buddyname <- liftAssistant $ getBuddyName for 	$(widgetFile "configurators/xmpp/needcloudrepo") #else-needCloudRepoR = xmppPage $+getNeedCloudRepoR = xmppPage $ 	$(widgetFile "configurators/xmpp/disabled") #endif
Assistant/WebApp/DashBoard.hs view
@@ -27,9 +27,7 @@ import qualified Data.Map as M import Control.Concurrent -{- A display of currently running and queued transfers.- -- - Or, if there have never been any this run, an intro display. -}+{- A display of currently running and queued transfers. -} transfersDisplay :: Bool -> Widget transfersDisplay warnNoScript = do 	webapp <- lift getYesod
Assistant/WebApp/RepoList.hs view
@@ -20,6 +20,7 @@ import Annex.UUID (getUUID) import Logs.Remote import Logs.Trust+import Logs.Group import Config import Config.Cost import qualified Git@@ -41,6 +42,8 @@ 		{ setupRepoLink :: Route WebApp 		, syncToggleLink :: Route WebApp 		}+	| UnwantedRepoActions+		{ setupRepoLink :: Route WebApp }  mkSyncingRepoActions :: UUID -> Actions mkSyncingRepoActions u = SyncingRepoActions@@ -54,6 +57,11 @@ 	, syncToggleLink = EnableSyncR u 	} +mkUnwantedRepoActions :: UUID -> Actions+mkUnwantedRepoActions u = UnwantedRepoActions+	{ setupRepoLink = EditRepositoryR u+	}+ needsEnabled :: Actions -> Bool needsEnabled (DisabledRepoActions _) = True needsEnabled _ = False@@ -62,6 +70,10 @@ notSyncing (SyncingRepoActions _ _) = False notSyncing _ = True +notWanted :: Actions -> Bool+notWanted (UnwantedRepoActions _) = True+notWanted _ = False+ {- Called by client to get a list of repos, that refreshes  - when new repos are added.  -@@ -115,16 +127,19 @@ 	| otherwise = list =<< (++) <$> configured <*> unconfigured   where 	configured = do-		syncing <- S.fromList . syncRemotes+		syncing <- S.fromList . map Remote.uuid . syncRemotes 			<$> liftAssistant getDaemonStatus 		liftAnnex $ do-			rs <- filter wantedrepo . concat . Remote.byCost+			unwanted <- S.fromList+				<$> filterM inUnwantedGroup (S.toList syncing)+			rs <- filter selectedrepo . concat . Remote.byCost 				<$> Remote.enabledRemoteList 			let us = map Remote.uuid rs-			let make r = if r `S.member` syncing-				then mkSyncingRepoActions $ Remote.uuid r-				else mkNotSyncingRepoActions $ Remote.uuid r-			let l = zip us $ map make rs+			let maker u+				| u `S.member` unwanted = mkUnwantedRepoActions u+				| u `S.member` syncing = mkSyncingRepoActions u+				| otherwise = mkNotSyncingRepoActions u+			let l = zip us $ map (maker . Remote.uuid) rs 			if includeHere reposelector 				then do 					u <- getUUID@@ -137,15 +152,15 @@ 				else return l 	unconfigured = liftAnnex $ do 		m <- readRemoteLog-		map snd . catMaybes . filter wantedremote +		map snd . catMaybes . filter selectedremote  			. map (findinfo m) 			<$> (trustExclude DeadTrusted $ M.keys m)-	wantedrepo r+	selectedrepo r 		| Remote.readonly r = False 		| onlyCloud reposelector = Git.repoIsUrl (Remote.repo r) && not (isXMPPRemote r) 		| otherwise = True-	wantedremote Nothing = False-	wantedremote (Just (iscloud, _))+	selectedremote Nothing = False+	selectedremote (Just (iscloud, _)) 		| onlyCloud reposelector = iscloud 		| otherwise = True 	findinfo m u = case M.lookup u m of
Assistant/WebApp/SideBar.hs view
@@ -13,7 +13,7 @@ import Assistant.WebApp import Assistant.WebApp.Types import Assistant.WebApp.Notifications-import Assistant.Alert+import Assistant.Alert.Utility import Assistant.DaemonStatus import Utility.NotificationBroadcaster import Utility.Yesod
Assistant/WebApp/Types.hs view
@@ -14,7 +14,6 @@  import Assistant.Common import Assistant.Ssh-import Assistant.Alert import Assistant.Pairing import Assistant.Types.Buddies import Utility.NotificationBroadcaster
Assistant/WebApp/routes view
@@ -63,6 +63,13 @@  /config/repository/reorder RepositoriesReorderR GET +/config/repository/disable/#UUID DisableRepositoryR GET++/config/repository/delete/confirm/#UUID DeleteRepositoryR GET+/config/repository/delete/start/#UUID StartDeleteRepositoryR GET+/config/repository/delete/finish/#UUID FinishDeleteRepositoryR GET+/config/repository/delete/here DeleteCurrentRepositoryR GET POST+ /transfers/#NotificationId TransfersR GET /notifier/transfers NotifierTransfersR GET
Assistant/XMPP/Git.hs view
@@ -31,10 +31,6 @@ import Remote.List import Utility.FileMode import Utility.Shell-#ifdef WITH_WEBAPP-import Assistant.WebApp (UrlRenderer)-import Assistant.WebApp.Configurators.XMPP-#endif  import Network.Protocol.XMPP import qualified Data.Text as T@@ -256,11 +252,11 @@   where 	matching loc r = repoIsUrl r && repoLocation r == loc -handlePushInitiation :: UrlRenderer -> NetMessage -> Assistant ()+handlePushInitiation :: (Remote -> Assistant ()) -> NetMessage -> Assistant () handlePushInitiation _ (Pushing cid CanPush) = 	unlessM (null <$> xmppRemotes cid) $  		sendNetMessage $ Pushing cid PushRequest-handlePushInitiation urlrenderer (Pushing cid PushRequest) =+handlePushInitiation checkcloudrepos (Pushing cid PushRequest) = 	go =<< liftAnnex (inRepo Git.Branch.current)   where 	go Nothing = noop@@ -276,28 +272,18 @@ 			void $ alertWhile (syncAlert [r]) $ 				xmppPush cid 					(taggedPush u selfjid branch r)-					(handleDeferred urlrenderer)-			checkCloudRepos urlrenderer r-handlePushInitiation urlrenderer (Pushing cid StartingPush) = do+					(handleDeferred checkcloudrepos)+			checkcloudrepos r+handlePushInitiation checkcloudrepos (Pushing cid StartingPush) = do 	rs <- xmppRemotes cid 	unless (null rs) $ do 		void $ alertWhile (syncAlert rs) $-			xmppReceivePack cid (handleDeferred urlrenderer)-		mapM_ (checkCloudRepos urlrenderer) rs+			xmppReceivePack cid (handleDeferred checkcloudrepos)+		mapM_ checkcloudrepos rs handlePushInitiation _ _ = noop -handleDeferred :: UrlRenderer -> NetMessage -> Assistant ()+handleDeferred :: (Remote -> Assistant ()) -> NetMessage -> Assistant () handleDeferred = handlePushInitiation--checkCloudRepos :: UrlRenderer -> Remote -> Assistant ()--- TODO only display if needed-checkCloudRepos urlrenderer r =-#ifdef WITH_WEBAPP-	unlessM (syncingToCloudRemote <$> getDaemonStatus) $-		cloudRepoNeeded urlrenderer (Remote.uuid r)-#else-	noop-#endif  writeChunk :: Handle -> B.ByteString -> IO () writeChunk h b = do
Backend.hs view
@@ -11,7 +11,6 @@ 	genKey, 	lookupFile, 	isAnnexLink,-	makeAnnexLink, 	chooseBackend, 	lookupBackendName, 	maybeLookupBackendName@@ -95,8 +94,7 @@   where 	makeret k = let bname = keyBackendName k in 		case maybeLookupBackendName bname of-			Just backend -> do-				return $ Just (k, backend)+			Just backend -> return $ Just (k, backend) 			Nothing -> do 				warning $ 					"skipping " ++ file ++
CHANGELOG view
@@ -1,3 +1,40 @@+git-annex (4.20130405) unstable; urgency=low++  * Group subcommands into sections in usage. Closes: #703797+  * Per-command usage messages.+  * webapp: Fix a race that sometimes caused alerts or other notifications+    to be missed if they occurred while a page was loading.+  * webapp: Progess bar fixes for many types of special remotes.+  * Build debian package without using cabal, which writes to HOME.+    Closes: #704205+  * webapp: Run ssh server probes in a way that will work when the+    login shell is a monstrosity that should have died 25 years ago,+    such as csh.+  * New annex.largefiles setting, which configures which files+    `git annex add` and the assistant add to the annex.+  * assistant: Check small files into git directly.+  * Remotes can be configured to use other MAC algorithms than HMACSHA1+    to encrypt filenames.+    Thanks, guilhem for the patch.+  * git-annex-shell: Passes rsync --bwlimit options on rsync.+    Thanks, guilhem for the patch.+  * webapp: Added UI to delete repositories. Closes: #689847+  * Adjust built-in preferred content expressions to make most types+    of repositories want content that is only located on untrusted, dead,+    and unwanted repositories.+  * drop --auto: Fix bug that prevented dropping files from untrusted+    repositories.+  * assistant: Fix bug that could cause direct mode files to be unstaged+    from git.+  * Update working tree files fully atomically.+  * webapp: Improved transfer queue management.+  * init: Probe whether the filesystem supports fifos, and if not,+    disable ssh connection caching.+  * Use lower case hash directories for storing files on crippled filesystems,+    same as is already done for bare repositories.++ -- Joey Hess <joeyh@debian.org>  Fri, 05 Apr 2013 10:42:18 -0400+ git-annex (4.20130323) unstable; urgency=low    * webapp: Repository list is now included in the dashboard, and other
CmdLine.hs view
@@ -40,15 +40,15 @@ 			state <- Annex.new g 			(actions, state') <- Annex.run state $ do 				checkfuzzy-				forM_ fields $ \(f, v) -> Annex.setField f v+				forM_ fields $ uncurry Annex.setField 				sequence_ flags 				prepCommand cmd params 		 	tryRun state' cmd $ [startup] ++ actions ++ [shutdown $ cmdnocommit cmd]   where-	err msg = msg ++ "\n\n" ++ usage header allcmds commonoptions+	err msg = msg ++ "\n\n" ++ usage header allcmds 	cmd = Prelude.head cmds 	(fuzzy, cmds, name, args) = findCmd fuzzyok allargs allcmds err-	(flags, params) = getOptCmd args cmd commonoptions err+	(flags, params) = getOptCmd args cmd commonoptions 	checkfuzzy = when fuzzy $ 		inRepo $ Git.AutoCorrect.prepare name cmdname cmds @@ -74,12 +74,15 @@  {- Parses command line options, and returns actions to run to configure flags  - and the remaining parameters for the command. -}-getOptCmd :: Params -> Command -> [Option] -> (String -> String) -> (Flags, Params)-getOptCmd argv cmd commonoptions err = check $+getOptCmd :: Params -> Command -> [Option] -> (Flags, Params)+getOptCmd argv cmd commonoptions = check $ 	getOpt Permute (commonoptions ++ cmdoptions cmd) argv   where 	check (flags, rest, []) = (flags, rest)-	check (_, _, errs) = error $ err $ concat errs+	check (_, _, errs) = error $ unlines+		[ concat errs+		, commandUsage cmd+		]  {- Runs a list of Annex actions. Catches IO errors and continues  - (but explicitly thrown errors terminate the whole command).
Command.hs view
@@ -20,7 +20,6 @@ 	isBareRepo, 	numCopies, 	numCopiesCheck,-	autoCopiesWith, 	checkAuto, 	module ReExported ) where@@ -40,7 +39,7 @@ import Annex.CheckAttr  {- Generates a normal command -}-command :: String -> String -> [CommandSeek] -> String -> Command+command :: String -> String -> [CommandSeek] -> CommandSection -> String -> Command command = Command [] Nothing commonChecks False  {- Indicates that a command doesn't need to commit any changes to@@ -108,26 +107,6 @@ 	needed <- getNumCopies numcopiesattr 	have <- trustExclude UnTrusted =<< Remote.keyLocations key 	return $ length have `vs` needed--{- Used for commands that have an auto mode that checks the number of known- - copies of a key.- -- - In auto mode, first checks that the number of known- - copies of the key is > or < than the numcopies setting, before running- - the action.- -}-autoCopiesWith :: FilePath -> Key -> (Int -> Int -> Bool) -> (Maybe Int -> CommandStart) -> CommandStart-autoCopiesWith file key vs a = do-	numcopiesattr <- numCopies file-	Annex.getState Annex.auto >>= auto numcopiesattr-  where-	auto numcopiesattr False = a numcopiesattr-	auto numcopiesattr True = do-		needed <- getNumCopies numcopiesattr-		have <- trustExclude UnTrusted =<< Remote.keyLocations key-		if length have `vs` needed-			then a numcopiesattr-			else stop  checkAuto :: Annex Bool -> Annex Bool checkAuto checker = ifM (Annex.getState Annex.auto)
Command/Add.hs view
@@ -1,6 +1,6 @@ {- git-annex command  -- - Copyright 2010 Joey Hess <joey@kitenet.net>+ - Copyright 2010, 2013 Joey Hess <joey@kitenet.net>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -27,19 +27,27 @@ import Utility.FileMode import Config import Utility.InodeCache+import Annex.FileMatcher  def :: [Command]-def = [notBareRepo $ command "add" paramPaths seek "add files to annex"]+def = [notBareRepo $ command "add" paramPaths seek SectionCommon+	"add files to annex"]  {- Add acts on both files not checked into git yet, and unlocked files.  -  - In direct mode, it acts on any files that have changed. -} seek :: [CommandSeek] seek =-	[ withFilesNotInGit start-	, whenNotDirect $ withFilesUnlocked start-	, whenDirect $ withFilesMaybeModified start+	[ go withFilesNotInGit+	, whenNotDirect $ go withFilesUnlocked+	, whenDirect $ go withFilesMaybeModified 	]+  where+  	go a = withValue largeFilesMatcher $ \matcher ->+		a $ \file -> ifM (checkFileMatcher matcher file <||> Annex.getState Annex.force)+			( start file+			, stop+			)  {- The add subcommand annexes a file, generating a key for it using a  - backend, and then moving it into the annex directory and setting up@@ -160,14 +168,14 @@ 	-- fromAnnex could fail if the file ownership is weird 	tryharder :: IOException -> Annex () 	tryharder _ = do-		src <- inRepo $ gitAnnexLocation key+		src <- calcRepo $ gitAnnexLocation key 		liftIO $ moveFile src file  {- Creates the symlink to the annexed content, returns the link target. -} link :: FilePath -> Key -> Bool -> Annex String link file key hascontent = handle (undo file key) $ do-	l <- calcGitLink file key-	makeAnnexLink l file+	l <- inRepo $ gitAnnexLink file key+	replaceFile file $ makeAnnexLink l  #ifndef __ANDROID__ 	when hascontent $ do@@ -198,7 +206,9 @@ 	when hascontent $ 		logStatus key InfoPresent 	ifM (isDirect <&&> pure hascontent)-		( stageSymlink file =<< hashSymlink =<< calcGitLink file key+		( do+			l <- inRepo $ gitAnnexLink file key+			stageSymlink file =<< hashSymlink l 		, ifM (coreSymlinks <$> Annex.getGitConfig) 			( do 				_ <- link file key hascontent
Command/AddUnused.hs view
@@ -15,7 +15,7 @@  def :: [Command] def = [notDirect $ command "addunused" (paramRepeating paramNumRange)-	seek "add back unused files"]+	seek SectionMaintenance "add back unused files"]  seek :: [CommandSeek] seek = [withUnusedMaps start]
Command/AddUrl.hs view
@@ -26,7 +26,8 @@  def :: [Command] def = [notBareRepo $ withOptions [fileOption, pathdepthOption, relaxedOption] $-	command "addurl" (paramRepeating paramUrl) seek "add urls to annex"]+	command "addurl" (paramRepeating paramUrl) seek+		SectionCommon "add urls to annex"]  fileOption :: Option fileOption = Option.field [] "file" paramFile "specify what file the url is added to"
Command/Assistant.hs view
@@ -20,7 +20,8 @@ def :: [Command] def = [noRepo checkAutoStart $ dontCheck repoExists $ 	withOptions [Command.Watch.foregroundOption, Command.Watch.stopOption, autoStartOption] $ -	command "assistant" paramNothing seek "automatically handle changes"]+	command "assistant" paramNothing seek SectionCommon+		"automatically handle changes"]  autoStartOption :: Option autoStartOption = Option.flag [] "autostart" "start in known repositories"
Command/Commit.hs view
@@ -14,7 +14,7 @@  def :: [Command] def = [command "commit" paramNothing seek-	"commits any staged changes to the git-annex branch"]+	SectionPlumbing "commits any staged changes to the git-annex branch"]  seek :: [CommandSeek] seek = [withNothing start]
Command/ConfigList.hs view
@@ -13,7 +13,7 @@  def :: [Command] def = [noCommit $ command "configlist" paramNothing seek-	"outputs relevant git configuration"]+	SectionPlumbing "outputs relevant git configuration"]  seek :: [CommandSeek] seek = [withNothing start]
Command/Copy.hs view
@@ -15,7 +15,7 @@  def :: [Command] def = [withOptions Command.Move.options $ command "copy" paramPaths seek-	"copy content of files to/from another repository"]+	SectionCommon "copy content of files to/from another repository"]  seek :: [CommandSeek] seek = [withField Command.Move.toOption Remote.byNameWithUUID $ \to ->
Command/Dead.hs view
@@ -17,7 +17,7 @@  def :: [Command] def = [command "dead" (paramRepeating paramRemote) seek-	"hide a lost repository"]+	SectionSetup "hide a lost repository"]  seek :: [CommandSeek] seek = [withWords start]@@ -31,6 +31,10 @@  perform :: UUID -> CommandPerform perform uuid = do+	markDead uuid+	next $ return True++markDead :: UUID -> Annex ()+markDead uuid = do 	trustSet uuid DeadTrusted 	groupSet uuid S.empty-	next $ return True
Command/Describe.hs view
@@ -14,7 +14,7 @@  def :: [Command] def = [command "describe" (paramPair paramRemote paramDesc) seek-	"change description of a repository"]+	SectionSetup "change description of a repository"]  seek :: [CommandSeek] seek = [withWords start]
Command/Direct.hs view
@@ -18,7 +18,8 @@  def :: [Command] def = [notBareRepo $ -	command "direct" paramNothing seek "switch repository to direct mode"]+	command "direct" paramNothing seek+		SectionSetup "switch repository to direct mode"]  seek :: [CommandSeek] seek = [withNothing start]
Command/Drop.hs view
@@ -21,7 +21,7 @@  def :: [Command] def = [withOptions [fromOption] $ command "drop" paramPaths seek-	"indicate content of files not currently wanted"]+	SectionCommon "indicate content of files not currently wanted"]  fromOption :: Option fromOption = Option.field ['f'] "from" paramRemote "drop content from a remote"@@ -31,7 +31,7 @@ 	withFilesInGit $ whenAnnexed $ start from]  start :: Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart-start from file (key, _) = autoCopiesWith file key (>) $ \numcopies ->+start from file (key, _) = checkDropAuto from file key $ \numcopies -> 	stopUnless (checkAuto $ wantDrop False (Remote.uuid <$> from) (Just file)) $ 		case from of 			Nothing -> startLocal file numcopies key Nothing@@ -138,3 +138,24 @@   where 	unsafe = showNote "unsafe" 	hint = showLongNote "(Use --force to override this check, or adjust annex.numcopies.)"++{- In auto mode, only runs the action if there are enough copies+ - copies on other semitrusted repositories.+ -+ - Passes any numcopies attribute of the file on to the action as an+ - optimisation. -}+checkDropAuto :: Maybe Remote -> FilePath -> Key -> (Maybe Int -> CommandStart) -> CommandStart+checkDropAuto mremote file key a = do+	numcopiesattr <- numCopies file+	Annex.getState Annex.auto >>= auto numcopiesattr+  where+	auto numcopiesattr False = a numcopiesattr+	auto numcopiesattr True = do+		needed <- getNumCopies numcopiesattr+		locs <- Remote.keyLocations key+		uuid <- getUUID+		let remoteuuid = fromMaybe uuid $ Remote.uuid <$> mremote+		locs' <- trustExclude UnTrusted $ filter (/= remoteuuid) locs+		if length locs' >= needed+			then a numcopiesattr+			else stop
Command/DropKey.hs view
@@ -16,7 +16,7 @@  def :: [Command] def = [noCommit $ command "dropkey" (paramRepeating paramKey) seek-	"drops annexed content for specified keys"] +	SectionPlumbing "drops annexed content for specified keys"]   seek :: [CommandSeek] seek = [withKeys start]
Command/DropUnused.hs view
@@ -19,7 +19,7 @@ def :: [Command] def = [withOptions [Command.Drop.fromOption] $ 	command "dropunused" (paramRepeating paramNumRange)-		seek "drop unused file content"]+		seek SectionMaintenance "drop unused file content"]  seek :: [CommandSeek] seek = [withUnusedMaps start]
Command/Find.hs view
@@ -21,7 +21,7 @@  def :: [Command] def = [noCommit $ withOptions [formatOption, print0Option] $-	command "find" paramPaths seek "lists available files"]+	command "find" paramPaths seek SectionQuery "lists available files"]  formatOption :: Option formatOption = Option.field [] "format" paramFormat "control format of output"
Command/Fix.hs view
@@ -10,11 +10,10 @@ import Common.Annex import Command import qualified Annex.Queue-import Annex.Content  def :: [Command] def = [notDirect $ noCommit $ command "fix" paramPaths seek-	"fix up symlinks to point to annexed content"]+	SectionMaintenance "fix up symlinks to point to annexed content"]  seek :: [CommandSeek] seek = [withFilesInGit $ whenAnnexed start]@@ -22,7 +21,7 @@ {- Fixes the symlink to an annexed file. -} start :: FilePath -> (Key, Backend) -> CommandStart start file (key, _) = do-	link <- calcGitLink file key+	link <- inRepo $ gitAnnexLink file key 	stopUnless ((/=) (Just link) <$> liftIO (catchMaybeIO $ readSymbolicLink file)) $ do 		showStart "fix" file 		next $ perform file link
Command/FromKey.hs view
@@ -16,7 +16,7 @@ def :: [Command] def = [notDirect $ notBareRepo $ 	command "fromkey" (paramPair paramKey paramPath) seek-		"adds a file using a specific key"]+		SectionPlumbing "adds a file using a specific key"]  seek :: [CommandSeek] seek = [withWords start]@@ -33,7 +33,7 @@  perform :: Key -> FilePath -> CommandPerform perform key file = do-	link <- calcGitLink file key+	link <- inRepo $ gitAnnexLink file key 	liftIO $ createDirectoryIfMissing True (parentDir file) 	liftIO $ createSymbolicLink link file 	next $ cleanup file
Command/Fsck.hs view
@@ -36,7 +36,7 @@  def :: [Command] def = [withOptions options $ command "fsck" paramPaths seek-	"check for problems"]+	SectionMaintenance "check for problems"]  fromOption :: Option fromOption = Option.field ['f'] "from" paramRemote "check remote"@@ -188,7 +188,7 @@  -} fixLink :: Key -> FilePath -> Annex Bool fixLink key file = do-	want <- calcGitLink file key+	want <- inRepo $ gitAnnexLink file key 	have <- getAnnexLinkTarget file 	maybe noop (go want) have 	return True@@ -223,7 +223,7 @@ 	{- Since we're checking that a key's file is present, throw 	 - in a permission fixup here too. -} 	when (present && not direct) $ do-		file <- inRepo $ gitAnnexLocation key+		file <- calcRepo $ gitAnnexLocation key 		freezeContent file 		freezeContentDir file @@ -281,7 +281,7 @@ checkKeySize key = ifM isDirect 	( return True 	, do-		file <- inRepo $ gitAnnexLocation key+		file <- calcRepo $ gitAnnexLocation key 		ifM (liftIO $ doesFileExist file) 			( checkKeySizeOr badContent key file 			, return True@@ -322,7 +322,7 @@  -} checkBackend :: Backend -> Key -> Annex Bool checkBackend backend key = do-	file <- inRepo $ gitAnnexLocation key+	file <- calcRepo $ gitAnnexLocation key 	ifM isDirect 		( ifM (goodContent key file) 			( checkBackendOr' (badContentDirect file) backend key file@@ -443,14 +443,14 @@  -} recordFsckTime :: Key -> Annex () recordFsckTime key = do-	parent <- parentDir <$> inRepo (gitAnnexLocation key)+	parent <- parentDir <$> calcRepo (gitAnnexLocation key) 	liftIO $ void $ tryIO $ do 		touchFile parent 		setSticky parent  getFsckTime :: Key -> Annex (Maybe EpochTime) getFsckTime key = do-	parent <- parentDir <$> inRepo (gitAnnexLocation key)+	parent <- parentDir <$> calcRepo (gitAnnexLocation key) 	liftIO $ catchDefaultIO Nothing $ do 		s <- getFileStatus parent 		return $ if isSticky $ fileMode s
Command/Get.hs view
@@ -17,7 +17,7 @@  def :: [Command] def = [withOptions [Command.Move.fromOption] $ command "get" paramPaths seek-	"make content of annexed files available"]+	SectionCommon "make content of annexed files available"]  seek :: [CommandSeek] seek = [withField Command.Move.fromOption Remote.byNameWithUUID $ \from ->
Command/Group.hs view
@@ -16,7 +16,8 @@ import qualified Data.Set as S  def :: [Command]-def = [command "group" (paramPair paramRemote paramDesc) seek "add a repository to a group"]+def = [command "group" (paramPair paramRemote paramDesc) seek+	SectionCommon "add a repository to a group"]  seek :: [CommandSeek] seek = [withWords start]
Command/Help.hs view
@@ -18,21 +18,30 @@ import qualified Command.Sync import qualified Command.Whereis import qualified Command.Fsck+import GitAnnex.Options +import System.Console.GetOpt+ def :: [Command]-def = [noCommit $ noRepo showHelp $ dontCheck repoExists $-	command "help" paramNothing seek "display help"]+def = [noCommit $ noRepo showGeneralHelp $ dontCheck repoExists $+	command "help" paramNothing seek SectionUtility "display help"]  seek :: [CommandSeek] seek = [withWords start]  start :: [String] -> CommandStart+start ["options"] = do+	liftIO showCommonOptions+	stop start _ = do-	liftIO showHelp+	liftIO showGeneralHelp 	stop -showHelp :: IO ()-showHelp = liftIO $ putStrLn $ unlines+showCommonOptions :: IO ()+showCommonOptions = putStrLn $ usageInfo "Common options:" options++showGeneralHelp :: IO ()+showGeneralHelp = putStrLn $ unlines 	[ "The most commonly used git-annex commands are:" 	, unlines $ map cmdline $ concat 		[ Command.Init.def@@ -45,7 +54,7 @@ 		, Command.Whereis.def 		, Command.Fsck.def 		]-	, "Run git-annex without any options for a complete command and option list."+	, "Run git-annex without any options for a complete command list." 	]   where 	cmdline c = "\t" ++ cmdname c ++ "\t" ++ cmddesc c
Command/Import.hs view
@@ -14,7 +14,7 @@  def :: [Command] def = [notDirect $ notBareRepo $ command "import" paramPaths seek-	"move and add files from outside git working copy"]+	SectionCommon "move and add files from outside git working copy"]  seek :: [CommandSeek] seek = [withPathContents start]
Command/InAnnex.hs view
@@ -13,7 +13,7 @@  def :: [Command] def = [noCommit $ command "inannex" (paramRepeating paramKey) seek-	"checks if keys are present in the annex"]+	SectionPlumbing "checks if keys are present in the annex"]  seek :: [CommandSeek] seek = [withKeys start]
Command/Indirect.hs view
@@ -22,7 +22,7 @@  def :: [Command] def = [notBareRepo $ command "indirect" paramNothing seek-	"switch repository to indirect mode"]+	SectionSetup "switch repository to indirect mode"]  seek :: [CommandSeek] seek = [withNothing start]@@ -82,13 +82,13 @@ 		cleandirect k -- clean before content directory gets frozen 		whenM (liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f) $ do 			moveAnnex k f-			l <- calcGitLink f k+			l <- inRepo $ gitAnnexLink f k 			liftIO $ createSymbolicLink l f 		showEndOk  	cleandirect k = do-		liftIO . nukeFile =<< inRepo (gitAnnexInodeCache k)-		liftIO . nukeFile =<< inRepo (gitAnnexMapping k)+		liftIO . nukeFile =<< calcRepo (gitAnnexInodeCache k)+		liftIO . nukeFile =<< calcRepo (gitAnnexMapping k)  cleanup :: CommandCleanup cleanup = do
Command/Init.hs view
@@ -13,7 +13,7 @@ 	 def :: [Command] def = [dontCheck repoExists $-	command "init" paramDesc seek "initialize git-annex"]+	command "init" paramDesc seek SectionSetup "initialize git-annex"]  seek :: [CommandSeek] seek = [withWords start]
Command/InitRemote.hs view
@@ -20,7 +20,7 @@ def :: [Command] def = [command "initremote" 	(paramPair paramName $ paramOptional $ paramRepeating paramKeyValue)-	seek "sets up a special (non-git) remote"]+	seek SectionSetup "sets up a special (non-git) remote"]  seek :: [CommandSeek] seek = [withWords start]
Command/Lock.hs view
@@ -12,7 +12,8 @@ import qualified Annex.Queue 	 def :: [Command]-def = [notDirect $ command "lock" paramPaths seek "undo unlock command"]+def = [notDirect $ command "lock" paramPaths seek SectionCommon+	"undo unlock command"]  seek :: [CommandSeek] seek = [withFilesUnlocked start, withFilesUnlockedToBeCommitted start]
Command/Log.hs view
@@ -37,7 +37,7 @@  def :: [Command] def = [withOptions options $-	command "log" paramPaths seek "shows location log"]+	command "log" paramPaths seek SectionQuery "shows location log"]  options :: [Option] options = passthruOptions ++ [gourceOption]
Command/Map.hs view
@@ -28,7 +28,8 @@  def :: [Command] def = [dontCheck repoExists $-	command "map" paramNothing seek "generate map of repositories"]+	command "map" paramNothing seek SectionQuery+		"generate map of repositories"]  seek :: [CommandSeek] seek = [withNothing start]
Command/Merge.hs view
@@ -12,8 +12,8 @@ import qualified Annex.Branch  def :: [Command]-def = [command "merge" paramNothing seek-		"auto-merge remote changes into git-annex branch"]+def = [command "merge" paramNothing seek SectionMaintenance+	"auto-merge remote changes into git-annex branch"]  seek :: [CommandSeek] seek = [withNothing start]
Command/Migrate.hs view
@@ -19,7 +19,8 @@  def :: [Command] def = [notDirect $ -	command "migrate" paramPaths seek "switch data to different backend"]+	command "migrate" paramPaths seek+		SectionUtility "switch data to different backend"]  seek :: [CommandSeek] seek = [withFilesInGit $ whenAnnexed start]@@ -62,7 +63,7 @@ 	go newkey = stopUnless (Command.ReKey.linkKey oldkey newkey) $ 		next $ Command.ReKey.cleanup file oldkey newkey 	genkey = do-		content <- inRepo $ gitAnnexLocation oldkey+		content <- calcRepo $ gitAnnexLocation oldkey 		let source = KeySource 			{ keyFilename = file 			, contentLocation = content
Command/Move.hs view
@@ -20,7 +20,7 @@  def :: [Command] def = [withOptions options $ command "move" paramPaths seek-	"move content of files to/from another repository"]+	SectionCommon "move content of files to/from another repository"]  fromOption :: Option fromOption = Option.field ['f'] "from" paramRemote "source remote"
Command/PreCommit.hs view
@@ -17,7 +17,8 @@ import Git.Sha  def :: [Command]-def = [command "pre-commit" paramPaths seek "run by git pre-commit hook"]+def = [command "pre-commit" paramPaths seek SectionPlumbing+	"run by git pre-commit hook"]  seek :: [CommandSeek] seek =
Command/ReKey.hs view
@@ -20,7 +20,7 @@ def :: [Command] def = [notDirect $ command "rekey" 	(paramOptional $ paramRepeating $ paramPair paramPath paramKey)-	seek "change keys used for files"]+	seek SectionPlumbing "change keys used for files"]  seek :: [CommandSeek] seek = [withPairs start]@@ -49,7 +49,7 @@ {- Make a hard link to the old key content, to avoid wasting disk space. -} linkKey :: Key -> Key -> Annex Bool linkKey oldkey newkey = getViaTmpUnchecked newkey $ \tmp -> do-	src <- inRepo $ gitAnnexLocation oldkey+	src <- calcRepo $ gitAnnexLocation oldkey 	ifM (liftIO $ doesFileExist tmp) 		( return True 		, ifM crippledFileSystem
Command/RecvKey.hs view
@@ -11,6 +11,7 @@ import Command import CmdLine import Annex.Content+import Annex import Utility.Rsync import Logs.Transfer import Command.SendKey (fieldTransfer)@@ -21,7 +22,7 @@  def :: [Command] def = [noCommit $ command "recvkey" paramKey seek-	"runs rsync in server mode to receive content"]+	SectionPlumbing "runs rsync in server mode to receive content"]  seek :: [CommandSeek] seek = [withKeys start]@@ -40,13 +41,16 @@ 			) 	)   where-	go tmp = ifM (liftIO $ rsyncServerReceive tmp)-		( ifM (isJust <$> Fields.getField Fields.direct)-			( directcheck tmp-			, return True+	go tmp = do+		opts <- filterRsyncSafeOptions . maybe [] words+			<$> getField "RsyncOptions"+		ifM (liftIO $ rsyncServerReceive (map Param opts) tmp)+			( ifM (isJust <$> Fields.getField Fields.direct)+				( directcheck tmp+				, return True+				)+			, return False 			)-		, return False-		) 	{- If the sending repository uses direct mode, the file 	 - it sends could be modified as it's sending it. So check 	 - that the right size file was received, and that the key/value
Command/Reinject.hs view
@@ -15,7 +15,7 @@  def :: [Command] def = [notDirect $ command "reinject" (paramPair "SRC" "DEST") seek-	"sets content of annexed file"]+	SectionUtility "sets content of annexed file"]  seek :: [CommandSeek] seek = [withWords start]
Command/Semitrust.hs view
@@ -14,7 +14,7 @@  def :: [Command] def = [command "semitrust" (paramRepeating paramRemote) seek-	"return repository to default trust level"]+	SectionSetup "return repository to default trust level"]  seek :: [CommandSeek] seek = [withWords start]
Command/SendKey.hs view
@@ -10,25 +10,30 @@ import Common.Annex import Command import Annex.Content+import Annex import Utility.Rsync import Logs.Transfer import qualified Fields+import Utility.Metered  def :: [Command] def = [noCommit $ command "sendkey" paramKey seek-	"runs rsync in server mode to send content"]+	SectionPlumbing "runs rsync in server mode to send content"]  seek :: [CommandSeek] seek = [withKeys start]  start :: Key -> CommandStart-start key = ifM (inAnnex key)-	( fieldTransfer Upload key $ \_p ->-		sendAnnex key rollback $ liftIO . rsyncServerSend-	, do-		warning "requested key is not present"-		liftIO exitFailure-	)+start key = do+	opts <- filterRsyncSafeOptions . maybe [] words+		<$> getField "RsyncOptions"+	ifM (inAnnex key)+		( fieldTransfer Upload key $ \_p ->+			sendAnnex key rollback $ liftIO . rsyncServerSend (map Param opts)+		, do+			warning "requested key is not present"+			liftIO exitFailure+		)   where 	{- No need to do any rollback; when sendAnnex fails, a nonzero 	 - exit will be propigated, and the remote will know the transfer
Command/Status.hs view
@@ -58,7 +58,7 @@  def :: [Command] def = [command "status" (paramOptional paramPaths) seek-	"shows status information about the annex"]+	SectionQuery "shows status information about the annex"]  seek :: [CommandSeek] seek = [withWords start]
Command/Sync.hs view
@@ -14,7 +14,6 @@ import qualified Annex import qualified Annex.Branch import qualified Annex.Queue-import Annex.Content import Annex.Direct import Annex.CatFile import Annex.Link@@ -34,7 +33,7 @@  def :: [Command] def = [command "sync" (paramOptional (paramRepeating paramRemote))-	[seek] "synchronize local repository with remotes"]+	[seek] SectionCommon "synchronize local repository with remotes"]  -- syncing involves several operations, any of which can independently fail seek :: CommandSeek@@ -268,7 +267,7 @@ 		[Just SymlinkBlob, Nothing] 	makelink (Just key) = do 		let dest = mergeFile file key-		l <- calcGitLink dest key+		l <- inRepo $ gitAnnexLink dest key 		liftIO $ nukeFile dest 		addAnnexLink l dest 		whenM (isDirect) $
Command/Test.hs view
@@ -11,7 +11,8 @@  def :: [Command] def = [ dontCheck repoExists $-	command "test" paramNothing seek "run built-in test suite"]+	command "test" paramNothing seek SectionPlumbing+		"run built-in test suite"]  seek :: [CommandSeek] seek = [withWords start]
Command/TransferInfo.hs view
@@ -13,9 +13,10 @@ import Logs.Transfer import Types.Key import qualified Fields+import Utility.Metered  def :: [Command]-def = [noCommit $ command "transferinfo" paramKey seek+def = [noCommit $ command "transferinfo" paramKey seek SectionPlumbing 	"updates sender on number of bytes of content received"]  seek :: [CommandSeek]@@ -50,10 +51,14 @@ 			(update, tfile, _) <- mkProgressUpdater t info 			liftIO $ mapM_ void 				[ tryIO $ forever $ do-					bytes <- readish <$> getLine-					maybe (error "transferinfo protocol error") update bytes+					bytes <- readUpdate+					maybe (error "transferinfo protocol error")+						(update . toBytesProcessed) bytes 				, tryIO $ removeFile tfile 				, exitSuccess 				] 	stop start _ = error "wrong number of parameters"++readUpdate :: IO (Maybe Integer)+readUpdate = readish <$> getLine
Command/TransferKey.hs view
@@ -20,7 +20,7 @@  def :: [Command] def = [withOptions options $-	noCommit $ command "transferkey" paramKey seek+	noCommit $ command "transferkey" paramKey seek SectionPlumbing 		"transfers a key from or to a remote"]  options :: [Option]
Command/TransferKeys.hs view
@@ -23,7 +23,8 @@  def :: [Command] def = [withOptions options $-	command "transferkeys" paramNothing seek "plumbing; transfers keys"]+	command "transferkeys" paramNothing seek+	SectionPlumbing "transfers keys"]  options :: [Option] options = [readFdOption, writeFdOption]@@ -83,8 +84,9 @@ 						(TransferRequest direction remote key file) 			_ -> sendresult False 		go rest-	go [] = return ()-	go _ = error "transferkeys protocol error"+	go [] = noop+	go [""] = noop+	go v = error $ "transferkeys protocol error: " ++ show v  	readrequests = liftIO $ split fieldSep <$> hGetContents readh 	sendresult b = liftIO $ do
Command/Trust.hs view
@@ -13,7 +13,8 @@ import Logs.Trust  def :: [Command]-def = [command "trust" (paramRepeating paramRemote) seek "trust a repository"]+def = [command "trust" (paramRepeating paramRemote) seek+	SectionSetup "trust a repository"]  seek :: [CommandSeek] seek = [withWords start]
Command/Unannex.hs view
@@ -17,7 +17,8 @@  def :: [Command] def = [notDirect $-	command "unannex" paramPaths seek "undo accidential add command"]+	command "unannex" paramPaths seek SectionUtility+		"undo accidential add command"]  seek :: [CommandSeek] seek = [withFilesInGit $ whenAnnexed start]@@ -59,7 +60,7 @@   where 	goFast = do 		-- fast mode: hard link to content in annex-		src <- inRepo $ gitAnnexLocation key+		src <- calcRepo $ gitAnnexLocation key 		-- creating a hard link could fall; fall back to non fast mode 		ifM (liftIO $ catchBoolIO $ createLink src file >> return True) 			( thawContent file
Command/Ungroup.hs view
@@ -16,7 +16,8 @@ import qualified Data.Set as S  def :: [Command]-def = [command "ungroup" (paramPair paramRemote paramDesc) seek "remove a repository from a group"]+def = [command "ungroup" (paramPair paramRemote paramDesc) seek+	SectionSetup "remove a repository from a group"]  seek :: [CommandSeek] seek = [withWords start]
Command/Uninit.hs view
@@ -19,7 +19,7 @@  def :: [Command] def = [notDirect $ addCheck check $ command "uninit" paramPaths seek -	"de-initialize git-annex and clean out repository"]+	SectionUtility "de-initialize git-annex and clean out repository"]  check :: Annex () check = do
Command/Unlock.hs view
@@ -18,7 +18,7 @@ 	, c "edit" "same as unlock" 	]   where-	c n = notDirect . command n paramPaths seek+	c n = notDirect . command n paramPaths seek SectionCommon  seek :: [CommandSeek] seek = [withFilesInGit $ whenAnnexed start]@@ -35,7 +35,7 @@ 	unlessM (inAnnex key) $ error "content not present" 	unlessM (checkDiskSpace Nothing key 0) $ error "cannot unlock" -	src <- inRepo $ gitAnnexLocation key+	src <- calcRepo $ gitAnnexLocation key 	tmpdest <- fromRepo $ gitAnnexTmpLocation key 	liftIO $ createDirectoryIfMissing True (parentDir tmpdest) 	showAction "copying"
Command/Untrust.hs view
@@ -14,7 +14,7 @@  def :: [Command] def = [command "untrust" (paramRepeating paramRemote) seek-	"do not trust a repository"]+	SectionSetup "do not trust a repository"]  seek :: [CommandSeek] seek = [withWords start]
Command/Unused.hs view
@@ -37,7 +37,7 @@  def :: [Command] def = [withOptions [fromOption] $ command "unused" paramNothing seek-	"look for unused file content"]+	SectionMaintenance "look for unused file content"]  fromOption :: Option fromOption = Option.field ['f'] "from" paramRemote "remote to check for unused content"
Command/Upgrade.hs view
@@ -14,7 +14,8 @@  def :: [Command] def = [dontCheck repoExists $ -- because an old version may not seem to exist-	command "upgrade" paramNothing seek "upgrade repository layout"]+	command "upgrade" paramNothing seek+		SectionMaintenance "upgrade repository layout"]  seek :: [CommandSeek] seek = [withNothing start]
Command/Version.hs view
@@ -15,7 +15,7 @@  def :: [Command] def = [noCommit $ noRepo showPackageVersion $ dontCheck repoExists $-	command "version" paramNothing seek "show version info"]+	command "version" paramNothing seek SectionQuery "show version info"]  seek :: [CommandSeek] seek = [withNothing start]
Command/Vicfg.hs view
@@ -25,7 +25,7 @@  def :: [Command] def = [command "vicfg" paramNothing seek-	"edit git-annex's configuration"]+	SectionSetup "edit git-annex's configuration"]  seek :: [CommandSeek] seek = [withNothing start]
Command/Watch.hs view
@@ -14,7 +14,7 @@  def :: [Command] def = [notBareRepo $ withOptions [foregroundOption, stopOption] $ -	command "watch" paramNothing seek "watch for changes"]+	command "watch" paramNothing seek SectionCommon "watch for changes"]  seek :: [CommandSeek] seek = [withFlag stopOption $ \stopdaemon ->
Command/WebApp.hs view
@@ -31,7 +31,7 @@  def :: [Command] def = [noCommit $ noRepo startNoRepo $ dontCheck repoExists $ notBareRepo $-	command "webapp" paramNothing seek "launch webapp"]+	command "webapp" paramNothing seek SectionCommon "launch webapp"]  seek :: [CommandSeek] seek = [withNothing start]@@ -103,7 +103,7 @@ 	v <- newEmptyMVar 	let callback a = Just $ a v 	runAssistant d $ do-		startNamedThread (Just urlrenderer) $+		startNamedThread urlrenderer $ 			webAppThread d urlrenderer True  				(callback signaler) 				(callback mainthread)
Command/Whereis.hs view
@@ -16,7 +16,7 @@  def :: [Command] def = [noCommit $ command "whereis" paramPaths seek-	"lists repositories that have file content"]+	SectionQuery "lists repositories that have file content"]  seek :: [CommandSeek] seek = [withValue (remoteMap id) $ \m ->
Command/XMPPGit.hs view
@@ -13,7 +13,8 @@  def :: [Command] def = [noCommit $ noRepo xmppGitRelay $ dontCheck repoExists $-	command "xmppgit" paramNothing seek "git to XMPP relay (internal use)"]+	command "xmppgit" paramNothing seek+		SectionPlumbing "git to XMPP relay"]  seek :: [CommandSeek] seek = [withWords start]
Common/Annex.hs view
@@ -3,6 +3,6 @@ import Common as X import Types as X import Types.UUID as X (toUUID, fromUUID)-import Annex as X (gitRepo, inRepo, fromRepo)+import Annex as X (gitRepo, inRepo, fromRepo, calcRepo) import Locations as X import Messages as X
Creds.hs view
@@ -92,7 +92,7 @@ 		Just credpair -> do 			writeCacheCredPair credpair storage 			return $ Just credpair-		_ -> do error $ "bad creds"+		_ -> error "bad creds"  {- Gets a CredPair from the environment. -} getEnvCredPair :: CredPairStorage -> IO (Maybe CredPair)
Crypto.hs view
@@ -26,12 +26,11 @@ 	GpgOpts(..), 	getGpgOpts, -	prop_hmacWithCipher_sane+	prop_HmacSha1WithCipher_sane ) where  import qualified Data.ByteString.Lazy as L import Data.ByteString.Lazy.UTF8 (fromString)-import Data.Digest.Pure.SHA import Control.Applicative  import Common.Annex@@ -40,16 +39,20 @@ import Types.Key import Types.Crypto -{- The beginning of a Cipher is used for HMAC; the remainder- - is used as the GPG symmetric encryption passphrase.+{- The beginning of a Cipher is used for MAC'ing; the remainder is used+ - as the GPG symmetric encryption passphrase. Note that the cipher+ - itself is base-64 encoded, hence the string is longer than+ - 'cipherSize': 683 characters, padded to 684.  -- - HMAC SHA1 needs only 64 bytes. The rest of the HMAC key is for expansion,- - perhaps to HMAC SHA512, which needs 128 bytes (ideally).- - It also provides room the Cipher to contain data in a form like base64,- - which does not pack a full byte of entropy into a byte of data.+ - The 256 first characters that feed the MAC represent at best 192+ - bytes of entropy.  However that's more than enough for both the+ - default MAC algorithm, namely HMAC-SHA1, and the "strongest"+ - currently supported, namely HMAC-SHA512, which respectively need+ - (ideally) 64 and 128 bytes of entropy.  -- - 256 bytes is enough for gpg's symetric cipher; unlike weaker public key- - crypto, the key does not need to be too large.+ - The remaining characters (320 bytes of entropy) is enough for GnuPG's+ - symetric cipher; unlike weaker public key crypto, the key does not+ - need to be too large.  -} cipherBeginning :: Int cipherBeginning = 256@@ -60,8 +63,8 @@ cipherPassphrase :: Cipher -> String cipherPassphrase (Cipher c) = drop cipherBeginning c -cipherHmac :: Cipher -> String-cipherHmac (Cipher c) = take cipherBeginning c+cipherMac :: Cipher -> String+cipherMac (Cipher c) = take cipherBeginning c  {- Creates a new Cipher, encrypted to the specified key id. -} genEncryptedCipher :: String -> IO StorableCipher@@ -97,7 +100,7 @@ encryptCipher (Cipher c) (KeyIds ks) = do 	-- gpg complains about duplicate recipient keyids 	let ks' = nub $ sort ks-	encipher <- Gpg.pipeStrict ([ Params "--encrypt" ] ++ recipients ks') c+	encipher <- Gpg.pipeStrict (Params "--encrypt" : recipients ks') c 	return $ EncryptedCipher encipher (KeyIds ks')   where 	recipients l = force_recipients :@@ -115,10 +118,10 @@ {- Generates an encrypted form of a Key. The encryption does not need to be  - reversable, nor does it need to be the same type of encryption used  - on content. It does need to be repeatable. -}-encryptKey :: Cipher -> Key -> Key-encryptKey c k = Key-	{ keyName = hmacWithCipher c (key2file k)-	, keyBackendName = "GPGHMACSHA1"+encryptKey :: Mac -> Cipher -> Key -> Key+encryptKey mac c k = Key+	{ keyName = macWithCipher mac c (key2file k)+	, keyBackendName = "GPG" ++ showMac mac 	, keySize = Nothing -- size and mtime omitted 	, keyMtime = Nothing -- to avoid leaking data 	}@@ -147,13 +150,13 @@ decrypt :: Cipher -> Feeder -> Reader a -> IO a decrypt = Gpg.feedRead [Param "--decrypt"] . cipherPassphrase -hmacWithCipher :: Cipher -> String -> String-hmacWithCipher c = hmacWithCipher' (cipherHmac c) -hmacWithCipher' :: String -> String -> String-hmacWithCipher' c s = showDigest $ hmacSha1 (fromString c) (fromString s)+macWithCipher :: Mac -> Cipher -> String -> String+macWithCipher mac c = macWithCipher' mac (cipherMac c)+macWithCipher' :: Mac -> String -> String -> String+macWithCipher' mac c s = calcMac mac (fromString c) (fromString s) -{- Ensure that hmacWithCipher' returns the same thing forevermore. -}-prop_hmacWithCipher_sane :: Bool-prop_hmacWithCipher_sane = known_good == hmacWithCipher' "foo" "bar"+{- Ensure that macWithCipher' returns the same thing forevermore. -}+prop_HmacSha1WithCipher_sane :: Bool+prop_HmacSha1WithCipher_sane = known_good == macWithCipher' HmacSha1 "foo" "bar"   where 	known_good = "46b4ec586117154dacd49d664e5d63fdc88efb51"
GitAnnex.hs view
@@ -9,18 +9,10 @@  module GitAnnex where -import System.Console.GetOpt--import Common.Annex-import qualified Git.Config import qualified Git.CurrentRepo import CmdLine import Command-import Types.TrustLevel-import qualified Annex-import qualified Remote-import qualified Limit-import qualified Option+import GitAnnex.Options  import qualified Command.Add import qualified Command.Unannex@@ -145,49 +137,8 @@ #endif 	] -options :: [Option]-options = Option.common ++-	[ Option ['N'] ["numcopies"] (ReqArg setnumcopies paramNumber)-		"override default number of copies"-	, Option [] ["trust"] (trustArg Trusted)-		"override trust setting"-	, Option [] ["semitrust"] (trustArg SemiTrusted)-		"override trust setting back to default"-	, Option [] ["untrust"] (trustArg UnTrusted)-		"override trust setting to untrusted"-	, Option ['c'] ["config"] (ReqArg setgitconfig "NAME=VALUE")-		"override git configuration setting"-	, Option ['x'] ["exclude"] (ReqArg Limit.addExclude paramGlob)-		"skip files matching the glob pattern"-	, Option ['I'] ["include"] (ReqArg Limit.addInclude paramGlob)-		"don't skip files matching the glob pattern"-	, Option ['i'] ["in"] (ReqArg Limit.addIn paramRemote)-		"skip files not present in a remote"-	, Option ['C'] ["copies"] (ReqArg Limit.addCopies paramNumber)-		"skip files with fewer copies"-	, Option ['B'] ["inbackend"] (ReqArg Limit.addInBackend paramName)-		"skip files not using a key-value backend"-	, Option [] ["inallgroup"] (ReqArg Limit.addInAllGroup paramGroup)-		"skip files not present in all remotes in a group"-	, Option [] ["largerthan"] (ReqArg Limit.addLargerThan paramSize)-		"skip files larger than a size"-	, Option [] ["smallerthan"] (ReqArg Limit.addSmallerThan paramSize)-		"skip files smaller than a size"-	, Option ['T'] ["time-limit"] (ReqArg Limit.addTimeLimit paramTime)-		"stop after the specified amount of time"-	, Option [] ["trust-glacier"] (NoArg (Annex.setFlag "trustglacier"))-		"Trust Amazon Glacier inventory"-	] ++ Option.matcher-  where-	setnumcopies v = maybe noop-		(\n -> Annex.changeGitConfig $ \c -> c { annexNumCopies = n })-		(readish v)-	setgitconfig v = Annex.changeGitRepo =<< inRepo (Git.Config.store v)--	trustArg t = ReqArg (Remote.forceTrust t) paramRemote- header :: String-header = "Usage: git-annex command [option ..]"+header = "git-annex command [option ...]"  run :: [String] -> IO () run args = dispatch True args cmds options [] header Git.CurrentRepo.get
+ GitAnnex/Options.hs view
@@ -0,0 +1,60 @@+{- git-annex options+ -+ - Copyright 2010, 2013 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module GitAnnex.Options where++import System.Console.GetOpt++import Common.Annex+import qualified Git.Config+import Command+import Types.TrustLevel+import qualified Annex+import qualified Remote+import qualified Limit+import qualified Option++options :: [Option]+options = Option.common +++	[ Option ['N'] ["numcopies"] (ReqArg setnumcopies paramNumber)+		"override default number of copies"+	, Option [] ["trust"] (trustArg Trusted)+		"override trust setting"+	, Option [] ["semitrust"] (trustArg SemiTrusted)+		"override trust setting back to default"+	, Option [] ["untrust"] (trustArg UnTrusted)+		"override trust setting to untrusted"+	, Option ['c'] ["config"] (ReqArg setgitconfig "NAME=VALUE")+		"override git configuration setting"+	, Option ['x'] ["exclude"] (ReqArg Limit.addExclude paramGlob)+		"skip files matching the glob pattern"+	, Option ['I'] ["include"] (ReqArg Limit.addInclude paramGlob)+		"don't skip files matching the glob pattern"+	, Option ['i'] ["in"] (ReqArg Limit.addIn paramRemote)+		"skip files not present in a remote"+	, Option ['C'] ["copies"] (ReqArg Limit.addCopies paramNumber)+		"skip files with fewer copies"+	, Option ['B'] ["inbackend"] (ReqArg Limit.addInBackend paramName)+		"skip files not using a key-value backend"+	, Option [] ["inallgroup"] (ReqArg Limit.addInAllGroup paramGroup)+		"skip files not present in all remotes in a group"+	, Option [] ["largerthan"] (ReqArg Limit.addLargerThan paramSize)+		"skip files larger than a size"+	, Option [] ["smallerthan"] (ReqArg Limit.addSmallerThan paramSize)+		"skip files smaller than a size"+	, Option ['T'] ["time-limit"] (ReqArg Limit.addTimeLimit paramTime)+		"stop after the specified amount of time"+	, Option [] ["trust-glacier"] (NoArg (Annex.setFlag "trustglacier"))+		"Trust Amazon Glacier inventory"+	] ++ Option.matcher+  where+	setnumcopies v = maybe noop+		(\n -> Annex.changeGitConfig $ \c -> c { annexNumCopies = n })+		(readish v)+	setgitconfig v = Annex.changeGitRepo =<< inRepo (Git.Config.store v)++	trustArg t = ReqArg (Remote.forceTrust t) paramRemote
GitAnnexShell.hs view
@@ -15,6 +15,7 @@ import CmdLine import Command import Annex.UUID+import Annex (setField) import qualified Option import Fields import Utility.UserInfo@@ -62,7 +63,7 @@ 			expected ++ " but found " ++ s  header :: String-header = "Usage: git-annex-shell [-c] command [parameters ...] [option ..]"+header = "git-annex-shell [-c] command [parameters ...] [option ...]"  run :: [String] -> IO () run [] = failure@@ -86,32 +87,38 @@ builtin cmd dir params = do 	checkNotReadOnly cmd 	checkDirectory $ Just dir-	let (params', fieldparams) = partitionParams params-	let fields = filter checkField $ parseFields fieldparams-	dispatch False (cmd : params') cmds options fields header $+	let (params', fieldparams, opts) = partitionParams params+	    fields = filter checkField $ parseFields fieldparams+	    cmds' = map (newcmd $ unwords opts) cmds+	dispatch False (cmd : params') cmds' options fields header $ 		Git.Construct.repoAbsPath dir >>= Git.Construct.fromAbsPath+  where+	addrsyncopts opts seek k = setField "RsyncOptions" opts >> seek k+	newcmd opts c = c { cmdseek = map (addrsyncopts opts) (cmdseek c) }  external :: [String] -> IO () external params = do 	{- Normal git-shell commands all have the directory as their last 	 - parameter. -} 	let lastparam = lastMaybe =<< shellUnEscape <$> lastMaybe params+	    (params', _, _) = partitionParams params 	checkDirectory lastparam 	checkNotLimited-	unlessM (boolSystem "git-shell" $ map Param $ "-c":fst (partitionParams params)) $+	unlessM (boolSystem "git-shell" $ map Param $ "-c":params') $ 		error "git-shell failed" -{- Parameters between two -- markers are field settings, in the form:+{- Split the input list into 3 groups separated with a double dash --.+ - Parameters between two -- markers are field settings, in the form:  - field=value field=value  -- - Parameters after the last -- are ignored, these tend to be passed by- - rsync and not be useful.+ - Parameters after the last -- are the command itself and its arguments e.g.,+ - rsync --bandwidth=100.  -}-partitionParams :: [String] -> ([String], [String])+partitionParams :: [String] -> ([String], [String], [String]) partitionParams ps = case segment (== "--") ps of-	params:fieldparams:_ -> (params, fieldparams)-	[params] -> (params, [])-	_ -> ([], [])+	params:fieldparams:rest -> ( params, fieldparams, intercalate ["--"] rest )+	[params] -> (params, [], [])+	_ -> ([], [], [])  parseFields :: [String] -> [(String, String)] parseFields = map (separate (== '='))@@ -126,7 +133,7 @@ 	| otherwise = False  failure :: IO ()-failure = error $ "bad parameters\n\n" ++ usage header cmds options+failure = error $ "bad parameters\n\n" ++ usage header cmds  checkNotLimited :: IO () checkNotLimited = checkEnv "GIT_ANNEX_SHELL_LIMITED"
Init.hs view
@@ -18,6 +18,7 @@ import Utility.Network import qualified Git import qualified Git.LsFiles+import qualified Git.Config import qualified Annex.Branch import Logs.UUID import Annex.Version@@ -33,7 +34,7 @@ genDescription :: Maybe String -> Annex String genDescription (Just d) = return d genDescription Nothing = do-	hostname <- maybe "" id <$> liftIO getHostname+	hostname <- fromMaybe "" <$> liftIO getHostname 	let at = if null hostname then "" else "@" 	username <- liftIO myUserName 	reldir <- liftIO . relHome =<< fromRepo Git.repoPath@@ -44,6 +45,7 @@ 	prepUUID 	setVersion defaultVersion 	checkCrippledFileSystem+	checkFifoSupport 	Annex.Branch.create 	gitPreCommitHookWrite 	createInodeSentinalFile@@ -132,7 +134,7 @@ 		return True  checkCrippledFileSystem :: Annex ()-checkCrippledFileSystem = whenM (probeCrippledFileSystem) $ do+checkCrippledFileSystem = whenM probeCrippledFileSystem $ do 	warning "Detected a crippled filesystem." 	setCrippledFileSystem True 	unlessM isDirect $ do@@ -144,3 +146,22 @@ 		void $ liftIO clean 		setDirect True 	setVersion directModeVersion++probeFifoSupport :: Annex Bool+probeFifoSupport = do+	tmp <- fromRepo gitAnnexTmpDir+	let f = tmp </> "gaprobe"+	liftIO $ do+		createDirectoryIfMissing True tmp+		nukeFile f+		ms <- tryIO $ do+			createNamedPipe f ownerReadMode+			getFileStatus f+		nukeFile f+		return $ either (const False) isNamedPipe ms++checkFifoSupport :: Annex ()+checkFifoSupport = unlessM probeFifoSupport $ do+	warning "Detected a filesystem without fifo support."+	warning "Disabling ssh connection caching."+	setConfig (annexConfig "sshcaching") (Git.Config.boolConfig False)
Limit.hs view
@@ -5,7 +5,7 @@  - Licensed under the GNU GPL version 3 or higher.  -} -{-# LANGUAGE PackageImports, CPP #-}+{-# LANGUAGE CPP #-}  module Limit where @@ -128,7 +128,7 @@ limitPresent :: Maybe UUID -> MkLimit limitPresent u _ = Right $ const $ check $ \key -> do 	hereu <- getUUID-	if u == Just hereu || u == Nothing+	if u == Just hereu || isNothing u 		then inAnnex key 		else do 			us <- Remote.keyLocations key@@ -145,8 +145,8 @@  limitCopies :: MkLimit limitCopies want = case split ":" want of-	[v, n] -> case readTrustLevel v of-		Just trust -> go n $ checktrust trust+	[v, n] -> case parsetrustspec v of+		Just checker -> go n $ checktrust checker 		Nothing -> go n $ checkgroup v 	[n] -> go n $ const $ return True 	_ -> Left "bad value for copies"@@ -160,8 +160,11 @@ 		us <- filter (`S.notMember` notpresent) 			<$> (filterM good =<< Remote.keyLocations key) 		return $ length us >= n-	checktrust t u = (== t) <$> lookupTrust u+	checktrust checker u = checker <$> lookupTrust u 	checkgroup g u = S.member g <$> lookupGroups u+	parsetrustspec s+		| "+" `isSuffixOf` s = (>=) <$> readTrustLevel (beginning s)+		| otherwise = (==) <$> readTrustLevel s  {- Adds a limit to skip files not believed to be present in all  - repositories in the specified group. -}@@ -204,10 +207,15 @@ limitSize :: (Maybe Integer -> Maybe Integer -> Bool) -> MkLimit limitSize vs s = case readSize dataUnits s of 	Nothing -> Left "bad size"-	Just sz -> Right $ const $ lookupFile >=> check sz+	Just sz -> Right $ go sz   where-	check _ Nothing = return False-	check sz (Just (key, _)) = return $ keySize key `vs` Just sz+  	go sz _ fi = lookupFile fi >>= check fi sz+	check _ sz (Just (key, _)) = return $ keySize key `vs` Just sz+	check fi sz Nothing = do+		filesize <- liftIO $ catchMaybeIO $+			fromIntegral . fileSize+				<$> getFileStatus (Annex.relFile fi)+		return $ filesize `vs` Just sz  addTimeLimit :: String -> Annex () addTimeLimit s = do
Locations.hs view
@@ -11,6 +11,7 @@ 	keyPaths, 	keyPath, 	gitAnnexLocation,+	gitAnnexLink, 	gitAnnexMapping, 	gitAnnexInodeCache, 	gitAnnexInodeSentinal,@@ -88,7 +89,7 @@ annexLocation :: Key -> Hasher -> FilePath annexLocation key hasher = objectDir </> keyPath key hasher -{- Annexed file's absolute location in a repository.+{- Annexed object's absolute location in a repository.  -  - When there are multiple possible locations, returns the one where the  - file is actually present.@@ -99,35 +100,50 @@  - This does not take direct mode into account, so in direct mode it is not  - the actual location of the file's content.  -}-gitAnnexLocation :: Key -> Git.Repo -> IO FilePath-gitAnnexLocation key r-	| Git.repoIsLocalBare r =-		{- Bare repositories default to hashDirLower for new-		 - content, as it's more portable. -}+gitAnnexLocation :: Key -> Git.Repo -> GitConfig -> IO FilePath+gitAnnexLocation key r config = gitAnnexLocation' key r (annexCrippledFileSystem config)+gitAnnexLocation' :: Key -> Git.Repo -> Bool -> IO FilePath+gitAnnexLocation' key r crippled+	{- Bare repositories default to hashDirLower for new+	 - content, as it's more portable.+	 -+	 - Repositories on filesystems that are crippled also use+	 - hashDirLower, since they do not use symlinks and it's+	 - more portable. -}+	| Git.repoIsLocalBare r || crippled = 		check $ map inrepo $ annexLocations key-	| otherwise =-		{- Non-bare repositories only use hashDirMixed, so-		 - don't need to do any work to check if the file is-		 - present. -}-		return $ inrepo $ annexLocation key hashDirMixed+	{- Non-bare repositories only use hashDirMixed, so+	 - don't need to do any work to check if the file is+	 - present. -}+	| otherwise = return $ inrepo $ annexLocation key hashDirMixed   where 	inrepo d = Git.localGitDir r </> d 	check locs@(l:_) = fromMaybe l <$> firstM doesFileExist locs 	check [] = error "internal" +{- Calculates a symlink to link a file to an annexed object. -}+gitAnnexLink :: FilePath -> Key -> Git.Repo -> IO FilePath+gitAnnexLink file key r = do+	cwd <- getCurrentDirectory+	let absfile = fromMaybe whoops $ absNormPath cwd file+	loc <- gitAnnexLocation' key r False+	return $ relPathDirToFile (parentDir absfile) loc+  where+  	whoops = error $ "unable to normalize " ++ file+ {- File that maps from a key to the file(s) in the git repository.  - Used in direct mode. -}-gitAnnexMapping :: Key -> Git.Repo -> IO FilePath-gitAnnexMapping key r = do-	loc <- gitAnnexLocation key r +gitAnnexMapping :: Key -> Git.Repo -> GitConfig -> IO FilePath+gitAnnexMapping key r config = do+	loc <- gitAnnexLocation key r config 	return $ loc ++ ".map"  {- File that caches information about a key's content, used to determine  - if a file has changed.  - Used in direct mode. -}-gitAnnexInodeCache :: Key -> Git.Repo -> IO FilePath-gitAnnexInodeCache key r  = do-	loc <- gitAnnexLocation key r +gitAnnexInodeCache :: Key -> Git.Repo -> GitConfig -> IO FilePath+gitAnnexInodeCache key r config  = do+	loc <- gitAnnexLocation key r config 	return $ loc ++ ".cache"  gitAnnexInodeSentinal :: Git.Repo -> FilePath@@ -148,7 +164,7 @@ gitAnnexTmpDir :: Git.Repo -> FilePath gitAnnexTmpDir r = addTrailingPathSeparator $ gitAnnexDir r </> "tmp" -{- The temp file to use for a given key. -}+{- The temp file to use for a given key's content. -} gitAnnexTmpLocation :: Key -> Git.Repo -> FilePath gitAnnexTmpLocation key r = gitAnnexTmpDir r </> keyFile key
Logs/Group.hs view
@@ -13,6 +13,7 @@ 	groupMap, 	groupMapLoad, 	getStandardGroup,+	inUnwantedGroup ) where  import qualified Data.Map as M@@ -66,11 +67,15 @@ makeGroupMap byuuid = GroupMap byuuid bygroup   where 	bygroup = M.fromListWith S.union $-		concat $ map explode $ M.toList byuuid+		concatMap explode $ M.toList byuuid 	explode (u, s) = map (\g -> (g, S.singleton u)) (S.toList s)  {- If a repository is in exactly one standard group, returns it. -} getStandardGroup :: S.Set Group -> Maybe StandardGroup-getStandardGroup s = case catMaybes $ map toStandardGroup $ S.toList s of+getStandardGroup s = case mapMaybe toStandardGroup $ S.toList s of 	[g] -> Just g 	_ -> Nothing++inUnwantedGroup :: UUID -> Annex Bool+inUnwantedGroup u = elem UnwantedGroup +	. mapMaybe toStandardGroup . S.toList <$> lookupGroups u
Logs/PreferredContent.hs view
@@ -27,8 +27,8 @@ import Logs.UUIDBased import Limit import qualified Utility.Matcher+import Annex.FileMatcher import Annex.UUID-import Git.FilePath import Types.Group import Logs.Group import Types.StandardGroups@@ -43,26 +43,18 @@ 	ts <- liftIO getPOSIXTime 	Annex.Branch.change preferredContentLog $ 		showLog id . changeLog ts uuid val . parseLog Just-	Annex.changeState $ \s -> s { Annex.groupmap = Nothing }+	Annex.changeState $ \s -> s { Annex.preferredcontentmap = Nothing } preferredContentSet NoUUID _ = error "unknown UUID; cannot modify"  {- Checks if a file is preferred content for the specified repository  - (or the current repository if none is specified). -} isPreferredContent :: Maybe UUID -> AssumeNotPresent -> FilePath -> Bool -> Annex Bool isPreferredContent mu notpresent file def = do-	matchfile <- getTopFilePath <$> inRepo (toTopFilePath file)-	let fi = Annex.FileInfo-		{ Annex.matchFile = matchfile-		, Annex.relFile = file-		} 	u <- maybe getUUID return mu 	m <- preferredContentMap 	case M.lookup u m of 		Nothing -> return def-		Just matcher-			| Utility.Matcher.isEmpty matcher -> return def-			| otherwise -> Utility.Matcher.matchMrun matcher $ -				\a -> a notpresent fi+		Just matcher -> checkFileMatcher' matcher file notpresent def  {- The map is cached for speed. -} preferredContentMap :: Annex Annex.PreferredContentMap@@ -87,56 +79,30 @@  - because the configuration is shared amoung repositories and newer  - versions of git-annex may add new features. Instead, parse errors  - result in a Matcher that will always succeed. -}-makeMatcher :: GroupMap -> UUID -> String -> Utility.Matcher.Matcher MatchFiles+makeMatcher :: GroupMap -> UUID -> String -> FileMatcher makeMatcher groupmap u s 	| s == "standard" = standardMatcher groupmap u 	| null (lefts tokens) = Utility.Matcher.generate $ rights tokens 	| otherwise = matchAll   where-	tokens = map (parseToken (Just u) groupmap) (tokenizeMatcher s)+	tokens = map (parseToken (limitPresent $ Just u) groupmap) (tokenizeMatcher s)  {- Standard matchers are pre-defined for some groups. If none is defined,  - or a repository is in multiple groups with standard matchers, match all. -}-standardMatcher :: GroupMap -> UUID -> Utility.Matcher.Matcher MatchFiles+standardMatcher :: GroupMap -> UUID -> FileMatcher standardMatcher m u = maybe matchAll (makeMatcher m u . preferredContent) $ 	getStandardGroup =<< u `M.lookup` groupsByUUID m -matchAll :: Utility.Matcher.Matcher MatchFiles-matchAll = Utility.Matcher.generate []- {- Checks if an expression can be parsed, if not returns Just error -} checkPreferredContentExpression :: String -> Maybe String checkPreferredContentExpression s 	| s == "standard" = Nothing-	| otherwise = case lefts $ map (parseToken Nothing emptyGroupMap) (tokenizeMatcher s) of-		[] -> Nothing-		l -> Just $ unwords $ map ("Parse failure: " ++) l--parseToken :: (Maybe UUID) -> GroupMap -> String -> Either String (Utility.Matcher.Token MatchFiles)-parseToken mu groupmap t-	| any (== t) Utility.Matcher.tokens = Right $ Utility.Matcher.token t-	| t == "present" = use $ limitPresent mu-	| otherwise = maybe (Left $ "near " ++ show t) use $ M.lookup k $-		M.fromList-			[ ("include", limitInclude)-			, ("exclude", limitExclude)-			, ("copies", limitCopies)-			, ("inbackend", limitInBackend)-			, ("largerthan", limitSize (>))-			, ("smallerthan", limitSize (<))-			, ("inallgroup", limitInAllGroup groupmap)-			]-  where-	(k, v) = separate (== '=') t-	use a = Utility.Matcher.Operation <$> a v--{- This is really dumb tokenization; there's no support for quoted values.- - Open and close parens are always treated as standalone tokens;- - otherwise tokens must be separated by whitespace. -}-tokenizeMatcher :: String -> [String]-tokenizeMatcher = filter (not . null ) . concatMap splitparens . words+	| otherwise = case parsedToMatcher vs of+		Left e -> Just e+		Right _ -> Nothing   where-	splitparens = segmentDelim (`elem` "()")+	vs = map (parseToken (limitPresent Nothing) emptyGroupMap)+		(tokenizeMatcher s)  {- Puts a UUID in a standard group, and sets its preferred content to use  - the standard expression for that group, unless something is already set. -}
Logs/Remote.hs view
@@ -93,7 +93,7 @@ prop_parse_show_Config :: RemoteConfig -> Bool prop_parse_show_Config c 	-- whitespace and '=' are not supported in keys-	| any (\k -> any isSpace k || any (== '=') k) (M.keys c) = True+	| any (\k -> any isSpace k || elem '=' k) (M.keys c) = True 	| otherwise = parseConfig (showConfig c) ~~ Just c   where 	normalize v = sort . M.toList <$> v
Logs/Transfer.hs view
@@ -13,6 +13,7 @@ import qualified Git import Types.Remote import Types.Key+import Utility.Metered import Utility.Percentage import Utility.QuickCheck @@ -69,6 +70,7 @@ 	[ show $ transferDirection t 	, show $ transferUUID t 	, fromMaybe (key2file $ transferKey t) (associatedFile info)+	, show $ bytesComplete info 	]  {- Transfers that will accomplish the same task. -}@@ -128,8 +130,8 @@ 			Just fd -> do 				locked <- catchMaybeIO $ 					setLock fd (WriteLock, AbsoluteSeek, 0, 0)-				when (locked == Nothing) $-					error $ "transfer already in progress"+				when (isNothing locked) $+					error "transfer already in progress" 				void $ tryIO $ writeTransferInfoFile info tfile 				return mfd 	cleanup _ Nothing = noop@@ -165,12 +167,13 @@ 	mvar <- liftIO $ newMVar 0 	return (liftIO . updater tfile mvar, tfile, mvar)   where-	updater tfile mvar bytes = modifyMVar_ mvar $ \oldbytes -> do-		if (bytes - oldbytes >= mindelta)+	updater tfile mvar b = modifyMVar_ mvar $ \oldbytes -> do+		let newbytes = fromBytesProcessed b+		if newbytes - oldbytes >= mindelta 			then do-				let info' = info { bytesComplete = Just bytes }+				let info' = info { bytesComplete = Just newbytes } 				_ <- tryIO $ writeTransferInfoFile info' tfile-				return bytes+				return newbytes 			else return oldbytes 	{- The minimum change in bytesComplete that is worth 	 - updating a transfer info file for is 1% of the total@@ -210,7 +213,7 @@ {- Gets all currently running transfers. -} getTransfers :: Annex [(Transfer, TransferInfo)] getTransfers = do-	transfers <- catMaybes . map parseTransferFile . concat <$> findfiles+	transfers <- mapMaybe parseTransferFile . concat <$> findfiles 	infos <- mapM checkTransfer transfers 	return $ map (\(t, Just i) -> (t, i)) $ 		filter running $ zip transfers infos@@ -262,7 +265,7 @@ {- Parses a transfer information filename to a Transfer. -} parseTransferFile :: FilePath -> Maybe Transfer parseTransferFile file-	| "lck." `isPrefixOf` (takeFileName file) = Nothing+	| "lck." `isPrefixOf` takeFileName file = Nothing 	| otherwise = case drop (length bits - 3) bits of 		[direction, u, key] -> Transfer 			<$> readLcDirection direction@@ -288,17 +291,17 @@ writeTransferInfo :: TransferInfo -> String writeTransferInfo info = unlines 	[ (maybe "" show $ startedTime info) ++-	  (maybe "" (\b -> " " ++ show b) $ bytesComplete info)+	  (maybe "" (\b -> ' ' : show b) (bytesComplete info)) 	, fromMaybe "" $ associatedFile info -- comes last; arbitrary content 	] -readTransferInfoFile :: (Maybe ProcessID) -> FilePath -> IO (Maybe TransferInfo)+readTransferInfoFile :: Maybe ProcessID -> FilePath -> IO (Maybe TransferInfo) readTransferInfoFile mpid tfile = catchDefaultIO Nothing $ do 	h <- openFile tfile ReadMode 	fileEncoding h 	hClose h `after` (readTransferInfo mpid <$> hGetContentsStrict h) -readTransferInfo :: (Maybe ProcessID) -> String -> Maybe TransferInfo+readTransferInfo :: Maybe ProcessID -> String -> Maybe TransferInfo readTransferInfo mpid s = TransferInfo 	<$> time 	<*> pure mpid@@ -350,8 +353,8 @@  prop_read_write_transferinfo :: TransferInfo -> Bool prop_read_write_transferinfo info-	| transferRemote info /= Nothing = True -- remote not stored-	| transferTid info /= Nothing = True -- tid not stored+	| isJust (transferRemote info) = True -- remote not stored+	| isJust (transferTid info) = True -- tid not stored 	| otherwise = Just (info { transferPaused = False }) == info'   where 	info' = readTransferInfo (transferPid info) (writeTransferInfo info)
Logs/Trust.hs view
@@ -70,7 +70,7 @@ 		return $ partition (`elem` candidates) ls  {- Filters UUIDs to those not matching a TrustLevel. -}-trustExclude :: TrustLevel -> [UUID] -> Annex ([UUID])+trustExclude :: TrustLevel -> [UUID] -> Annex [UUID] trustExclude level ls = snd <$> trustPartition level ls  {- trustLog in a map, overridden with any values from forcetrust or
Logs/Unused.hs view
@@ -31,7 +31,7 @@ readUnusedLog prefix = do 	f <- fromRepo $ gitAnnexUnusedLog prefix 	ifM (liftIO $ doesFileExist f)-		( M.fromList . catMaybes . map parse . lines+		( M.fromList . mapMaybe parse . lines 			<$> liftIO (readFile f) 		, return M.empty 		)
Makefile view
@@ -50,7 +50,7 @@  # hothasktags chokes on some tempolate haskell etc, so ignore errors tags:-	find . | grep -v /.git/ | grep -v /doc/ | egrep '\.hs$$' | xargs hothasktags > tags 2>/dev/null+	find . | grep -v /.git/ | grep -v /dist/ | grep -v /doc/ | egrep '\.hs$$' | xargs hothasktags > tags 2>/dev/null  # If ikiwiki is available, build static html docs suitable for being # shipped in the software package.
Messages.hs view
@@ -43,14 +43,15 @@ import System.Log.Formatter import System.Log.Handler (setFormatter, LogHandler) import System.Log.Handler.Simple+import qualified Data.Set as S  import Common import Types import Types.Messages+import qualified Messages.JSON as JSON import Types.Key import qualified Annex-import qualified Messages.JSON as JSON-import qualified Data.Set as S+import Utility.Metered  showStart :: String -> String -> Annex () showStart command file = handle (JSON.start command $ Just file) $@@ -70,7 +71,7 @@  {- Shows a progress meter while performing a transfer of a key.  - The action is passed a callback to use to update the meter. -}-metered :: (Maybe MeterUpdate) -> Key -> (MeterUpdate -> Annex a) -> Annex a+metered :: Maybe MeterUpdate -> Key -> (MeterUpdate -> Annex a) -> Annex a metered combinemeterupdate key a = go (keySize key)   where 	go (Just size) = meteredBytes combinemeterupdate size a@@ -78,7 +79,7 @@  {- Shows a progress meter while performing an action on a given number  - of bytes. -}-meteredBytes :: (Maybe MeterUpdate) -> Integer -> (MeterUpdate -> Annex a) -> Annex a+meteredBytes :: Maybe MeterUpdate -> Integer -> (MeterUpdate -> Annex a) -> Annex a meteredBytes combinemeterupdate size a = withOutputType go   where 	go NormalOutput = do@@ -86,7 +87,7 @@ 		meter <- liftIO $ newMeter progress "B" 25 (renderNums binaryOpts 1) 		showOutput 		r <- a $ \n -> liftIO $ do-			incrP progress n+			setP progress $ fromBytesProcessed n 			displayMeter stdout meter 			maybe noop (\m -> m n) combinemeterupdate 		liftIO $ clearMeter stdout meter
Messages/JSON.hs view
@@ -34,7 +34,4 @@ add v = putStr $ Stream.add v  complete :: JSON a => [(String, a)] -> IO ()-complete v = putStr $ concat-	[ Stream.start v-	, Stream.end-	]+complete v = putStr $ Stream.start v ++ Stream.end
− Meters.hs 
@@ -1,40 +0,0 @@-{- git-annex meters- -- - Copyright 2012 Joey Hess <joey@kitenet.net>- -- - Licensed under the GNU GPL version 3 or higher.- -}--module Meters where--import Common-import Types.Meters-import Utility.Observed--import qualified Data.ByteString.Lazy as L-import qualified Data.ByteString as S--{- Sends the content of a file to an action, updating the meter as it's- - consumed. -}-withMeteredFile :: FilePath -> MeterUpdate -> (L.ByteString -> IO a) -> IO a-withMeteredFile f meterupdate a = withBinaryFile f ReadMode $ \h ->-	hGetContentsObserved h (meterupdate . toInteger) >>= a--{- Sends the content of a file to a Handle, updating the meter as it's- - written. -}-streamMeteredFile :: FilePath -> MeterUpdate -> Handle -> IO ()-streamMeteredFile f meterupdate h = withMeteredFile f meterupdate $ L.hPut h--{- Writes a ByteString to a Handle, updating a meter as it's written. -}-meteredWrite :: MeterUpdate -> Handle -> L.ByteString -> IO ()-meteredWrite meterupdate h = go . L.toChunks -  where-	go [] = return ()-	go (c:cs) = do-		S.hPut h c-		meterupdate $ toInteger $ S.length c-		go cs--meteredWriteFile :: MeterUpdate -> FilePath -> L.ByteString -> IO ()-meteredWriteFile meterupdate f b = withBinaryFile f WriteMode $ \h ->-	meteredWrite meterupdate h b
Option.hs view
@@ -1,4 +1,4 @@-{- git-annex command-line options+{- common command-line options  -  - Copyright 2010-2011 Joey Hess <joey@kitenet.net>  -
Remote.hs view
@@ -28,6 +28,7 @@ 	byCost, 	prettyPrintUUIDs, 	prettyListUUIDs,+	prettyUUID, 	remoteFromUUID, 	remotesWithUUID, 	remotesWithoutUUID,@@ -150,7 +151,7 @@ prettyListUUIDs uuids = do 	hereu <- getUUID 	m <- uuidDescriptions-	return $ map (\u -> prettify m hereu u) uuids+	return $ map (prettify m hereu) uuids   where 	finddescription m u = M.findWithDefault "" u m 	prettify m hereu u@@ -158,6 +159,10 @@ 		| otherwise = n 	  where 		n = finddescription m u++{- Nice display of a remote's name and/or description. -}+prettyUUID :: UUID -> Annex String+prettyUUID u = concat <$> prettyListUUIDs [u]  {- Gets the remote associated with a UUID.  - There's no associated remote when this is the UUID of the local repo. -}
Remote/Bup.hs view
@@ -29,6 +29,7 @@ import Data.Digest.Pure.SHA import Utility.UserInfo import Annex.Content+import Utility.Metered  type BupRepo = String
Remote/Directory.hs view
@@ -24,7 +24,7 @@ import Remote.Helper.Chunked import Crypto import Annex.Content-import Meters+import Utility.Metered  remote :: RemoteType remote = RemoteType {@@ -154,17 +154,20 @@ storeSplit' _ _ [] _ _ = error "ran out of dests" storeSplit' _ _  _ [] c = return $ reverse c storeSplit' meterupdate chunksize (d:dests) bs c = do-	bs' <- E.bracket (openFile d WriteMode) hClose (feed chunksize bs)+	bs' <- E.bracket (openFile d WriteMode) hClose $+		feed zeroBytesProcessed chunksize bs 	storeSplit' meterupdate chunksize dests bs' (d:c)   where-	feed _ [] _ = return []-	feed sz (l:ls) h = do-		let s = fromIntegral $ S.length l+	feed _ _ [] _ = return []+	feed bytes sz (l:ls) h = do+		let len = S.length l+		let s = fromIntegral len 		if s <= sz || sz == chunksize 			then do 				S.hPut h l-				meterupdate $ toInteger s-				feed (sz - s) ls h+				let bytes' = addBytesProcessed bytes len+				meterupdate bytes'+				feed bytes' (sz - s) ls h 			else return (l:ls)  storeHelper :: FilePath -> ChunkSize -> Key -> ([FilePath] -> IO [FilePath]) -> Annex Bool
Remote/Git.hs view
@@ -40,6 +40,7 @@ import Types.Key import qualified Fields import Logs.Location+import Utility.Metered  import Control.Concurrent import Control.Concurrent.MSampleVar@@ -110,6 +111,7 @@ 				else Nothing 			, repo = r 			, gitconfig = gc+				{ remoteGitConfig = Just $ extractGitConfig r } 			, readonly = Git.repoIsHttp r 			, globallyAvailable = not $ Git.repoIsLocal r || Git.repoIsLocalUnknown r 			, remotetype = remote@@ -309,7 +311,7 @@ 			: maybe [] (\f -> [(Fields.associatedFile, f)]) file 		Just (cmd, params) <- git_annex_shell (repo r) "transferinfo"  			[Param $ key2file key] fields-		v <- liftIO $ newEmptySV+		v <- liftIO $ (newEmptySV :: IO (MSampleVar Integer)) 		tid <- liftIO $ forkIO $ void $ tryIO $ do 			bytes <- readSV v 			p <- createProcess $@@ -325,13 +327,14 @@ 			send bytes 			forever $ 				send =<< readSV v-		let feeder = writeSV v+		let feeder = writeSV v . fromBytesProcessed 		bracketIO noop (const $ tryIO $ killThread tid) (a feeder)  copyFromRemoteCheap :: Remote -> Key -> FilePath -> Annex Bool copyFromRemoteCheap r key file 	| not $ Git.repoIsUrl (repo r) = guardUsable (repo r) False $ do-		loc <- liftIO $ gitAnnexLocation key (repo r)+		loc <- liftIO $ gitAnnexLocation key (repo r) $+			fromJust $ remoteGitConfig $ gitconfig r 		liftIO $ catchBoolIO $ createSymbolicLink loc file >> return True 	| Git.repoIsSsh (repo r) = 		ifM (Annex.Content.preseedTmp key file)@@ -391,13 +394,13 @@ 	dorsync = rsyncHelper (Just p) $ 		rsyncparams ++ [Param src, Param dest] 	docopy = liftIO $ bracket-		(forkIO $ watchfilesize 0)+		(forkIO $ watchfilesize zeroBytesProcessed) 		(void . tryIO . killThread) 		(const $ copyFileExternal src dest) 	watchfilesize oldsz = do 		threadDelay 500000 -- 0.5 seconds 		v <- catchMaybeIO $-			fromIntegral . fileSize+			toBytesProcessed . fileSize 				<$> getFileStatus dest 		case v of 			Just sz
Remote/Glacier.hs view
@@ -22,7 +22,7 @@ import qualified Remote.Helper.AWS as AWS import Crypto import Creds-import Meters+import Utility.Metered import qualified Annex import Annex.Content
Remote/Helper/Chunked.hs view
@@ -10,7 +10,7 @@ import Common.Annex import Utility.DataUnits import Types.Remote-import Meters+import Utility.Metered  import qualified Data.Map as M import qualified Data.ByteString.Lazy as L
Remote/Helper/Encryptable.hs view
@@ -12,9 +12,11 @@ import Common.Annex import Types.Remote import Crypto+import Types.Crypto import qualified Annex import Config.Cost import Utility.Base64+import Utility.Metered  {- Encryption setup for a remote. The user must specify whether to use  - an encryption key, or not encrypt. An encrypted cipher is created, or is@@ -106,7 +108,8 @@ cipherKey :: RemoteConfig -> Key -> Annex (Maybe (Cipher, Key)) cipherKey c k = maybe Nothing make <$> remoteCipher c   where-	make ciphertext = Just (ciphertext, encryptKey ciphertext k)+	make ciphertext = Just (ciphertext, encryptKey mac ciphertext k)+	mac = fromMaybe defaultMac $ M.lookup "mac" c >>= readMac  {- Stores an StorableCipher in a remote's configuration. -} storeCipher :: RemoteConfig -> StorableCipher -> RemoteConfig
Remote/Hook.hs view
@@ -21,6 +21,7 @@ import Remote.Helper.Special import Remote.Helper.Encryptable import Crypto+import Utility.Metered  remote :: RemoteType remote = RemoteType {
Remote/Rsync.hs view
@@ -22,6 +22,7 @@ import Crypto import Utility.Rsync import Utility.CopyFile+import Utility.Metered import Annex.Perms  type RsyncUrl = String@@ -126,7 +127,7 @@ retrieveCheap o k f = ifM (preseedTmp k f) ( retrieve o k undefined f , return False )  retrieveEncrypted :: RsyncOpts -> (Cipher, Key) -> Key -> FilePath -> Annex Bool-retrieveEncrypted o (cipher, enck) _ f = withTmp enck $ \tmp -> do+retrieveEncrypted o (cipher, enck) _ f = withTmp enck $ \tmp -> 	ifM (retrieve o enck undefined tmp) 		( liftIO $ catchBoolIO $ do 			decrypt cipher (feedFile tmp) $
Remote/S3.hs view
@@ -27,7 +27,7 @@ import qualified Remote.Helper.AWS as AWS import Crypto import Creds-import Meters+import Utility.Metered import Annex.Content  remote :: RemoteType
Remote/Web.hs view
@@ -17,6 +17,7 @@ import Logs.Web import qualified Utility.Url as Url import Types.Key+import Utility.Metered  import qualified Data.Map as M
Remote/WebDAV.hs view
@@ -30,7 +30,7 @@ import Remote.Helper.Chunked import Crypto import Creds-import Meters+import Utility.Metered import Annex.Content  type DavUrl = String
Seek.hs view
@@ -28,7 +28,7 @@ 		runSegmentPaths (\fs -> Git.Command.leaveZombie <$> a fs g) params 	{- Show warnings only for files/directories that do not exist. -} 	forM_ (map fst $ filter (null . snd) $ zip params ll) $ \p ->-		unlessM (isJust <$> (liftIO $ catchMaybeIO $ getSymbolicLinkStatus p)) $+		unlessM (isJust <$> liftIO (catchMaybeIO $ getSymbolicLinkStatus p)) $ 			fileNotFound p 	return $ concat ll
Test.hs view
@@ -72,7 +72,7 @@ 	divider 	propigate rs qcok   where-	divider = putStrLn $ take 70 $ repeat '-'+	divider = putStrLn $ replicate 70 '-'  propigate :: [Counts] -> Bool -> IO () propigate cs qcok@@ -103,7 +103,7 @@ 	, check "prop_relPathDirToFile_basics" Utility.Path.prop_relPathDirToFile_basics 	, check "prop_relPathDirToFile_regressionTest" Utility.Path.prop_relPathDirToFile_regressionTest 	, check "prop_cost_sane" Config.Cost.prop_cost_sane-	, check "prop_hmacWithCipher_sane" Crypto.prop_hmacWithCipher_sane+	, check "prop_HmacSha1WithCipher_sane" Crypto.prop_HmacSha1WithCipher_sane 	, check "prop_TimeStamp_sane" Logs.UUIDBased.prop_TimeStamp_sane 	, check "prop_addLog_sane" Logs.UUIDBased.prop_addLog_sane 	, check "prop_verifiable_sane" Utility.Verifiable.prop_verifiable_sane@@ -851,7 +851,7 @@ 		-- removed via directory permissions; undo 		recurseDir SystemFS dir >>= 			filterM doesDirectoryExist >>=-			mapM_ Utility.FileMode.allowWrite+				mapM_ Utility.FileMode.allowWrite 		removeDirectoryRecursive dir 	 checklink :: FilePath -> Assertion
Types.hs view
@@ -14,8 +14,7 @@ 	RemoteGitConfig(..), 	Remote, 	RemoteType,-	Option,-	MeterUpdate+	Option ) where  import Annex@@ -25,7 +24,6 @@ import Types.UUID import Types.Remote import Types.Option-import Types.Meters  type Backend = BackendA Annex type Remote = RemoteA Annex
Types/Command.hs view
@@ -42,6 +42,7 @@ 	, cmdname :: String 	, cmdparamdesc :: String     -- description of params for usage 	, cmdseek :: [CommandSeek]   -- seek stage+	, cmdsection :: CommandSection 	, cmddesc :: String          -- description of command for usage 	} @@ -52,6 +53,24 @@ instance Eq Command where 	a == b = cmdname a == cmdname b -{- Order commands by name -}+{- Order commands by name. -} instance Ord Command where 	compare = comparing cmdname++{- The same sections are listed in doc/git-annex.mdwn -}+data CommandSection +	= SectionCommon+	| SectionSetup+	| SectionMaintenance+	| SectionQuery+	| SectionUtility+	| SectionPlumbing+	deriving (Eq, Ord, Enum, Bounded)++descSection :: CommandSection -> String+descSection SectionCommon = "Commonly used commands"+descSection SectionSetup = "Repository setup commands"+descSection SectionMaintenance = "Repository maintenance commands"+descSection SectionQuery = "Query commands"+descSection SectionUtility = "Utility commands"+descSection SectionPlumbing = "Plumbing commands"
Types/Crypto.hs view
@@ -9,8 +9,16 @@ 	Cipher(..), 	StorableCipher(..), 	KeyIds(..),+	Mac(..),+	readMac,+	showMac,+	defaultMac,+	calcMac, ) where +import qualified Data.ByteString.Lazy as L+import Data.Digest.Pure.SHA+ import Utility.Gpg (KeyIds(..))  -- XXX ideally, this would be a locked memory region@@ -18,3 +26,44 @@  data StorableCipher = EncryptedCipher String KeyIds | SharedCipher String 	deriving (Ord, Eq)++{- File names are (client-side) MAC'ed on special remotes.+ - The chosen MAC algorithm needs to be same for all files stored on the+ - remote.+ -}+data Mac = HmacSha1 | HmacSha224 | HmacSha256 | HmacSha384 | HmacSha512+	deriving (Eq)++defaultMac :: Mac+defaultMac = HmacSha1++-- MAC algorithms are shown as follows in the file names.+showMac :: Mac -> String+showMac HmacSha1   = "HMACSHA1"+showMac HmacSha224 = "HMACSHA224"+showMac HmacSha256 = "HMACSHA256"+showMac HmacSha384 = "HMACSHA384"+showMac HmacSha512 = "HMACSHA512"++-- Read the MAC algorithm from the remote config.+readMac :: String -> Maybe Mac+readMac "HMACSHA1"   = Just HmacSha1+readMac "HMACSHA224" = Just HmacSha224+readMac "HMACSHA256" = Just HmacSha256+readMac "HMACSHA384" = Just HmacSha384+readMac "HMACSHA512" = Just HmacSha512+readMac _ = Nothing++calcMac+  :: Mac	  -- ^ MAC+  -> L.ByteString -- ^ secret key+  -> L.ByteString -- ^ message+  -> String	  -- ^ MAC'ed message, in hexadecimals+calcMac mac = case mac of+	HmacSha1   -> showDigest $* hmacSha1+	HmacSha224 -> showDigest $* hmacSha224+	HmacSha256 -> showDigest $* hmacSha256+	HmacSha384 -> showDigest $* hmacSha384+	HmacSha512 -> showDigest $* hmacSha512+  where+  ($*) g f x y = g $ f x y
Types/GitConfig.hs view
@@ -37,6 +37,7 @@ 	, annexAutoCommit :: Bool 	, annexWebOptions :: [String] 	, annexCrippledFileSystem :: Bool+	, annexLargeFiles :: Maybe String 	, coreSymlinks :: Bool 	} @@ -59,6 +60,7 @@ 	, annexAutoCommit = getbool (annex "autocommit") True 	, annexWebOptions = getwords (annex "web-options") 	, annexCrippledFileSystem = getbool (annex "crippledfilesystem") False+	, annexLargeFiles = getmaybe (annex "largefiles") 	, coreSymlinks = getbool "core.symlinks" True 	}   where@@ -86,7 +88,8 @@ 	, remoteAnnexStartCommand :: Maybe String 	, remoteAnnexStopCommand :: Maybe String -	-- these settings are specific to particular types of remotes+	{- These settings are specific to particular types of remotes+	 - including special remotes. -} 	, remoteAnnexSshOptions :: [String] 	, remoteAnnexRsyncOptions :: [String] 	, remoteAnnexGnupgOptions :: [String]@@ -95,6 +98,8 @@ 	, remoteAnnexBupSplitOptions :: [String] 	, remoteAnnexDirectory :: Maybe FilePath 	, remoteAnnexHookType :: Maybe String+	{- A regular git remote's git repository config. -}+	, remoteGitConfig :: Maybe GitConfig 	}  extractRemoteGitConfig :: Git.Repo -> String -> RemoteGitConfig@@ -115,13 +120,14 @@ 	, remoteAnnexBupSplitOptions = getoptions "bup-split-options" 	, remoteAnnexDirectory = notempty $ getmaybe "directory" 	, remoteAnnexHookType = notempty $ getmaybe "hooktype"+	, remoteGitConfig = Nothing 	}   where 	getbool k def = fromMaybe def $ getmaybebool k 	getmaybebool k = Git.Config.isTrue =<< getmaybe k 	getmayberead k = readish =<< getmaybe k-	getmaybe k = maybe (Git.Config.getMaybe (key k) r) Just $-		Git.Config.getMaybe (remotekey k) r+	getmaybe k = mplus (Git.Config.getMaybe (key k) r)+		(Git.Config.getMaybe (remotekey k) r) 	getoptions k = fromMaybe [] $ words <$> getmaybe k  	key k = "annex." ++ k
− Types/Meters.hs 
@@ -1,12 +0,0 @@-{- git-annex meter types- -- - Copyright 2012 Joey Hess <joey@kitenet.net>- -- - Licensed under the GNU GPL version 3 or higher.- -}--module Types.Meters where--{- An action that can be run repeatedly, feeding it the number of- - bytes sent or retrieved so far. -}-type MeterUpdate = (Integer -> IO ())
Types/Remote.hs view
@@ -15,9 +15,9 @@ import qualified Git import Types.Key import Types.UUID-import Types.Meters import Types.GitConfig import Config.Cost+import Utility.Metered  type RemoteConfigKey = String type RemoteConfig = M.Map RemoteConfigKey String
Types/StandardGroups.hs view
@@ -16,6 +16,7 @@ 	| FullArchiveGroup 	| SourceGroup 	| ManualGroup+	| UnwantedGroup 	deriving (Eq, Ord, Enum, Bounded, Show)  fromStandardGroup :: StandardGroup -> String@@ -27,6 +28,7 @@ fromStandardGroup FullArchiveGroup = "archive" fromStandardGroup SourceGroup = "source" fromStandardGroup ManualGroup = "manual"+fromStandardGroup UnwantedGroup = "unwanted"  toStandardGroup :: String -> Maybe StandardGroup toStandardGroup "client" = Just ClientGroup@@ -37,6 +39,7 @@ toStandardGroup "archive" = Just FullArchiveGroup toStandardGroup "source" = Just SourceGroup toStandardGroup "manual" = Just ManualGroup+toStandardGroup "unwanted" = Just UnwantedGroup toStandardGroup _ = Nothing  descStandardGroup :: StandardGroup -> String@@ -48,14 +51,27 @@ descStandardGroup FullArchiveGroup = "full archive: archives all files not archived elsewhere" descStandardGroup SourceGroup = "file source: moves files on to other repositories" descStandardGroup ManualGroup = "manual mode: only stores files you manually choose"+descStandardGroup UnwantedGroup = "unwanted: remove content from this repository"  {- See doc/preferred_content.mdwn for explanations of these expressions. -} preferredContent :: StandardGroup -> String-preferredContent ClientGroup = "exclude=*/archive/* and exclude=archive/*"-preferredContent TransferGroup = "not (inallgroup=client and copies=client:2) and " ++ preferredContent ClientGroup+preferredContent ClientGroup = lastResort+	"exclude=*/archive/* and exclude=archive/*"+preferredContent TransferGroup = lastResort+	"not (inallgroup=client and copies=client:2) and " ++ preferredContent ClientGroup preferredContent BackupGroup = "include=*"-preferredContent IncrementalBackupGroup = "include=* and (not copies=incrementalbackup:1)"-preferredContent SmallArchiveGroup = "(include=*/archive/* or include=archive/*) and " ++ preferredContent FullArchiveGroup-preferredContent FullArchiveGroup = "not (copies=archive:1 or copies=smallarchive:1)"+preferredContent IncrementalBackupGroup = lastResort+	"include=* and (not copies=incrementalbackup:1)"+preferredContent SmallArchiveGroup = lastResort $+	"(include=*/archive/* or include=archive/*) and " ++ preferredContent FullArchiveGroup+preferredContent FullArchiveGroup = lastResort+	"not (copies=archive:1 or copies=smallarchive:1)" preferredContent SourceGroup = "not (copies=1)"-preferredContent ManualGroup = "present and exclude=*/archive/* and exclude=archive/*"+preferredContent ManualGroup = lastResort+	"present and exclude=*/archive/* and exclude=archive/*"+preferredContent UnwantedGroup = "exclude=*"+  	+{- Most repositories want any content that is only on untrusted+ - or dead repositories. -}+lastResort :: String -> String+lastResort s = "(" ++ s ++ ") or (not copies=semitrusted+:1)"
Upgrade/V1.hs view
@@ -92,7 +92,7 @@ 		case r of 			Nothing -> noop 			Just (k, _) -> do-				link <- calcGitLink f k+				link <- inRepo $ gitAnnexLink f k 				liftIO $ removeFile f 				liftIO $ createSymbolicLink link f 				Annex.Queue.addCommand "add" [Param "--"] [f]
Usage.hs view
@@ -8,45 +8,53 @@ module Usage where  import Common.Annex-import System.Console.GetOpt  import Types.Command -{- Usage message with lists of commands and options. -}-usage :: String -> [Command] -> [Option] -> String-usage header cmds commonoptions = unlines $ -	[ header-	, ""-	, "Options:"-	] ++ optlines ++-	[ ""-	, "Commands:"-	, ""-	] ++ cmdlines+import System.Console.GetOpt++usageMessage :: String -> String+usageMessage s = "Usage: " ++ s++{- Usage message with lists of commands by section. -}+usage :: String -> [Command] -> String+usage header cmds = unlines $ usageMessage header : concatMap go [minBound..]   where-	-- To get consistent indentation of options, generate the-	-- usage for all options at once. A command's options will-	-- be displayed after the command.-	alloptlines = filter (not . null) $-		lines $ usageInfo "" $-			concatMap cmdoptions scmds ++ commonoptions-	(cmdlines, optlines) = go scmds alloptlines []-	go [] os ls = (ls, os)-	go (c:cs) os ls = go cs os' (ls++(l:o))+	go section+		| null cs = []+		| otherwise =+			[ ""+			, descSection section ++ ":"+			, ""+			] ++ map cmdline cs 	  where-		(o, os') = splitAt (length $ cmdoptions c) os-		l = concat -			[ cmdname c-			, namepad (cmdname c)-			, cmdparamdesc c-			, descpad (cmdparamdesc c)-			, cmddesc c-			]+		cs = filter (\c -> cmdsection c == section) scmds+	cmdline c = concat+		[ cmdname c+		, namepad (cmdname c)+		, cmdparamdesc c+		, descpad (cmdparamdesc c)+		, cmddesc c+		] 	pad n s = replicate (n - length s) ' ' 	namepad = pad $ longest cmdname + 1 	descpad = pad $ longest cmdparamdesc + 2 	longest f = foldl max 0 $ map (length . f) cmds 	scmds = sort cmds++{- Usage message for a single command. -}+commandUsage :: Command -> String+commandUsage cmd = unlines+	[ usageInfo header (cmdoptions cmd)+	, "To see additional options common to all commands, run: git annex help options"+	]+  where+	header = usageMessage $ unwords+		[ "git-annex"+		, cmdname cmd+		, cmdparamdesc cmd+		, "[option ...]"+		]  {- Descriptions of params used in usage messages. -} paramPaths :: String
+ Utility/Metered.hs view
@@ -0,0 +1,116 @@+{- Metered IO+ -+ - Copyright 2012, 2013 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE TypeSynonymInstances #-}++module Utility.Metered where++import Common++import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString as S+import System.IO.Unsafe+import Foreign.Storable (Storable(sizeOf))+import System.Posix.Types++{- An action that can be run repeatedly, updating it on the bytes processed.+ -+ - Note that each call receives the total number of bytes processed, so+ - far, *not* an incremental amount since the last call. -}+type MeterUpdate = (BytesProcessed -> IO ())++{- Total number of bytes processed so far. -}+newtype BytesProcessed = BytesProcessed Integer+	deriving (Eq, Ord)++class AsBytesProcessed a where+	toBytesProcessed :: a -> BytesProcessed+	fromBytesProcessed :: BytesProcessed -> a++instance AsBytesProcessed Integer where+	toBytesProcessed i = BytesProcessed i+	fromBytesProcessed (BytesProcessed i) = i++instance AsBytesProcessed Int where+	toBytesProcessed i = BytesProcessed $ toInteger i+	fromBytesProcessed (BytesProcessed i) = fromInteger i++instance AsBytesProcessed FileOffset where+	toBytesProcessed sz = BytesProcessed $ toInteger sz+	fromBytesProcessed (BytesProcessed sz) = fromInteger sz++addBytesProcessed :: AsBytesProcessed v => BytesProcessed -> v -> BytesProcessed+addBytesProcessed (BytesProcessed i) v = +	let (BytesProcessed n) = toBytesProcessed v+	in BytesProcessed $! i + n++zeroBytesProcessed :: BytesProcessed+zeroBytesProcessed = BytesProcessed 0++{- Sends the content of a file to an action, updating the meter as it's+ - consumed. -}+withMeteredFile :: FilePath -> MeterUpdate -> (L.ByteString -> IO a) -> IO a+withMeteredFile f meterupdate a = withBinaryFile f ReadMode $ \h ->+	hGetContentsMetered h meterupdate >>= a++{- Sends the content of a file to a Handle, updating the meter as it's+ - written. -}+streamMeteredFile :: FilePath -> MeterUpdate -> Handle -> IO ()+streamMeteredFile f meterupdate h = withMeteredFile f meterupdate $ L.hPut h++{- Writes a ByteString to a Handle, updating a meter as it's written. -}+meteredWrite :: MeterUpdate -> Handle -> L.ByteString -> IO ()+meteredWrite meterupdate h = go zeroBytesProcessed . L.toChunks +  where+	go _ [] = return ()+	go sofar (c:cs) = do+		S.hPut h c+		let sofar' = addBytesProcessed sofar $ S.length c+		meterupdate sofar'+		go sofar' cs++meteredWriteFile :: MeterUpdate -> FilePath -> L.ByteString -> IO ()+meteredWriteFile meterupdate f b = withBinaryFile f WriteMode $ \h ->+	meteredWrite meterupdate h b++{- This is like L.hGetContents, but after each chunk is read, a meter+ - is updated based on the size of the chunk.+ -+ - Note that the meter update is run in unsafeInterleaveIO, which means that+ - it can be run at any time. It's even possible for updates to run out+ - of order, as different parts of the ByteString are consumed.+ -+ - All the usual caveats about using unsafeInterleaveIO apply to the+ - meter updates, so use caution.+ -}+hGetContentsMetered :: Handle -> MeterUpdate -> IO L.ByteString+hGetContentsMetered h meterupdate = lazyRead zeroBytesProcessed+  where+	lazyRead sofar = unsafeInterleaveIO $ loop sofar++	loop sofar = do+		c <- S.hGetSome h defaultChunkSize+		if S.null c+			then do+				hClose h+				return $ L.empty+			else do+				let sofar' = addBytesProcessed sofar $+					S.length c+				meterupdate sofar'+				{- unsafeInterleaveIO causes this to be+				 - deferred until the data is read from the+				 - ByteString. -}+				cs <- lazyRead sofar'+				return $ L.append (L.fromChunks [c]) cs++{- Same default chunk size Lazy ByteStrings use. -}+defaultChunkSize :: Int+defaultChunkSize = 32 * k - chunkOverhead+  where+	k = 1024+	chunkOverhead = 2 * sizeOf (undefined :: Int) -- GHC specific
Utility/NotificationBroadcaster.hs view
@@ -40,14 +40,23 @@ newNotificationBroadcaster :: IO NotificationBroadcaster newNotificationBroadcaster = atomically $ newTMVar [] -{- Allocates a notification handle for a client to use. -}-newNotificationHandle :: NotificationBroadcaster -> IO NotificationHandle-newNotificationHandle b = NotificationHandle+{- Allocates a notification handle for a client to use.+ -+ - An immediate notification can be forced the first time waitNotification+ - is called on the handle. This is useful in cases where a notification+ - may be sent while the new handle is being constructed. Normally,+ - such a notification would be missed. Forcing causes extra work,+ - but ensures such notifications get seen.+ -}+newNotificationHandle :: Bool -> NotificationBroadcaster -> IO NotificationHandle+newNotificationHandle force b = NotificationHandle 	<$> pure b 	<*> addclient   where 	addclient = do-		s <- newEmptySV+		s <- if force+			then newSV ()+			else newEmptySV 		atomically $ do 			l <- takeTMVar b 			putTMVar b $ l ++ [s]
− Utility/Observed.hs 
@@ -1,43 +0,0 @@-module Utility.Observed where--import qualified Data.ByteString.Lazy as L-import qualified Data.ByteString as S-import System.IO-import System.IO.Unsafe-import Foreign.Storable (Storable(sizeOf))--{- This is like L.hGetContents, but after each chunk is read, an action- - is run to observe the size of the chunk.- -- - Note that the observer is run in unsafeInterleaveIO, which means that- - it can be run at any time. It's even possible for observers to run out- - of order, as different parts of the ByteString are consumed.- -- - All the usual caveats about using unsafeInterleaveIO apply to the observers,- - so use caution.- -}-hGetContentsObserved :: Handle -> (Int -> IO ()) -> IO L.ByteString-hGetContentsObserved h observe = lazyRead-  where-	lazyRead = unsafeInterleaveIO loop--	loop = do-		c <- S.hGetSome h defaultChunkSize-		if S.null c-			then do-				hClose h-				return $ L.empty-			else do-				observe $ S.length c-				{- unsafeInterleaveIO causes this to be-				 - deferred until the data is read from the-				 - ByteString. -}-				cs <- lazyRead-				return $ L.append (L.fromChunks [c]) cs--{- Same default chunk size Lazy ByteStrings use. -}-defaultChunkSize :: Int-defaultChunkSize = 32 * k - chunkOverhead-  where-	k = 1024-	chunkOverhead = 2 * sizeOf (undefined :: Int) -- GHC specific
Utility/Rsync.hs view
@@ -8,8 +8,11 @@ module Utility.Rsync where  import Common+import Utility.Metered  import Data.Char+import System.Console.GetOpt+import Data.Tuple.Utils  {- Generates parameters to make rsync use a specified command as its remote  - shell. -}@@ -22,13 +25,14 @@ 	escape s = "'" ++  join "''" (split "'" s) ++ "'"  {- Runs rsync in server mode to send a file. -}-rsyncServerSend :: FilePath -> IO Bool-rsyncServerSend file = rsync $-	rsyncServerParams ++ [Param "--sender", File file]+rsyncServerSend :: [CommandParam] -> FilePath -> IO Bool+rsyncServerSend options file = rsync $+	rsyncServerParams ++ Param "--sender" : options ++ [File file]  {- Runs rsync in server mode to receive a file. -}-rsyncServerReceive :: FilePath -> IO Bool-rsyncServerReceive file = rsync $ rsyncServerParams ++ [File file]+rsyncServerReceive :: [CommandParam] -> FilePath -> IO Bool+rsyncServerReceive options file = rsync $+	rsyncServerParams ++ options ++ [File file]  rsyncServerParams :: [CommandParam] rsyncServerParams =@@ -44,14 +48,13 @@ rsync :: [CommandParam] -> IO Bool rsync = boolSystem "rsync" -{- Runs rsync, but intercepts its progress output and feeds bytes- - complete values into the callback. The progress output is also output- - to stdout. +{- Runs rsync, but intercepts its progress output and updates a meter.+ - The progress output is also output to stdout.   -  - The params must enable rsync's --progress mode for this to work.  -}-rsyncProgress :: (Integer -> IO ()) -> [CommandParam] -> IO Bool-rsyncProgress callback params = do+rsyncProgress :: MeterUpdate -> [CommandParam] -> IO Bool+rsyncProgress meterupdate params = do 	r <- withHandle StdoutHandle createProcessSuccess p (feedprogress 0 []) 	{- For an unknown reason, piping rsync's output like this does 	 - causes it to run a second ssh process, which it neglects to wait@@ -72,7 +75,7 @@ 					Nothing -> feedprogress prev buf' h 					(Just bytes) -> do 						when (bytes /= prev) $-							callback bytes+							meterupdate $ toBytesProcessed bytes 						feedprogress bytes buf' h  {- Checks if an rsync url involves the remote shell (ssh or rsh).@@ -127,3 +130,11 @@ 		([], _) -> Nothing 		(_, []) -> Nothing 		(b, _) -> readish b++{- Filters options to those that are safe to pass to rsync in server mode,+ - without causing it to eg, expose files. -}+filterRsyncSafeOptions :: [String] -> [String]+filterRsyncSafeOptions = fst3 . getOpt Permute+	[ Option [] ["bwlimit"] (reqArgLong "bwlimit") "" ]+  where+	reqArgLong x = ReqArg (\v -> "--" ++ x ++ "=" ++ v) ""
Utility/SafeCommand.hs view
@@ -55,8 +55,16 @@ 		{ env = environ } 	waitForProcess pid +{- Wraps a shell command line inside sh -c, allowing it to be run in a+ - login shell that may not support POSIX shell, eg csh. -}+shellWrap :: String -> String+shellWrap cmdline = "sh -c " ++ shellEscape cmdline+ {- Escapes a filename or other parameter to be safely able to be exposed to- - the shell. -}+ - the shell.+ -+ - This method works for POSIX shells, as well as other shells like csh.+ -} shellEscape :: String -> String shellEscape f = "'" ++ escaped ++ "'"   where
debian/changelog view
@@ -1,3 +1,40 @@+git-annex (4.20130405) unstable; urgency=low++  * Group subcommands into sections in usage. Closes: #703797+  * Per-command usage messages.+  * webapp: Fix a race that sometimes caused alerts or other notifications+    to be missed if they occurred while a page was loading.+  * webapp: Progess bar fixes for many types of special remotes.+  * Build debian package without using cabal, which writes to HOME.+    Closes: #704205+  * webapp: Run ssh server probes in a way that will work when the+    login shell is a monstrosity that should have died 25 years ago,+    such as csh.+  * New annex.largefiles setting, which configures which files+    `git annex add` and the assistant add to the annex.+  * assistant: Check small files into git directly.+  * Remotes can be configured to use other MAC algorithms than HMACSHA1+    to encrypt filenames.+    Thanks, guilhem for the patch.+  * git-annex-shell: Passes rsync --bwlimit options on rsync.+    Thanks, guilhem for the patch.+  * webapp: Added UI to delete repositories. Closes: #689847+  * Adjust built-in preferred content expressions to make most types+    of repositories want content that is only located on untrusted, dead,+    and unwanted repositories.+  * drop --auto: Fix bug that prevented dropping files from untrusted+    repositories.+  * assistant: Fix bug that could cause direct mode files to be unstaged+    from git.+  * Update working tree files fully atomically.+  * webapp: Improved transfer queue management.+  * init: Probe whether the filesystem supports fifos, and if not,+    disable ssh connection caching.+  * Use lower case hash directories for storing files on crippled filesystems,+    same as is already done for bare repositories.++ -- Joey Hess <joeyh@debian.org>  Fri, 05 Apr 2013 10:42:18 -0400+ git-annex (4.20130323) unstable; urgency=low    * webapp: Repository list is now included in the dashboard, and other
debian/control view
@@ -4,7 +4,6 @@ Build-Depends:  	debhelper (>= 9), 	ghc (>= 7.4),-	cabal-install, 	libghc-mtl-dev (>= 2.1.1), 	libghc-missingh-dev, 	libghc-hslogger-dev,
debian/rules view
@@ -1,5 +1,8 @@ #!/usr/bin/make -f +# Avoid using cabal, as it writes to $HOME+export CABAL=runghc Setup.hs+ %: 	dh $@
doc/assistant.mdwn view
@@ -18,25 +18,15 @@ ## documentation  * [[Basic usage|quickstart]]-* Want to make two nearby computers share the same synchronised folder?-  Follow the [[pairing_walkthrough]].-* Want to share a synchronised folder with a friend?+* Want to make two nearby computers share the same synchronised folder?  +  Follow the [[local_pairing_walkthrough]].+* Or perhaps you want to share files between computers in different+  locations, like home and work?  +  Follow the [[remote_sharing_walkthrough]].+* Want to share a synchronised folder with a friend?     Follow the [[share_with_a_friend_walkthrough]].-* Want to archive data to a drive or the cloud?-  Follow the [[archival_walkthrough]]--## command line startup--The git-annex assistant will automatically be started when you log in to-desktop environments like Mac OS X, Gnome, XFCE, and KDE, and the menu item-shown above can be used to open the webapp. On other systems, you may need-to start it by hand.--To start the webapp, run `git annex webapp` at the command line.--To start the assistant without opening the webapp, -you can run the command "git annex assistant --autostart". This is a-good thing to configure your system to run automatically when you log in.+* Want to archive data to a drive or the cloud?  +  Follow the [[archival_walkthrough]].  ## colophon
− doc/assistant/.release_notes.mdwn.swp

binary file changed (20480 → absent bytes)

+ doc/assistant/deleterepository.png view

binary file changed (absent → 22780 bytes)

+ doc/assistant/local_pairing_walkthrough.mdwn view
@@ -0,0 +1,60 @@+So you have two computers in the same building, and you want them to share+the same synchronised folder, communicating directly with each other.++This is incredibly easy to set up with the git annex assistant.++Let's say the two computers are your computer and your friend's computer.+We'll start on your computer, where you open up your git annex dashboard.++[[!img addrepository.png alt="Add another repository button"]]++`*click*`++[[!img pairing.png alt="Pair with another computer"]]++`*click*`++Now the hard bit. You have to think up a secret phrase, and type it in,+(and perhaps get the spelling correct).++[[!img secret.png alt="Enter secret phrase"]]++Now your computer is in pairing mode. When your friend looks at her git+annex dashboard, she sees something like this.++[[!img pairrequest.png alt="Pair request"]]++`*click*`++[[!img secretempty.png alt="Enter same secret phrase"]]++Now it's up to you to let her know what the secret is. As soon as she+enters it, both your computers will be paired, and will begin to sync their+git-annex folders. Just like that you can share files.++----++Something to keep in mind, especially if pairing doesn't seem to be+working, is that the two computers need to be on the same network for this+pairing process to work. Sometimes a building will have more than one+network inside it, and you'll need to connect them both to the same one.+Make sure the wireless network name is the same, or that they're both+plugged into the same router.++Also, the file sharing set up by this pairing only works when both+computers are on the same network. If you go on a trip, any files you+edit will not be visible to your friend until you get back. ++To get around this, you'll often also want to set up+[[jabber_pairing|share_with_a_friend_walkthrough]], and a server+in the cloud, which they can use to exchange files while away.++And also, you can pair with as many other computers as you like, not just+one!++## What does pairing actually do behind the scenes?++It ensures that both repositories have correctly configured +[[remotes|walkthrough/adding_a_remote]] pointing to each other.+If you have already configured this manually, you do not need to+perform pairing.
+ doc/assistant/local_pairing_walkthrough/addrepository.png view

binary file changed (absent → 2259 bytes)

+ doc/assistant/local_pairing_walkthrough/pairing.png view

binary file changed (absent → 6771 bytes)

+ doc/assistant/local_pairing_walkthrough/pairrequest.png view

binary file changed (absent → 5383 bytes)

+ doc/assistant/local_pairing_walkthrough/secret.png view

binary file changed (absent → 5132 bytes)

+ doc/assistant/local_pairing_walkthrough/secretempty.png view

binary file changed (absent → 9575 bytes)

− doc/assistant/pairing_walkthrough.mdwn 
@@ -1,60 +0,0 @@-So you have two computers in the same building, and you want them to share-the same synchronised folder, communicating directly with each other.--This is incredibly easy to set up with the git annex assistant.--Let's say the two computers are your computer and your friend's computer.-We'll start on your computer, where you open up your git annex dashboard.--[[!img addrepository.png alt="Add another repository button"]]--`*click*`--[[!img pairing.png alt="Pair with another computer"]]--`*click*`--Now the hard bit. You have to think up a secret phrase, and type it in,-(and perhaps get the spelling correct).--[[!img secret.png alt="Enter secret phrase"]]--Now your computer is in pairing mode. When your friend looks at her git-annex dashboard, she sees something like this.--[[!img pairrequest.png alt="Pair request"]]--`*click*`--[[!img secretempty.png alt="Enter same secret phrase"]]--Now it's up to you to let her know what the secret is. As soon as she-enters it, both your computers will be paired, and will begin to sync their-git-annex folders. Just like that you can share files.--------Something to keep in mind, especially if pairing doesn't seem to be-working, is that the two computers need to be on the same network for this-pairing process to work. Sometimes a building will have more than one-network inside it, and you'll need to connect them both to the same one.-Make sure the wireless network name is the same, or that they're both-plugged into the same router.--Also, the file sharing set up by this pairing only works when both-computers are on the same network. If you go on a trip, any files you-edit will not be visible to your friend until you get back. --To get around this, you'll often also want to set up-[[jabber_pairing|share_with_a_friend_walkthrough]], and a server-in the cloud, which they can use to exchange files while away.--And also, you can pair with as many other computers as you like, not just-one!--## What does pairing actually do behind the scenes?--It ensures that both repositories have correctly configured -[[remotes|walkthrough/adding_a_remote]] pointing to each other.-If you have already configured this manually, you do not need to-perform pairing.
− doc/assistant/pairing_walkthrough/addrepository.png

binary file changed (2259 → absent bytes)

− doc/assistant/pairing_walkthrough/pairing.png

binary file changed (6771 → absent bytes)

− doc/assistant/pairing_walkthrough/pairrequest.png

binary file changed (5383 → absent bytes)

− doc/assistant/pairing_walkthrough/secret.png

binary file changed (5132 → absent bytes)

− doc/assistant/pairing_walkthrough/secretempty.png

binary file changed (9575 → absent bytes)

doc/assistant/quickstart.mdwn view
@@ -1,3 +1,5 @@+## first run+ To get started with the git-annex assistant, just pick it from your system's list of applications. @@ -13,3 +15,16 @@ interface to add repositories and control the git-annex assistant.  [[!img assistant/running.png]]++## starting on boot++The git-annex assistant will automatically be started when you log in to+desktop environments like Mac OS X, Gnome, XFCE, and KDE, and the menu item+shown above can be used to open the webapp. On other systems, you may need+to start it by hand.++To start the webapp, run `git annex webapp` at the command line.++To start the assistant without opening the webapp, +you can run the command "git annex assistant --autostart". This is a+good thing to configure your system to run automatically when you log in.
doc/assistant/release_notes.mdwn view
@@ -71,7 +71,7 @@ * Archiving or backing up files to Amazon Glacier. See [[archival_walkthrough]]. * [[Sharing repositories with friends|share_with_a_friend_walkthrough]]   contacted through a Jabber server (such as Google Talk).-* [[Pairing|pairing_walkthrough]] two computers that are on the same local+* [[Pairing|local_pairing_walkthrough]] two computers that are on the same local   network (or VPN) and automatically keeping the files in the annex in   sync as changes are made to them. * Cloning your repository to removable drives, USB keys, etc. The assistant@@ -104,7 +104,7 @@ * Archiving or backing up files to Amazon Glacier. * [[Sharing repositories with friends|share_with_a_friend_walkthrough]]   contacted through a Jabber server (such as Google Talk).-* [[Pairing|pairing_walkthrough]] two computers that are on the same local+* [[Pairing|local_pairing_walkthrough]] two computers that are on the same local   network (or VPN) and automatically keeping the files in the annex in   sync as changes are made to them. * Cloning your repository to removable drives, USB keys, etc. The assistant@@ -137,7 +137,7 @@ * Setting up cloud repositories, that are used as backups, archives,   or transfer points between repositories that cannot directly contact   one-another.-* [[Pairing|pairing_walkthrough]] two computers that are on the same local+* [[Pairing|local_pairing_walkthrough]] two computers that are on the same local   network (or VPN) and automatically keeping the files in the annex in   sync as changes are made to them. * Cloning your repository to removable drives, USB keys, etc. The assistant@@ -179,7 +179,7 @@ In general, anything you can configure with the assistant's web app will work. Some examples of use cases supported by this release include: -* [[Pairing|pairing_walkthrough]] two computers that are on the same local+* [[Pairing|local_pairing_walkthrough]] two computers that are on the same local   network (or VPN) and automatically keeping the files in the annex in   sync as changes are made to them. * Cloning your repository to removable drives, USB keys, etc. The assistant@@ -211,7 +211,7 @@ In general, anything you can configure with the assistant's web app will work. Some examples of use cases supported by this release include: -* [[Pairing|pairing_walkthrough]] two computers that are on the same local+* [[Pairing|local_pairing_walkthrough]] two computers that are on the same local   network (or VPN) and automatically keeping the files in the annex in   sync as changes are made to them. * Cloning your repository to removable drives, USB keys, etc. The assistant
+ doc/assistant/remote_sharing_walkthrough.mdwn view
@@ -0,0 +1,12 @@+So you have two computers that are not in the same place, and you want them+to share the same synchronised folder, communicating directly with each other.++[[!inline feeds=no template=bare pages=videos/git-annex_assistant_remote_sharing]]++You can add even more computers using the same method show here.++----++If you have a laptop that is sometimes near another computer, you can+speed up file transfers when it is by also connecting it using the+[[local_pairing_walkthrough]].
doc/assistant/share_with_a_friend_walkthrough.mdwn view
@@ -7,7 +7,7 @@  Start by opening up your git annex dashboard. -[[!img pairing_walkthrough/addrepository.png alt="Add another repository button"]]+[[!img local_pairing_walkthrough/addrepository.png alt="Add another repository button"]]  `*click*`
doc/assistant/thanks.mdwn view
@@ -231,6 +231,9 @@   toy project into something much more, and showed me the interest was there. * Rsync.net, for providing me a free account so I can make sure git-annex   works well with it.+* LeastAuthority.com, for providing me a free Tahoe-LAFS grid account,+  so I can test git-annex with that, and back up the git-annex assistant+  screencasts. * Anna and Mark, for the loan of the video camera; as well as the rest of   my family, for your support. Even when I couldn't explain what I was   working on.
doc/bugs/Creating_an_encrypted_S3_does_not_check_for_presence_of_GPG.mdwn view
@@ -15,4 +15,4 @@  Please provide any additional information below. -[[!tag /design/assistant/OSX]]+[[!tag /design/assistant]]
doc/bugs/Detection_assumes_that_shell_is_bash.mdwn view
@@ -18,3 +18,7 @@ Not everyone has bash as there login-shell.  [[!tag /design/assistant]]++> [[done]]; assistant now uses sh -c "sane shell stuff here" to work+> around csh. (There are systems without bash, but probably fewer without sh)+> --[[Joey]]
doc/bugs/No_progress_bars_with_S3.mdwn view
@@ -19,3 +19,8 @@ When uploading local data to an S3 remote, I see no progress bars. The progress bar area on active uploads stays the same grey as the bar on queued uploads. The status does not change from "0% of...". The uploads are completing, but this makes it very difficult to judge their activity.  The only remotes I currently have setup are S3 special remotes, so I cannot say whether progress bars are working for uploads to other remote types.++> [[done]], this turned out to be a confusion in the progress code;+> parts were expecting a full number of bytes since the start, while+> other parts were sending the number of bytes in a chunk. Result was+> progress bars stuck at 0% often. --[[Joey]]
+ doc/bugs/Segfaults_on_Fedora_18_with_SELinux_enabled.mdwn view
@@ -0,0 +1,65 @@+git-annex version: 4.20130323++Running the webapp with SELinux enabled:++    [0 zerodogg@browncoats annexed]$ git annex webapp --debug+    Launching web browser on file:///home/zerodogg/Documents/annexed/.git/annex/webapp.html+    /home/zerodogg/bin/git-annex: line 25:  5801 Segmentation fault      (core dumped) "$base/runshell" git-annex "$@"++After disabling SELinux it works just fine. This is on a freshly installed (default settings) Fedora 18 on x86-64.++Running the assistant also works, but segfaults when attempting to open the webapp:++    [0 zerodogg@browncoats annexed]$ git annex assistant &+    [1] 6241+    [0 zerodogg@browncoats annexed]$ +    [0 zerodogg@browncoats annexed]$ git annex webapp --debug+    Launching web browser on file:///home/zerodogg/Documents/annexed/.git/annex/webapp.html+    /home/zerodogg/bin/git-annex: line 25:  6322 Segmentation fault      (core dumped) "$base/runshell" git-annex "$@"+    [139 zerodogg@browncoats annexed]$ Created new window in existing browser session.++Here's what `dmesg` says:++    [   71.488843] SELinux: initialized (dev proc, type proc), uses genfs_contexts+    [  115.443932] git-annex[3985]: segfault at e6e62984 ip 0000000009b8085a sp 00000000f4bfd028 error 4 in git-annex[8048000+1c75000]+    [  125.148819] SELinux: initialized (dev proc, type proc), uses genfs_contexts+    [  125.230155] git-annex[4043]: segfault at e6eda984 ip 0000000009b8085a sp 00000000f63fd028 error 4 in git-annex[8048000+1c75000]+    [  406.855659] SELinux: initialized (dev proc, type proc), uses genfs_contexts+    [  407.033966] git-annex[5806]: segfault at e6faa984 ip 0000000009b8085a sp 00000000f6dfd028 error 4 in git-annex[8048000+1c75000]+    [  462.368045] git-annex[6279]: segfault at e6f76984 ip 0000000009b8085a sp 00000000f49fd028 error 4 in git-annex[8048000+1c75000]+    [  465.714636] SELinux: initialized (dev proc, type proc), uses genfs_contexts+    [  465.930434] git-annex[6329]: segfault at e6e7a984 ip 0000000009b8085a sp 00000000f63fd028 error 4 in git-annex[8048000+1c75000]+    [  560.570480] git-annex[7050]: segfault at e7022984 ip 0000000009b8085a sp 00000000f54fd028 error 4 in git-annex[8048000+1c75000]+    [  565.510664] SELinux: initialized (dev proc, type proc), uses genfs_contexts+    [  565.688681] git-annex[7108]: segfault at e7196984 ip 0000000009b8085a sp 00000000f54fd028 error 4 in git-annex[8048000+1c75000]++Running the whole thing with --debug doesn't appear to provide anything useful:++    [0 zerodogg@browncoats annexed]$ git annex assistant --debug &+    [1] 7018+    [0 zerodogg@browncoats annexed]$ [2013-03-24 16:27:02 CET] read: git ["--git-dir=/home/zerodogg/Documents/annexed/.git","--work-tree=/home/zerodogg/Documents/annexed","show-ref","git-annex"]+    [2013-03-24 16:27:02 CET] read: git ["--git-dir=/home/zerodogg/Documents/annexed/.git","--work-tree=/home/zerodogg/Documents/annexed","show-ref","--hash","refs/heads/git-annex"]+    [2013-03-24 16:27:02 CET] read: git ["--git-dir=/home/zerodogg/Documents/annexed/.git","--work-tree=/home/zerodogg/Documents/annexed","log","refs/heads/git-annex..f2260840bd9563f3d9face53dddd6807813860cd","--oneline","-n1"]+    [2013-03-24 16:27:02 CET] read: git ["--git-dir=/home/zerodogg/Documents/annexed/.git","--work-tree=/home/zerodogg/Documents/annexed","log","refs/heads/git-annex..798526ef1315811296b1ac95d4cf97c72141ad29","--oneline","-n1"]+    [2013-03-24 16:27:02 CET] read: git ["--git-dir=/home/zerodogg/Documents/annexed/.git","--work-tree=/home/zerodogg/Documents/annexed","log","refs/heads/git-annex..0d827b1ef545a88e94ee8cc973e54a1b74d216f4","--oneline","-n1"]+    [2013-03-24 16:27:02 CET] read: git ["--git-dir=/home/zerodogg/Documents/annexed/.git","--work-tree=/home/zerodogg/Documents/annexed","log","refs/heads/git-annex..1d8f91411b827c4d59735dbc572e7f278e870e43","--oneline","-n1"]+    [2013-03-24 16:27:02 CET] read: git ["--git-dir=/home/zerodogg/Documents/annexed/.git","--work-tree=/home/zerodogg/Documents/annexed","log","refs/heads/git-annex..cc442416b325866139db6dbe374bddacda6fef91","--oneline","-n1"]+    [2013-03-24 16:27:02 CET] read: git ["--git-dir=/home/zerodogg/Documents/annexed/.git","--work-tree=/home/zerodogg/Documents/annexed","log","refs/heads/git-annex..3c2f44ffd82df1a0ae8858bdf2610e933b105a09","--oneline","-n1"]+    [2013-03-24 16:27:02 CET] read: git ["--git-dir=/home/zerodogg/Documents/annexed/.git","--work-tree=/home/zerodogg/Documents/annexed","log","refs/heads/git-annex..fb8819ca92d9a2ed39e6d329160b5f8da60df83f","--oneline","-n1"]+    [2013-03-24 16:27:02 CET] read: git ["--git-dir=/home/zerodogg/Documents/annexed/.git","--work-tree=/home/zerodogg/Documents/annexed","log","refs/heads/git-annex..68d0f936ee044b0ca34cf4029bcd6274fed88499","--oneline","-n1"]+    [2013-03-24 16:27:02 CET] read: git ["--git-dir=/home/zerodogg/Documents/annexed/.git","--work-tree=/home/zerodogg/Documents/annexed","log","refs/heads/git-annex..3ba3dfef6340196126f4fc630b5048188230d1ff","--oneline","-n1"]+    [2013-03-24 16:27:02 CET] chat: git ["--git-dir=/home/zerodogg/Documents/annexed/.git","--work-tree=/home/zerodogg/Documents/annexed","cat-file","--batch"]+    +    [1]  + done       GITWRAP annex assistant --debug+    [0 zerodogg@browncoats annexed]$ git annex webapp --debug &+    [1] 7082+    [0 zerodogg@browncoats annexed]$ Launching web browser on file:///home/zerodogg/Documents/annexed/.git/annex/webapp.html+    /home/zerodogg/bin/git-annex: line 25:  7088 Segmentation fault      (core dumped) "$base/runshell" git-annex "$@"+    +    [1]  + exit 139   GITWRAP annex webapp --debug+    [0 zerodogg@browncoats annexed]$ Created new window in existing browser session.++> On IRC it developed that it segfaulted at other times, and gdb complained+> of a library mismatch. Seems something changed in Fedora libc, and +> the 32 bit binary is not working on 64 bit. I've brought back the 64 bit+> standalone builds, which work. [[done]] --[[Joey]]
doc/bugs/The_webapp_doesn__39__t_allow_deleting_repositories.mdwn view
@@ -21,3 +21,13 @@     Codename:	precise  [[!tag /design/assistant]]++> Status: You can delete the current repository. You can also remove+> repositories from the list of remotes (without deleting their content)+> and you can tell it you want to stop using a remote, and it will+> suck all content off that remote until it's empty.+> +> Still todo: Detect when a remote has been sucked dry, and actually delete+> it. --[[Joey]]++>> [[done]] --[[Joey]]
doc/bugs/WEBDAV_443.mdwn view
@@ -302,3 +302,6 @@ > that does not support symlinks, and may be broken in some other way > as well, but is not relevant to this bug report.) > --[[Joey]] ++> Closing this bug since the bug submitter cannot reproduce it and+> had many problems that seems to point at a bad build. [[done]] --[[Joey]]
+ doc/bugs/allows_repository_with_the_same_name_twice.mdwn view
@@ -0,0 +1,23 @@+What steps will reproduce the problem?++Unsure. I believe:++* Add a git remote+* Mark it as dead+* Remove the git remote, re-add with the same name++What is the expected output? What do you see instead?++When I do a `git annex status` I see:++ 	04e701b5-8a22-4391-ad74-d75dde715c7b -- bigserver+ 	6ddfda5d-0f17-45a9-b41a-2a626a823101 -- bigserver++What version of git-annex are you using? On what operating system?++4.20130323 on OSX and Linux++Please provide any additional information below.++Trying to get a file from bigserver kept on failing with the message "Try making some of these repositories available". Which led me on a wild goose chases blaming SSH keys and PATH issues.+
+ doc/bugs/git-annex_add_should_repack_as_it_goes.mdwn view
@@ -0,0 +1,24 @@+What steps will reproduce the problem?++1. Create a fresh git-annex repository+2. Add a directory tree to it with about 300,000 files in it+3. wait+4. change the tree; attempt a git commit++What is the expected output? What do you see instead?++git commit hangs due to the large number of loose objects created during the git annex add. If git annex had stopped to repack the git repo a few times along the way, I think this might have been avoided.++What version of git-annex are you using? On what operating system?++git-annex version: 4.20130323+local repository version: 3+default repository version: 3+supported repository versions: 3 4+upgrade supported from repository versions: 0 1 2+build flags: Assistant Webapp Pairing Testsuite S3 WebDAV FsEvents XMPP DNS++Darwin pluto.local 12.3.0 Darwin Kernel Version 12.3.0: Sun Jan  6 22:37:10 PST 2013; root:xnu-2050.22.13~1/RELEASE_X86_64 x86_64+(Mac OS 10.8.3)++git version 1.8.2
doc/bugs/host_with_rysnc_installed__44___not_recognized.mdwn view
@@ -13,3 +13,7 @@  [[!meta title="webapp rsync probe command failed on FreeNAS box"]] [[!tag /design/assistant]]++> [[done]]; based on the error message it's using csh and +> the assistant will now wrap its shell commands to work with csh.+> --[[Joey]]
doc/bugs/ssh_connection_caching_broken_on_NTFS.mdwn view
@@ -61,3 +61,6 @@ but it would be nifty if git-annex could detect the filesystem type and do The Right Thing.  Thanks for all the work on git-annex -- it's an awesome project!++> [[done]], `git annex init` now probes for fifo support and disables ssh+> connection caching if it cannot make one. --[[Joey]]
doc/coding_style.mdwn view
@@ -24,7 +24,7 @@ The definitions within the where clause should be put on separate lines, each indented with a tab. -	foo = do+	main = do 		foo 		bar 		foo
doc/design/assistant.mdwn view
@@ -11,13 +11,14 @@ * Month 4 "cloud": [[!traillink cloud]] [[!traillink transfer_control]] * Month 5 "cloud continued": [[!traillink xmpp]] [[!traillink more_cloud_providers]] * Month 6 "9k bonus round": [[!traillink desymlink]]-* Month 7: user-driven features and polishing; +* Month 7: user-driven features and polishing;   [presentation at LCA2013](http://mirror.linux.org.au/linux.conf.au/2013/mp4/gitannex.mp4) * Month 8: [[!traillink Android]]+* Month 9: [[screencasts|videos]] and polishing  We are, approximately, here: -* Months 9-11: more user-driven features and polishing (see remaining TODO items in all pages above)+* Months 10-11: more user-driven features and polishing * Month 12: "Windows purgatory" [[Windows]]  ## porting@@ -28,11 +29,16 @@  ## not yet on the map: +* [[rate_limiting]] * [[partial_content]]-* encrypted git remotes using [git-remote-gcrypt](https://github.com/blake2-ppc/git-remote-gcrypt)+* [[encrypted_git_remotes]] * [[deltas]] * [[leftovers]] * [[other todo items|todo]]++## polls++I post [[polls]] occasionally to make decisions. You can vote!  ## blog
doc/design/assistant/OSX.mdwn view
@@ -2,15 +2,9 @@  * autostart the assistant on OSX, using launchd **done** * icon to start webapp **done**+* use FSEvents to detect file changes (better than kqueue) **done** * Use OSX's "network reachability functionality" to detect when on a network   <http://developer.apple.com/library/mac/#documentation/Networking/Conceptual/SystemConfigFrameworks/SC_Intro/SC_Intro.html#//apple_ref/doc/uid/TP40001065>--Gripes:--* The assistant has to wait a second when a new file is created,-  to work around some bad behavior when pasting a file into the annex.-  [[details|bugs/pasting_into_annex_on_OSX]]. That's one more second-  before the file is synced out.  Bugs:
doc/design/assistant/android.mdwn view
@@ -42,5 +42,9 @@ * Enable WebDAV support. Currently needs template haskell (could be avoided   by changing the DAV library to not use it), and also networking support,   which seems broken in current ghc-android.+* XMPP support. I got all haskell libraries installed, but it fails to find+  several C libraries at link time.+* Get local pairing to work. network-multicast and network-info don't+  currently install. * Get test suite to pass. Current failure is because `git fetch` is somehow   broken with local repositories.
+ doc/design/assistant/blog/day_222__back.mdwn view
@@ -0,0 +1,16 @@+Back from my trip. Spent today getting caught up.++Didn't do much while I was away. Pushed out a new release on Saturday.+Made `git annex` usage display nicer.++Fixed some minor webapp bugs today. The interesting bug was a+race that sometimes caused alerts or other notifications to be+missed and not be immediately displayed if they occurred while+a page was loading. You sometimes had to hit reload to see them,+but not anymore!++Checked if the `push.default=simple` change in upcoming git release will+affect git-annex. It shouldn't affect the assistant, or `git annex sync`,+since they always list all branches to push explicitly. But if you `git push`+manually, when the default changes that won't include the git-annex branch+in the push any longer.
+ doc/design/assistant/blog/day_223__progress_revisited.mdwn view
@@ -0,0 +1,24 @@+Went out and tried for the second time to record a screencast demoing+setting up syncing between two computers using just Jabber and a cloud+remote. I can't record this one at home, or viewers would think git-annex+was crazy slow, when it's just my dialup. ;) But once again I encountered+bugs, and so I found myself working on progress bars today, unexpectedly.++Seems there was confusion in different parts of the progress bar code+about whether an update contained the total number of bytes transferred, or+the delta of bytes transferred since the last update. One way this bug+showed up was progress bars that seemed to stick at 0% for a long time.+Happened for most special remotes, although not for rsync or git remotes.+In order to fix it comprehensively, I added a new BytesProcessed data type,+that is explicitly a total quantity of bytes, not a delta. And checked and+fixed all the places that used a delta as that type was knitted into+the code.++(Note that this doesn't necessarily fix every problem with progress bars.+Particularly, buffering can now cause progress bars to seem to run ahead+of transfers, reaching 100% when data is still being uploaded. Still,+they should be a lot better than before.)++I've just successfully run through the Jabber + Cloud remote setup process+again, and it seems to be working great now. Maybe I'll still get the+screencast recorded by the end of March.
+ doc/design/assistant/blog/day_224__annex.largefiles.mdwn view
@@ -0,0 +1,23 @@+Built a feature for power users today. `annex.largefiles` can be+configured to specify what files `git annex add` and the assistant should+put into the annex. It uses the same syntax as [[/preferred_content]],+so arbitrarily complex expressions can be built.++For example, a game written in C with some large data files could+include only 100kb or larger files, that are not C code:++	annex.largefiles = largerthan=100kb and not (include=*.c or include=*.h) ++The assistant will commit small files to git directly!+`git annex add`, being a lower level tool, skips small files+and leaves it up to you to `git add` them as desired.++It's even possible to tell the assistant that no file is too large to be+committed directly to git. `git config annex.largefiles 'exclude=*'`+The result should be much like using SparkleShare or dvcs-autosync.++-----++Also today, made the remote ssh server checking code in the webapp+deal with servers where the default shell is csh or some other non-POSIX+shell.
+ doc/design/assistant/blog/day_225__back_from_the_dead.mdwn view
@@ -0,0 +1,47 @@+I've posted a poll: [[polls/goals_for_April]]++----++Today added UI to the webapp to delete repositories, which many+users have requested. It can delete the local repository,+with appropriate cautions and sanity checks:++[[!img /assistant/deleterepository.png]]++More likely, you'll use it to remove a remote, which is done with no muss+and no fuss, since that doesn't delete any data and the remote can always+be added back if you change your mind.++It also has an option to fully delete the data on a remote. This doesn't+actually delete the remote right away. All it does is marks the remote+as untrusted[1], and configures it to not want any content.+This causes all the content on it to be sucked off to whatever+other repositories can hold it.++I had to adjust the preferred content expressions to make that work. For+example, when deleting an archive drive, your local (client) repository+does not normally want to hold all the data it has in "archive"+directories. With the adjusted preferred content expressions, any data on+an untrusted or dead repository is wanted. An interesting result is that+once a client repository has moved content from an untrusted remote, it+will decide it doesn't want it anymore, and shove it out to any other+remote that will accept it. Which is just the behavior we want. All it took+to get all this behavior is adding "or (not copies=semitrusted:1)" to the+preferred content expressions!++For most special remotes, just sucking the data from them is sufficient to+pretty well delete them. You'd want to delete an Amazon bucket or glacier+once it's empty, and git repositories need to be fully deleted. Since this+would need unique code for each type of special remote, and it would be+code that a) deletes possibly large quantities of data with no real way to+sanity check it and b) doesn't get run and tested very often; it's not+something I'm thrilled about fully automating. However, I would like to+make the assistant detect when all the content has been sucked out of a+remote, and pop up at least a message prompting to finish the deletion.+Future work.++-----++[1] I really, really wanted to mark it dead, but letting puns drive code+is probably a bad idea. I had no idea I'd get here when I started+developing this feature this morning.. Honest!
+ doc/design/assistant/blog/day_226__poll_results.mdwn view
@@ -0,0 +1,28 @@+Both the assistant and `git annex drop --auto` refused to drop files from+untrusted repositories. Got that fixed.++Finally recorded the xmpp pairing screencast. In one perfect take, which+somehow `recordmydesktop` lost the last 3 minutes of.+Argh! Anyway I'm editing it now, so, look for that screencast soon.++The [[polls/goals_for_April]] poll results are in. ++* There have been no votes at all for working on+  cloud remotes. Seems that git-annex supports enough cloud remotes already.+* A lot of people want the Android webapp port to be done, so I will+  probably spend some time on that this month.+* Interest in other various features is split. I am surprised how many +  want git-remote-gcrypt, compared to the features that would make+  syncing use less bandwidth. Doesn't git push over xmpp cover most+  of the use cases where git-remote-gcrypt would need to be used with the+  assistant?+* Nearly as many people as want features, want me to work on bug+  fixing and polishing what's already there.+  So I should probably continue to make screencasts, since they often force+  me to look at things with fresh eyes and see and fix problems. And of course,+  continue working on bugs as they're reported.+* I'm not sure what to make of the 10% who want me to add direct mode support.+  Since direct mode is already used by default, perhaps they want+  me to take time off? :) (I certainly need to fix the+  [[bugs/Direct_mode_keeps_re-checksuming_duplicated_files]] bug, and one other+  direct mode bug I discovered yesterday.)
+ doc/design/assistant/blog/day_227__bigfixing_all_day_today.mdwn view
@@ -0,0 +1,21 @@+The [[xmpp screencast|videos/git-annex_assistant_remote_sharing]]+is at long last done!++----++Fixed a bug that could cause the assistant to unstage files+from git sometimes. This happened because of a bad optimisation; adding a+file when it's already present and unchanged was optimised to do nothing.+But if the file had just been removed, and was put back, this resulted+in the removal being staged, and the add not being staged. Ugly bug,+although the assistant's daily sanity check automatically restaged the+files.++Underlying that bug was a more important problem: git-annex does not always+update working tree files atomically. So a crash at just the wrong instant+could cause a file to be deleted from the working tree. I fixed that too;+all changes to files in the working tree should now be staged in a temp+file, which is renamed into place atomically.++Also made a bunch of improvements to the dashboard's transfer display, and+to the handling of the underlying transfer queue.
+ doc/design/assistant/blog/day_228__more_work_on_repository_removals.mdwn view
@@ -0,0 +1,27 @@+Getting back to the repository removal handling from Sunday, I made the+assistant detect when a repository that has been marked as unwanted becomes+empty, and finish the removal process.++I was able to add this to the expensive transfer scan without making it any+more expensive than it already was, since that scan already looks at the+location of all keys. Although when a remote is detected as empty, it then+does one more check, equivilant to `git annex unused`, to find any+remaining objects on the remote, and force them off.++I think this should work pretty well, but it needs some testing and+probably some UI work.++----++Andy spotted a bug in the preferred content expressions I was using to+handle untrusted remotes. So he saved me several hours dealing with an ugly+bug at some point down the line. I had misread my own preferred content+expression documentation, and `copies=semitrusted:1` was not doing what I+thought it was. Added a new syntax that does what I need,+`copies=semitrusted+:1`++----++The 64 bit linux standalone builds are back. Apparently the 32 bit builds+have stopped working on recent Fedora, for reasons that are unclear. I set+up an autobuilder to produce the 64 bit builds.
+ doc/design/assistant/blog/day_229__rainy_day_bugfixes.mdwn view
@@ -0,0 +1,17 @@+Got caught up on bug reports and made some bug fixes.++The one bug I was really worried about, a strange file corruption problem+on Android, turned out not to be a bug in git-annex. (Nor is it a bug that+will affect regular users.)++The only interesting bug fixed was a mixed case hash directory name+collision when a repository is put on a VFAT filesystem (or other+filesystem with similar semantics). I was able to fix that nicely; since+such a repository will be in crippled filesystem mode due to other+limitations of the filesystem, and so won't be using symlinks,+it doesn't need to use the mixed case hash directory names.++Last night, finished up the repository removal code, and associated UI+tweaks. It works very well.++Will probably make a release tomorrow.
+ doc/design/assistant/encrypted_git_remotes.mdwn view
@@ -0,0 +1,21 @@+Encrypted git remotes are now possible +using [git-remote-gcrypt](https://github.com/blake2-ppc/git-remote-gcrypt).++There are at least two use cases for this in the assistant:++* Storing an encrypted git repository on a local drive.+* Or on a remote server. This could even allow using github. But more+  likely would be a shell server that has git-annex-shell on it so can+  also store file contents, and which is not trusted with unencrypted data.++git-remote-gcrypt is already usable with git-annex. What's needed is+to make sure it's installed (ie, get it packaged into distros or embedded+into git-annex), and make it easy to set up from the webapp.++Hmm, this will need gpg key creation, so would also be a good opportunity+to make the webapp allow using that for special remotes too.++One change is needed in git-annex core.. It currently does not support+storing encrypted files on git remotes, only on special remotes. Perhaps+the way to deal with this is to make it consider git-remote-grypt remotes+to be a special remote type?
+ doc/design/assistant/polls/goals_for_April.mdwn view
@@ -0,0 +1,17 @@+What should I work on in April? I expect I could get perhaps two of these+features done in a month if I'm lucky. I have only 3 more funded months,+and parts of one will be spent working on porting to Windows, so choose wisely!+--[[Joey]]++[[!poll open=yes expandable=yes 4 "upload and download rate limiting" 15 "get webapp working on Android" 5 "deltas: speed up syncing modified versions of existing files" 8 "encrypted git remotes using git-remote-gcrypt" 0 "add support for more cloud storage remotes" 19 "don't work on features, work on making it easier to install and use" 2 "Handle duplicate files" 6 "direct mode (aka real files instead of symlinks) [already done --joey]" 3 "start windows port now"]]++References:++* [[rate_limiting]]+* [[Android]]+* [[deltas]] to speed up syncing modified files (at least for remotes using rsync)+* [[encrypted_git_remotes]]+* [[more_cloud_providers]] (OpenStack Swift, Owncloud, Google drive,+  Dropbox, Mediafire, nimbus.io, Mega, etc.)+* [[old poll on "what is preventing me from using git-annex assistant"|what_is_preventing_me_from_using_git-annex_assistant]]+  (many of the items on it should be fixed now, but I have plenty of bug reports to chew on still)
+ doc/design/assistant/rate_limiting.mdwn view
@@ -0,0 +1,57 @@+Webapp needs a simple speed control knob, especially to avoid saturating +bandwidth on uploads.++We have basic throttling support in git-annex for rsync,+but none for any special remotes. A good first step would be to expose+this in the webapp, and ensure that `git-annex-shell` also honors it when+sending/receiving data.++We actually need two speed controls, one for upload and one for download.++It is probably not necessary to throttle git push/pull operations, as the+data transfers tend to be small. Only throttling file transfers is+essential.++## possibility: trickle++Since `git-annex transferkeys` is a separate process, one easy option would+be to run it inside `trickle`. If the user changes the bandwidth limits,+it could kill the transfer and restart it with different trickle options.++Problem: Not all special remotes support resuming transfers, so this is+suboptimal. (So too are the pause/resume buttons, when using those+remotes!)++`trickle` is available for OSX as well as Linux and BSDs.+<http://hints.macworld.com/comment.php?mode=view&cid=65362>+<http://mac.softpedia.com/get/Network-Admin/Trickle.shtml>+It is probably not easily available for Android, as it uses `LD_PRELOAD`.++## possibility: built in IO limiting++A cleaner method would be to do the limiting inside git-annex. We already+have metered file IO. It should be possible to make the meter not only report+on the transfer speed, but detect when it's going too fast, and delay. This+will delay the file streaming through the special remote's transfer code,+so should work for a variety of special remotes. (Not for rsync or bup+or git-annex-shell though, so those need to be handled separately.)++Should work well for uploads at least. I don't know how well it would work+for throttling downloads; the sender may just keep sending data and the+data buffer before it gets to the IO meter. Maybe once the buffers fill the+OS would have the TCP throttled down. Needs investigation; trickle claims+to throttle downloads.++## communications channels++There would need to be a communication channel for the assistant to tell+`git annex transferkeys` when the rate limit has changed. It could for+example send it a SIGUSR1, and then leave it up to the process to reload+the git config. Inside the IO meter, we could have an MVar that contains+the current throttle value, so the IO meter could check it each time it's+called and adjust its throttling appropriately.++Ideally, the assistant could also communicate in the same way with+`git-annex-shell` to tell it when the limit has changed. Since+`git-annex-shell` uses rsync, it would need to abort the transfer, and rely+on the other side retrying to start it up with the new limit.
doc/design/assistant/syncing.mdwn view
@@ -25,11 +25,6 @@ ## TODO  * Test MountWatcher on LXDE.-* git-annex needs a simple speed control knob, which can be plumbed-  through to, at least, rsync. A good job for an hour in an-  airport somewhere.-* Find a way to probe available outgoing bandwidth, to throttle so-  we don't bufferbloat the network to death. * Add a hook, so when there's a change to sync, a program can be run    and do its own signaling. * --debug will show often unnecessary work being done. Optimise.
doc/design/encryption.mdwn view
@@ -59,10 +59,11 @@ if it has the file. This can be done without enumeration, although it will mean running gpg once per file fscked, to get the encrypted filename. -So, the files stored in the remote should be encrypted. But, it needs-to be a repeatable encryption, so they cannot just be gpg encrypted,-that would yeild a new name each time. Instead, HMAC is used. Any hash-could be used with HMAC; currently SHA1 is used.+So, the files stored in the remote should be encrypted. But, it needs to+be a repeatable encryption, so they cannot just be gpg encrypted, that+would yeild a new name each time. Instead, HMAC is used. Any hash could+be used with HMAC. SHA-1 is the default, but [[other_hashes|/encryption]]+can be chosen for new remotes.  It was suggested that it might not be wise to use the same cipher for both gpg and HMAC. Being paranoid, it's best not to tie the security of one
doc/encryption.mdwn view
@@ -21,6 +21,13 @@ Typically, you will say "encryption=2512E3C7" to use a specific gpg key. Or, you might say "encryption=joey@kitenet.net" to search for matching keys. +The default MAC algorithm to be applied on the filenames is HMACSHA1. A+stronger one, for instance HMACSHA512, one can be chosen upon creation+of the special remote with the option `mac=HMACSHA512`. The available+MAC algorithms are HMACSHA1, HMACSHA224, HMACSHA256, HMACSHA384, and+HMACSHA512. Note that it is not possible to change algorithm for a+non-empty remote.+ The [[encryption_design|design/encryption]] allows additional encryption keys to be added on to a special remote later. Once a key is added, it is able to access content that has already been stored in the special remote.
+ doc/forum/Howto_remove_unused_files.mdwn view
@@ -0,0 +1,31 @@+Hello.++My case: I have somehow managed to get my repo, with quite much stuff inside it messed up.++There is single directory 'cities' containing quite many files (>10k) that i would rather see gone (and keep the tar.bz version of it ..). I tried doing ++    git drop --force++that works fine, but the files are still there after sync. ++git annex unused says just 'ok' so i guess it thinks they are still used somewhere. I tried to look where, but i ended up just doing git annex drop -f my_remote_here test_file_name for each of my remotes. This doesnt help. +How can i get rid of these files? Doing git annex fsck shows that +++So, try to search what is the key:++     % ls -lah cities/diskcache/config.cfg+     lrwxrwxrwx 1 XX XXX 190 Nov 29 05:52 cities/diskcache/config.cfg -> ../../../../.git/annex/objects/qm/M6/SHA256-s32--4f5ce34d1b0b8d854a315530b2fdcbfa9c3067636a2aa5433a04402db4151dce/SHA256-s32--4f5ce34d1b0b8d854a315530b2fdcbfa9c3067636a2aa5433a04402db4151dce+     sundberg@sundberg-MS-7680 ~/git-repository/ubuntu.iso/Archive/Maps+     % git log --stat --all -SSHA256-s32--4f5ce34d1b0b8d854a315530b2fdcbfa9c3067636a2aa5433a04402db4151dce/SHA256-s32--4f5ce34d1b0b8d854a315530b2fdcbfa9c3067636a2aa5433a04402db4151dce+     commit 51a57a023774ff80408210828f298f5c42a7e0be+     Author: XXXX+     Date:   Sun Dec 9 13:42:40 2012 +0200+        git-annex automatic sync+     Archive/Maps/cities/diskcache/config.cfg |    1 ++     1 file changed, 1 insertion(+)++So how can i deduce what is the remote i should try to clean up ?+++Thanks!
+ doc/forum/Stupid_mistake:_recoverable__63__.mdwn view
@@ -0,0 +1,31 @@+Hi,++I was a bit hasty the other day and did something stupid.  I+added a new folder to git annex.  Something like++    git annex add my-important folder++my-important folder contains a lot of files and it took a couple+of minutes to add.  When I then tried to do++    git commit -am 'added files'++per the walkthrough I got an error (9, as I recall).  I thought+I'd added too many files or something so I wanted to start over+and perhaps I didn't fully understand the mechanisms of annex I+did the following++    git reset --hard .++Unfortunately, did replaced my files with a bunch of symlinks,+rather than making git annex forget and go back to the previous+stage as I had hoped.++I have managed to recover most of my files from backup, but some+of them I still can't recover.  Is there any way back?  It seems+I still have the files in my git folder.++Thanks,+Rasmus++PS: Sorry, I shouldn't have made this text rather than Markdown.
+ doc/forum/Will_git-annex_solve_my_problem__63__.mdwn view
@@ -0,0 +1,7 @@+Here's my current situation:++I have a box which creates about a dozen files periodically. All files add up to about 1GB in size. The files are text and sorted. I then rsync the files to n servers. The rsync diff algorithm transfers way less than n * 1GB because the files are largely the same. However, this distribution technique is inefficient because I must run n rsync processes in parallel and the rsync diff algorithm takes a lot of CPU.++How could I use git-annex instead of rsync?++Because the box producing the new files also has the old files, then presumably git could calculate the diffs for each file once instead of n times as with the rsync solution? Then only the diffs need be distributed to the n servers... using git-annex? And finally the newly updated version of the dozen files needs to be available on each of the n servers. Ideally, the diffs would not mount up over time on either the publishing server or the n servers, thus causing out of disk problems etc. How to deploy git-annex to solve my problem?
doc/git-annex.mdwn view
@@ -688,6 +688,9 @@   copies, on remotes with the specified trust level. For example,   "--copies=trusted:2" +  To match any trust level at or higher than a given level, use+  'trustlevel+'. For example, "--copies=semitrusted+:2"+ * --copies=groupname:number    Matches only files that git-annex believes have the specified number of@@ -735,6 +738,23 @@    Closes a group of file matching options. +# PREFERRED CONTENT++Each repository has a preferred content setting, which specifies content+that the repository wants to have present. These settings can be configured+using `git annex vicfg`. They are used by the `--auto` option, and+by the git-annex assistant.++The preferred content settings are similar, but not identical to+the file matching options specified above, just without the dashes.+For example:++	exclude=archive/* and (include=*.mp3 or smallerthan=1mb)++The main differences are that `exclude=` and `include=` always+match relative to the top of the git repository, and that there is+no equivilant to --in.+ # CONFIGURATION  Like other git commands, git-annex is configured via `.git/config`.@@ -765,6 +785,19 @@    The default reserve is 1 megabyte. +* `annex.largefiles`++  Allows configuring which files `git annex add` and the assistant consider+  to be large enough to need to be added to the annex. By default,+  all files are added to the annex.++  The value is a preferred content expression. See PREFERRED CONTENT+  for details.++  Example:++	annex.largefiles = largerthan=100kb and not (include=*.c or include=*.h)+ * `annex.queuesize`    git-annex builds a queue of git commands, in order to combine similar@@ -790,10 +823,6 @@   the accuracy will make `git annex unused` consume more memory;   run `git annex status` for memory usage numbers. -* `annex.version`--  Automatically maintained, and used to automate upgrades between versions.- * `annex.sshcaching`    By default, git-annex caches ssh connections@@ -819,11 +848,15 @@   Set to false to prevent the git-annex assistant from automatically   committing changes to files in the repository. +* `annex.version`++  Automatically maintained, and used to automate upgrades between versions.+ * `annex.direct` -  Set to true to enable an (experimental) mode where files in the repository-  are accessed directly, rather than through symlinks. Note that many git-  and git-annex commands will not work with such a repository.+  Set to true when the repository is in direct mode. Should not be set+  manually; use the "git annex direct" and "git annex indirect" commands+  instead.  * `annex.crippledfilesystem` @@ -988,7 +1021,8 @@ 	*.ogg annex.backend=SHA256E  The numcopies setting can also be configured on a per-file-type basis via-the `annex.numcopies` attribute in `.gitattributes` files.+the `annex.numcopies` attribute in `.gitattributes` files. This overrides+any value set using `annex.numcopies` in `.git/config`. For example, this makes two copies be needed for wav files:  	*.wav annex.numcopies=2
doc/install/Fedora.mdwn view
@@ -6,6 +6,21 @@  ---- +To install the latest version of git-annex on Fedora 18 and later, you can use `cabal`:++<pre>+# Install dependencies+sudo yum install libxml2-devel gnutls-devel libgsasl-devel ghc cabal-install happy alex libidn-devel+# Update the cabal list+cabal update+# Install c2hs, required by dependencies of git-annex, but not automatically installed+cabal install --bindir=$HOME/bin c2hs+# Install git-annex+cabal install --bindir=$HOME/bin git-annex+</pre>++----+ Older version? Here's an installation recipe for Fedora 14 through 15.  <pre>@@ -22,4 +37,3 @@  Note: You can't just use `cabal install git-annex`, because Fedora does not yet ship ghc 7.4.-
doc/install/Linux_standalone.mdwn view
@@ -22,5 +22,5 @@  A daily build is also available. -* [download tarball](http://downloads.kitenet.net/git-annex/autobuild/i386/git-annex-standalone-i386.tar.gz) ([build logs](http://downloads.kitenet.net/git-annex/autobuild/i386/))-+* i386: [download tarball](http://downloads.kitenet.net/git-annex/autobuild/i386/git-annex-standalone-i386.tar.gz) ([build logs](http://downloads.kitenet.net/git-annex/autobuild/i386/))+* amd64: [download tarball](http://downloads.kitenet.net/git-annex/autobuild/amd64/git-annex-standalone-amd64.tar.gz) ([build logs](http://downloads.kitenet.net/git-annex/autobuild/amd64/))
+ doc/install/OSX/comment_15_336e0acb00e84943715e69917643a69e._comment view
@@ -0,0 +1,35 @@+[[!comment format=mdwn+ username="https://launchpad.net/~wincus"+ nickname="Juan Moyano"+ subject="git annex on Snow Leopard"+ date="2013-03-26T16:02:54Z"+ content="""+I'm having the same issue as @Pere, with a newer version of DAV :(++cabal: Error: some packages failed to install:+DAV-0.3.1 failed during the building phase. The exception was:+ExitFailure 11+git-annex-4.20130323 depends on shakespeare-css-1.0.3 which failed to install.+persistent-1.1.5.1 failed during the building phase. The exception was:+ExitFailure 11+persistent-template-1.1.3.1 depends on persistent-1.1.5.1 which failed to+install.+shakespeare-css-1.0.3 failed during the building phase. The exception was:+ExitFailure 11+yesod-1.1.9.2 depends on shakespeare-css-1.0.3 which failed to install.+yesod-auth-1.1.5.3 depends on shakespeare-css-1.0.3 which failed to install.+yesod-core-1.1.8.2 depends on shakespeare-css-1.0.3 which failed to install.+yesod-default-1.1.3.2 depends on shakespeare-css-1.0.3 which failed to+install.+yesod-form-1.2.1.3 depends on shakespeare-css-1.0.3 which failed to install.+yesod-json-1.1.2.2 depends on shakespeare-css-1.0.3 which failed to install.+yesod-persistent-1.1.0.1 depends on shakespeare-css-1.0.3 which failed to+install.+yesod-static-1.1.2.2 depends on shakespeare-css-1.0.3 which failed to install.++++*Any ideas?*+++"""]]
doc/internals.mdwn view
@@ -10,6 +10,7 @@  First there are two levels of directories used for hashing, to prevent too many things ending up in any one directory.+See [[hashing]] for details.  Each subdirectory has the [[name_of_a_key|key_format]] in one of the [[key-value_backends|backends]]. The file inside also has the name of the key.@@ -107,7 +108,9 @@  These log files record [[location_tracking]] information for file contents. Again these are placed in two levels of subdirectories-for hashing. The name of the key is the filename, and the content+for hashing. See [[hashing]] for details.++The name of the key is the filename, and the content consists of a timestamp, either 1 (present) or 0 (not present), and the UUID of the repository that has or lacks the file content.
+ doc/internals/hashing.mdwn view
@@ -0,0 +1,30 @@+In both the .git/annex directory and the git-annex branch, two levels of+hash directories are used, to avoid issues with too many files in one+directory.++Two separate hash methods are used. One, the old hash format, is only used+for non-bare git repositories. The other, the new hash format, is used for+bare git repositories, the git-annex branch, and on special remotes as+well.++## new hash format++This uses two directories, each with a three-letter name, such as "f87/4d5"++The directory names come from the md5sum of the [[key|key_format]].++For example:++	echo -n	"SHA256E-s0--e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" | md5sum++## old hash format++This uses two directories, each with a two-letter name, such as "pX/1J"++It takes the md5sum of the key, but rather than a string, represents it as 4+32bit words. Only the first word is used. It is converted into a string by the+same mechanism that would be used to encode a normal md5sum value into a+string, but where that would normally encode the bits using the 16 characters+0-9a-f, this instead uses the 32 characters "0123456789zqjxkmvwgpfZQJXKMVWGPF".+The first 2 letters of the resulting string are the first directory, and the+second 2 are the second directory.
− doc/news/version_3.20130207.mdwn 
@@ -1,18 +0,0 @@-git-annex 3.20130207 released with [[!toggle text="these changes"]]-[[!toggleable text="""-   * webapp: Now allows restarting any threads that crash.-   * Adjust debian package to only build-depend on DAV on architectures-     where it is available.-   * addurl --fast: Use curl, rather than haskell HTTP library, to support https.-   * annex.autocommit: New setting, can be used to disable autocommit-     of changed files by the assistant, while it still does data syncing-     and other tasks.-   * assistant: Ignore .DS\_Store on OSX.-   * assistant: Fix location log when adding new file in direct mode.-   * Deal with stale mappings for deleted file in direct mode.-   * pre-commit: Update direct mode mappings.-   * uninit, unannex --fast: If hard link creation fails, fall back to slow-     mode.-   * Clean up direct mode cache and mapping info when dropping keys.-   * dropunused: Clean up stale direct mode cache and mapping info not-     removed before."""]]
+ doc/news/version_4.20130405.mdwn view
@@ -0,0 +1,34 @@+git-annex 4.20130405 released with [[!toggle text="these changes"]]+[[!toggleable text="""+   * Group subcommands into sections in usage. Closes: #[703797](http://bugs.debian.org/703797)+   * Per-command usage messages.+   * webapp: Fix a race that sometimes caused alerts or other notifications+     to be missed if they occurred while a page was loading.+   * webapp: Progess bar fixes for many types of special remotes.+   * Build debian package without using cabal, which writes to HOME.+     Closes: #[704205](http://bugs.debian.org/704205)+   * webapp: Run ssh server probes in a way that will work when the+     login shell is a monstrosity that should have died 25 years ago,+     such as csh.+   * New annex.largefiles setting, which configures which files+     `git annex add` and the assistant add to the annex.+   * assistant: Check small files into git directly.+   * Remotes can be configured to use other MAC algorithms than HMACSHA1+     to encrypt filenames.+     Thanks, guilhem for the patch.+   * git-annex-shell: Passes rsync --bwlimit options on rsync.+     Thanks, guilhem for the patch.+   * webapp: Added UI to delete repositories. Closes: #[689847](http://bugs.debian.org/689847)+   * Adjust built-in preferred content expressions to make most types+     of repositories want content that is only located on untrusted, dead,+     and unwanted repositories.+   * drop --auto: Fix bug that prevented dropping files from untrusted+     repositories.+   * assistant: Fix bug that could cause direct mode files to be unstaged+     from git.+   * Update working tree files fully atomically.+   * webapp: Improved transfer queue management.+   * init: Probe whether the filesystem supports fifos, and if not,+     disable ssh connection caching.+   * Use lower case hash directories for storing files on crippled filesystems,+     same as is already done for bare repositories."""]]
doc/preferred_content.mdwn view
@@ -77,13 +77,18 @@ git-annex comes with some standard preferred content expressions, that can be used with repositories that are in some pre-defined groups. To make a repository use one of these, just set its preferred content expression-to "standard", and put it in one of these groups:+to "standard", and put it in one of these groups. +(Note that most of these standard expressions also make the repository+prefer any content that is only currently available on untrusted and+dead repositories. So if an untrusted repository gets connected,+any repository that can will back it up.)+ ### client  All content is preferred, unless it's in a "archive" directory. -`exclude=*/archive/* and exclude=archive/*`+`(exclude=*/archive/* and exclude=archive/*) or (not copies=semitrusted+:1)`  ### transfer @@ -95,7 +100,7 @@ The preferred content expression for these causes them to get and retain data until all clients have a copy. -`not (inallgroup=client and copies=client:2) and exclude=*/archive/* and exclude=archive/*`+`(not (inallgroup=client and copies=client:2) and exclude=*/archive/* and exclude=archive/*) or (not copies=semitrusted+:1)`  The "copies=client:2" part of the above handles the case where there is only one client repository. It makes a transfer repository@@ -114,20 +119,20 @@ Only prefers content that's not already backed up to another backup or incremental backup repository. -`include=* and (not copies=backup:1) and (not copies=incrementalbackup:1)`+`(include=* and (not copies=backup:1) and (not copies=incrementalbackup:1)) or (not copies=semitrusted+:1)`  ### small archive  Only prefers content that's located in an "archive" directory, and only if it's not already been archived somewhere else. -`(include=*/archive/* or include=archive/*) and not (copies=archive:1 or copies=smallarchive:1)`+`((include=*/archive/* or include=archive/*) and not (copies=archive:1 or copies=smallarchive:1)) or (not copies=semitrusted+:1)`  ### full archive  All content is preferred, unless it's already been archived somewhere else. -`not (copies=archive:1 or copies=smallarchive:1)`+`(not (copies=archive:1 or copies=smallarchive:1)) or (not copies=semitrusted+:1)`  Note that if you want to archive multiple copies (not a bad idea!), you should instead configure all your archive repositories with a@@ -155,4 +160,12 @@ Only content that is present is preferred. Content in "archive" directories is never preferred. -`present and exclude=*/archive/* and exclude=archive/*`+`(present and exclude=*/archive/* and exclude=archive/*) or (not copies=semitrusted+:1)`++### unwanted++Use for repositories that you don't want to exist. This will result+in any content on them being moved away to other repositories. (Works+best when the unwanted repository is also marked as untrusted or dead.)++`exclude=*`
doc/special_remotes.mdwn view
@@ -14,6 +14,7 @@ * [[rsync]] * [[webdav]] * [[web]]+* [[xmpp]] * [[hook]]  The above special remotes can be used to tie git-annex
+ doc/special_remotes/bup/comment_6_5942333cde09fd98e26c4f1d389cb76f._comment view
@@ -0,0 +1,10 @@+[[!comment format=mdwn+ username="https://www.google.com/accounts/o8/id?id=AItOawnZWCbRYPVnwscdkdEDwgQHZJLwW6H_AHo"+ nickname="Tobias"+ subject="bup fail?"+ date="2013-03-31T21:05:32Z"+ content="""+I've run into problems storing a huge number of files in the bup repo. It seems that thousands of branches are a problem. I don't know if it's a problem of git-annex, bup, or the filesystem.++How about adding an option to store tree/commit ids in git-annex instead of using branches in bup?+"""]]
+ doc/special_remotes/bup/comment_7_cb1a0d3076e9d06e7a24204478f6fa98._comment view
@@ -0,0 +1,10 @@+[[!comment format=mdwn+ username="http://joeyh.name/"+ nickname="joey"+ subject="comment 7"+ date="2013-04-02T21:24:06Z"+ content="""+`bup-split` uses a git branch to name the objects stored in the bup repository. So it will be limited by any scalability issues affecting large numbers of git branches. I don't know what those are.++Yes, it would be possible to make git-annex store this in the git-annex branch instead.+"""]]
+ doc/special_remotes/xmpp.mdwn view
@@ -0,0 +1,24 @@+XMPP (Jabber) is used by the [[assistant]] as a git remote. This is,+technically not a git-annex special remote (large files are not transferred+over XMPP; only git commits are sent).++Typically XMPP will be set up using the web app, but here's how a manual+set up could be accomplished:++1. xmpp login credentials need to be stored in `.git/annex/creds/xmpp`.+   Obviously this file should be mode 600. An example file:++	XMPPCreds {xmppUsername = "joeyhess", xmppPassword = "xxxx", xmppHostname = "xmpp.l.google.com.", xmppPort = 5222, xmppJID = "joeyhess@gmail.com"}++2. A git remote is created using a special url, of the form `xmpp::user@host`+   For the above example, it would be `url = xmpp::joeyhess@gmail.com`++3. The uuid of one of the other clients using XMPP should be configured+   using the `annex.uuid` setting, the same as is set up for other remotes.++With the above configuration, the [[assistant]] will use xmpp remotes much as+any other git remote. Since XMPP requires a client that is continually running+to see incoming pushes, the XMPP remote cannot be used with git at the+command line.++See also: [[xmpp_protocol_design_notes|design/assistant/xmpp]]
+ doc/tips/replacing_Sparkleshare_or_dvcs-autosync_with_the_assistant.mdwn view
@@ -0,0 +1,41 @@+Sparkleshare and dvcs-autosync are tools to automatically commit your+changes to git and keep them in sync with other repositories. Unlike+git-annex, they don't store the file content on the side, but directly in+the git repository. Great for small files, less good for big files.++Here's how to use the [[git-annex assistant|/assistant]] to do the same+thing, but even better!++----++First, get git-annex version 4.20130329 or newer.++----++Let's suppose you're delveloping a video game, written in C. You have+source code, and some large game assets. You want to ensure the source+code is stored in git -- that's what git's for! And you want to store+the game assets in the git annex -- to avod bloating your git repos with+possibly enormous files, but still version control them.++All you need to do is configure git-annex to treat your C files+as small files. And treat any file larger than, say, 100kb as a large+file that is stored in the annex.++	git config annex.largefiles "largerthan=100kb and not (include=*.c or include=*.h)"++Now if you run `git annex add`, it will only add the large files to the+annex. You can `git add` the small files directly to git.++Better, if you run `git annex assistant`, it will *automatically*+add the large files to the annex, and store the small files in git.+It'll notice every time you modify a file, and immediately commit it,+too. And sync it out to other repositories you configure using `git annex+webapp`.++----++It's also possible to disable the use of the annex entirely, and just+have the assistant *always* put every file into git, no matter its size:++	git config annex.largefiles "exclude=*"
+ doc/todo/stream_feature__63__.mdwn view
@@ -0,0 +1,23 @@+I am just asking myself, is it stupid to think that streaming in git annex would be a good idea and wouldnt it be totaly easy to implement?++Ok just tried to link to files over ssh, it creates a link but you cant open with it its content ^^++But at least the files you have access over some filesystem as example samba/sshfs or just a other directory or usb-drive you could stream instead of "get"++you could add another mode like direct and indirect, like symbolic-links or something like that?++Sadly linux is to stupid to allow direct ssh links ( thats maybe one of the biggest features hurd has over linux  ) but you could mount with sshfs readonly (checking first if sshfs is installed) to mount the files there and then map the links there.++ok I am not so shure how hard it would be and how much bug potentials it creates, but it would be great I guess.++git annex is a bit like a telephone book, where you get a list of where the targets are. So using it to call the persons so that they drive to you to talk with you is nice. But I think the better feature would be if you just talk with the guy over the telephone directly bevore he comes to you (streaming)++I mean you did one great thing, you did make cloudy thing peer to peer, like git is targeted too but for smaller files, yes there are may use cases without this feature, but I would be really glad if it could do that too, if I give annex 5 locations on other pcs usb-sticks etc, I find it stupid to additionaly do setup all this sources again a second time for streaming, and then I have maybe even 2 different file names because you map stuff in git.++So sorry its late here, I am a bit tired so I maybe dont know what I am talking right now, my english isnt the best, too, but I think it would be a great feature.++I mean on your setup, with slow internet, you maybe always make a get command, but here, if I link to youtube, I have no problem to stream it, or even on internal network between my pcs I have gb-lan, I start directly movies streaming, I would only use get, in rare cases where I need them on a train, the normal thing is to stream stuff.++So I have to go sleep now ++bye
doc/videos/git-annex_assistant_archiving.mdwn view
@@ -1,5 +1,5 @@ <video controls width=400>-<source type="video/mp4" src="http://downloads.kitenet.net/videos/git-annex/git-annex-assistant-archiving.ogv">+<source src="http://downloads.kitenet.net/videos/git-annex/git-annex-assistant-archiving.ogv"> </video><br> A <a href="http://downloads.kitenet.net/videos/git-annex/git-annex-assistant-archiving.ogv">9 minute screencast</a> covering archiving your files with the [[git-annex assistant|/assistant]]</a>.
doc/videos/git-annex_assistant_introduction.mdwn view
@@ -1,5 +1,5 @@ <video controls width=400>-<source type="video/mp4" src="http://downloads.kitenet.net/videos/git-annex/git-annex-assistant-intro.ogv">+<source src="http://downloads.kitenet.net/videos/git-annex/git-annex-assistant-intro.ogv"> </video><br> A <a href="http://downloads.kitenet.net/videos/git-annex/git-annex-assistant-intro.ogv">8 minute screencast</a> introducing the [[git-annex assistant|/assistant]]</a>.
+ doc/videos/git-annex_assistant_remote_sharing.mdwn view
@@ -0,0 +1,6 @@+<video controls width=400>+<source src="http://downloads.kitenet.net/videos/git-annex/git-annex-xmpp-pairing.ogv">+</video><br>+A <a href="http://downloads.kitenet.net/videos/git-annex/git-annex-xmpp-pairing.ogv">6 minute screencast</a>+showing how to share files between your computers in different locations,+such as home and work.
git-annex.1 view
@@ -612,6 +612,9 @@ copies, on remotes with the specified trust level. For example, "\-\-copies=trusted:2" .IP+To match any trust level at or higher than a given level, use+'trustlevel+'. For example, "\-\-copies=semitrusted+:2"+.IP .IP "\-\-copies=groupname:number" Matches only files that git\-annex believes have the specified number of copies, on remotes in the specified group. For example,@@ -650,6 +653,22 @@ .IP "\-)" Closes a group of file matching options. .IP+.SH PREFERRED CONTENT+Each repository has a preferred content setting, which specifies content+that the repository wants to have present. These settings can be configured+using git annex vicfg. They are used by the \-\-auto option, and+by the git\-annex assistant.+.PP+The preferred content settings are similar, but not identical to+the file matching options specified above, just without the dashes.+For example:+.PP+ exclude=archive/* and (include=*.mp3 or smallerthan=1mb)+.PP+The main differences are that exclude= and include= always+match relative to the top of the git repository, and that there is+no equivilant to \-\-in.+.PP .SH CONFIGURATION Like other git commands, git\-annex is configured via .git/config. Here are all the supported configuration settings.@@ -675,6 +694,18 @@ .IP The default reserve is 1 megabyte. .IP+.IP "annex.largefiles"+Allows configuring which files git annex add and the assistant consider+to be large enough to need to be added to the annex. By default,+all files are added to the annex.+.IP+The value is a preferred content expression. See PREFERRED CONTENT+for details.+.IP+Example:+.IP+ annex.largefiles = largerthan=100kb and not (include=*.c or include=*.h)+.IP .IP "annex.queuesize" git\-annex builds a queue of git commands, in order to combine similar commands for speed. By default the size of the queue is limited to@@ -697,9 +728,6 @@ the accuracy will make git annex unused consume more memory; run git annex status for memory usage numbers. .IP-.IP "annex.version"-Automatically maintained, and used to automate upgrades between versions.-.IP .IP "annex.sshcaching" By default, git\-annex caches ssh connections (if built using a new enough ssh). To disable this, set to false.@@ -721,10 +749,13 @@ Set to false to prevent the git\-annex assistant from automatically committing changes to files in the repository. .IP+.IP "annex.version"+Automatically maintained, and used to automate upgrades between versions.+.IP .IP "annex.direct"-Set to true to enable an (experimental) mode where files in the repository-are accessed directly, rather than through symlinks. Note that many git-and git\-annex commands will not work with such a repository.+Set to true when the repository is in direct mode. Should not be set+manually; use the "git annex direct" and "git annex indirect" commands+instead. .IP .IP "annex.crippledfilesystem" Set to true if the repository is on a crippled filesystem, such as FAT,@@ -864,7 +895,8 @@  *.ogg annex.backend=SHA256E .PP The numcopies setting can also be configured on a per\-file\-type basis via-the annex.numcopies attribute in .gitattributes files.+the annex.numcopies attribute in .gitattributes files. This overrides+any value set using annex.numcopies in .git/config. For example, this makes two copies be needed for wav files: .PP  *.wav annex.numcopies=2
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 4.20130323+Version: 4.20130405 Cabal-Version: >= 1.8 License: GPL Maintainer: Joey Hess <joey@kitenet.net>
+ templates/configurators/delete/currentrepository.hamlet view
@@ -0,0 +1,34 @@+<div .span9 .hero-unit>+  <h2>+    Deleting #{reldir}+  <p>+    Deleting this repository will remove <tt>#{reldir}</tt> and all its #+    ^{actionButton FileBrowserR (Just "files") (Just "Click to open a file browser") "" "icon-folder-open"}.+  $if havegitremotes+    $if havedataremotes+      <div .alert>+        Since this repository is currently configured to sync to other #+        repositories, you may be able to remove this repository without #+        losing any data, if all files have been synced to them. #+        No guarantees -- It's up to you to make sure before you continue.+    $else+      <div .alert .alert-error>+        This repository is not uploading its files to other repositories,+        so you will lose data if you delete it!+  $else+    <div .alert .alert-error>+      This repository is not syncing to other git repositories, #+      so you will lose data if you delete it!+  <p>+    If you choose to delete this repository, and potentially lose #+    data, enter "#{magicphrase}" into the box.+  <p>+    <form method="post" .form-horizontal enctype=#{enctype}>+      <fieldset>+        ^{form}+        ^{webAppFormAuthToken}+        <div .form-actions>+          <button .btn .btn-danger type=submit>+            <i .icon-warning-sign></i> Delete this repository #+          <a .btn href="@{DashboardR}">+            Cancel
+ templates/configurators/delete/finished.hamlet view
@@ -0,0 +1,14 @@+<div .span9 .hero-unit>+  <h2>+    Repository deleted+  <p>+    As much data as possible has been removed from the repository+    "#{reponame}", and it has been removed from the list of repositories.+  <p>+    $if gitrepo+     <div .alert>+       Since "#{reponame}" is a git repository, it still contains+       some data. To completely remove it, you should go delete that git+       repository.+    $else+      Now you can safely go delete the underlying storage of the repository.
+ templates/configurators/delete/start.hamlet view
@@ -0,0 +1,11 @@+<div .span9 .hero-unit>+  <h2>+    Delete repository #+    <small>+      #{reponame}+  <p>+    Before this repository can be deleted, all data must be moved #+    off it, to other repositories.+  <p>+   <a .btn .btn-primary href="@{StartDeleteRepositoryR uuid}">+     <i .icon-minus></i> Start deletion process
templates/configurators/editrepository.hamlet view
@@ -1,6 +1,9 @@ <div .span9 .hero-unit>   <h2>-    Configuring repository+    $if new+      Repository created+    $else+      Editing repository   $if new     <p>       This repository is set up and ready to go!@@ -19,9 +22,9 @@         ^{webAppFormAuthToken}         <div .form-actions>           <button .btn .btn-primary type=submit>-            Save Changes+            Save Changes #           <a .btn href="@{DashboardR}">-            Cancel+            Cancel #   $if new     <p>       In a hurry? Feel free to skip this step! You can always come back #
templates/controlmenu.hamlet view
@@ -2,11 +2,15 @@   <li>     <a href="@{NewRepositoryR}">       <i .icon-plus-sign></i> Add another local repository+  <li>     <a href="@{RepositorySwitcherR}">       <i .icon-folder-close></i> Switch repository+  <li>     <a href="@{RestartR}">       <i .icon-repeat></i> Restart daemon+  <li>     <a href="@{ShutdownR}">       <i .icon-off></i> Shutdown daemon+  <li>     <a href="@{LogR}">       <i .icon-list></i> View log
templates/documentation/repogroup.hamlet view
@@ -47,7 +47,7 @@     files until they can be moved to some other repository, like a client #     or transfer repository.   <p>-    Finally, repositories can be configured to be <b>manual</b>. This #+    Finally, repositories can be configured to be in <b>manual mode</b>. This #     prevents content being automatically synced to the repository, but #     you can use command-line tools like `git annex get` and `git annex drop` #     to control what content is present.
templates/repolist.hamlet view
@@ -22,18 +22,31 @@               <a href="@{setupRepoLink actions}">                 <i .icon-warning-sign></i> not enabled             $else-              <a href="@{syncToggleLink actions}">-                $if notSyncing actions-                  <i .icon-ban-circle></i> syncing disabled-                $else-                  <i .icon-refresh></i> syncing enabled+              $if notWanted actions+                <i .icon-trash></i> cleaning out..+              $else+                <a href="@{syncToggleLink actions}">+                  $if notSyncing actions+                    <i .icon-ban-circle></i> syncing disabled+                  $else+                    <i .icon-refresh></i> syncing enabled           <td .draghide>             $if needsEnabled actions               <a href="@{setupRepoLink actions}">                 enable             $else-              <a href="@{setupRepoLink actions}">-                configure+              <span .dropdown #menu-#{fromUUID uuid}>+                <a .dropdown-toggle data-toggle="dropdown" href="#menu-#{fromUUID uuid}">+                  <i .icon-cog></i> settings+                  <b .caret></b>+                <ul .dropdown-menu>+                  <li>+                    <a href="@{setupRepoLink actions}">+                      <i .icon-pencil></i> Edit+                    <a href="@{DisableRepositoryR uuid}">+                      <i .icon-minus></i> Disable+                    <a href="@{DeleteRepositoryR uuid}">+                      <i .icon-trash></i> Delete       $if addmore         <tr>           <td colspan="3">@@ -44,5 +57,5 @@               <a .btn .btn-small href="@{AddRepositoryR}">                 <i .icon-plus-sign></i> Add another repository             <span>-              &nbsp; Sync your files with another drive, device, or #+              &nbsp; Sync your files with another device, or #               share with a friend.