diff options
| author | JoeyHess <> | 2013-04-05 16:26:05 (GMT) |
|---|---|---|
| committer | hdiff <hdiff@hdiff.luite.com> | 2013-04-05 16:26:05 (GMT) |
| commit | 0ef77235d5c3743f0189030a5200a81a557f8e31 (patch) | |
| tree | 628967eaf483cd43f5e284f2e38df1bee6b27d48 | |
| parent | f299fa19ebd7a929ca6f3ac402c21815effd89f9 (diff) | |
version 4.201304054.20130405
231 files changed, 2765 insertions, 1043 deletions
@@ -28,6 +28,7 @@ module Annex ( gitRepo, inRepo, fromRepo, + calcRepo, getGitConfig, changeGitConfig, changeGitRepo, @@ -203,6 +204,11 @@ inRepo a = liftIO . a =<< gitRepo 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 getGitConfig = getState gitconfig diff --git a/Annex/Branch.hs b/Annex/Branch.hs index 4a36de6..021cd39 100644 --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -189,7 +189,7 @@ change file a = lockJournal $ a <$> getStale file >>= set file {- 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 @@ commit message = whenM journalDirty $ lockJournal $ do 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 @@ stageJournal = withIndex $ do 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 diff --git a/Annex/Content.hs b/Annex/Content.hs index 91ffe7a..44e5bb1 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -9,7 +9,6 @@ module Annex.Content ( inAnnex, inAnnexSafe, lockContent, - calcGitLink, getViaTmp, getViaTmpChecked, getViaTmpUnchecked, @@ -49,8 +48,8 @@ import Config 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 @@ inAnnexSafe = inAnnex' (fromMaybe False) (Just False) go - 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 @@ lockContent key a = do 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 @@ moveAnnex key src = withObjectLoc key storeobject storedirect 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 @@ prepSendAnnex key = withObjectLoc key indirect direct 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 @@ withObjectLoc key indirect direct = ifM isDirect , 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 @@ removeAnnex key = withObjectLoc key remove removedirect 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 @@ fromAnnex key dest = do - 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 @@ preseedTmp key file = go =<< inAnnex key copy = ifM (liftIO $ doesFileExist file) ( return True , do - s <- inRepo $ gitAnnexLocation key + s <- calcRepo $ gitAnnexLocation key liftIO $ copyFileExternal s file ) diff --git a/Annex/Content/Direct.hs b/Annex/Content/Direct.hs index bbf6e31..1f9ddb7 100644 --- a/Annex/Content/Direct.hs +++ b/Annex/Content/Direct.hs @@ -42,7 +42,7 @@ associatedFiles key = do - 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 @@ associatedFilesRelative key = do - 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 @@ removeInodeCache key = withInodeCacheFile key $ \f -> do 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 -> FileStatus -> Annex Bool 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 diff --git a/Annex/Direct.hs b/Annex/Direct.hs index 1bebb2c..e3779ad 100644 --- a/Annex/Direct.hs +++ b/Annex/Direct.hs @@ -89,7 +89,8 @@ addDirect file cache = do 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 :: FilePath -> Git.Ref -> Git.Ref -> Annex () 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 @@ mergeDirectCleanup d oldsha newsha = do - - 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 @@ toDirect k f = fromMaybe noop =<< toDirectGen k f 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 @@ toDirectGen k f = do {- 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 ) diff --git a/Annex/FileMatcher.hs b/Annex/FileMatcher.hs new file mode 100644 index 0000000..220fea2 --- /dev/null +++ b/Annex/FileMatcher.hs @@ -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 diff --git a/Annex/Link.hs b/Annex/Link.hs index 650fc19..931836d 100644 --- a/Annex/Link.hs +++ b/Annex/Link.hs @@ -60,7 +60,9 @@ getAnnexLinkTarget file = do -} 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 ) diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs index a8bd1f7..0b8ce3b 100644 --- a/Annex/Ssh.hs +++ b/Annex/Ssh.hs @@ -79,7 +79,7 @@ sshCacheDir 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 = [] diff --git a/Assistant.hs b/Assistant.hs index 630f368..0d9dafd 100644 --- a/Assistant.hs +++ b/Assistant.hs @@ -152,6 +152,7 @@ import Assistant.Threads.XMPPClient #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.LogFile 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 @@ stopDaemon = liftIO . Utility.Daemon.stopDaemon =<< fromRepo gitAnnexPidFile 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 @@ startDaemon assistant foreground startbrowser = do | 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 @@ startDaemon assistant foreground startbrowser = do #endif , assist $ netWatcherThread , assist $ netWatcherFallbackThread - , assist $ transferScannerThread + , assist $ transferScannerThread urlrenderer , assist $ configMonitorThread , assist $ glacierThread , watch $ watchThread diff --git a/Assistant/Alert.hs b/Assistant/Alert.hs index 2066940..d4770f6 100644 --- a/Assistant/Alert.hs +++ b/Assistant/Alert.hs @@ -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 +import qualified Data.Text as T -{- 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 - -{- 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 +#ifdef WITH_WEBAPP +import Assistant.Monad +import Assistant.DaemonStatus +import Assistant.WebApp.Types +import Assistant.WebApp +import Yesod +#endif + +{- 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 @@ -351,6 +199,23 @@ cloudRepoNeededAlert friendname button = Alert , 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 = [] + } + fileAlert :: TenseChunk -> FilePath -> Alert fileAlert msg file = (activityAlert Nothing [f]) { alertName = Just $ FileAlert msg diff --git a/Assistant/Alert/Utility.hs b/Assistant/Alert/Utility.hs new file mode 100644 index 0000000..4757c44 --- /dev/null +++ b/Assistant/Alert/Utility.hs @@ -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 diff --git a/Assistant/Common.hs b/Assistant/Common.hs index 0be5362..f971942 100644 --- a/Assistant/Common.hs +++ b/Assistant/Common.hs @@ -11,3 +11,4 @@ import Common.Annex as X import Assistant.Monad as X import Assistant.Types.DaemonStatus as X import Assistant.Types.NamedThread as X +import Assistant.Types.Alert as X diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs index 774580f..c966fc9 100644 --- a/Assistant/DaemonStatus.hs +++ b/Assistant/DaemonStatus.hs @@ -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 @@ calcSyncRemotes = do 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 @@ -151,6 +151,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 () alterTransferInfo t a = updateTransferInfo' $ M.adjust a t diff --git a/Assistant/DeleteRemote.hs b/Assistant/DeleteRemote.hs new file mode 100644 index 0000000..2504910 --- /dev/null +++ b/Assistant/DeleteRemote.hs @@ -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 diff --git a/Assistant/Drop.hs b/Assistant/Drop.hs index 4c060ba..1d22da4 100644 --- a/Assistant/Drop.hs +++ b/Assistant/Drop.hs @@ -41,25 +41,39 @@ handleDropsFrom _ _ _ _ _ Nothing _ = noop 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 @@ handleDropsFrom locs rs reason fromhere key (Just f) knownpresentremote , "(copies now " ++ show (have - 1) ++ ")" , ": " ++ reason ] - return $ decrcopies n + return $ decrcopies n u , return n ) , return n diff --git a/Assistant/NamedThread.hs b/Assistant/NamedThread.hs index 33af2c3..edebe83 100644 --- a/Assistant/NamedThread.hs +++ b/Assistant/NamedThread.hs @@ -13,6 +13,7 @@ import Common.Annex 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 Data.Map as M 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 @@ import qualified Data.Text as T - - 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 @@ startNamedThread urlrenderer namedthread@(NamedThread name a) = do ] 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) diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs index 54dcb42..50e8e73 100644 --- a/Assistant/Sync.hs +++ b/Assistant/Sync.hs @@ -12,6 +12,7 @@ import Assistant.Pushes 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 @@ pushToRemotes' now notifypushes remotes = do - 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 diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs index 46d77db..bee359d 100644 --- a/Assistant/Threads/Committer.hs +++ b/Assistant/Threads/Committer.hs @@ -312,7 +312,7 @@ handleAdds delayadd cs = returnWhen (null incomplete) $ do 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 diff --git a/Assistant/Threads/DaemonStatus.hs b/Assistant/Threads/DaemonStatus.hs index fffc6ed..5bbb15a 100644 --- a/Assistant/Threads/DaemonStatus.hs +++ b/Assistant/Threads/DaemonStatus.hs @@ -17,7 +17,7 @@ import Utility.NotificationBroadcaster -} daemonStatusThread :: NamedThread daemonStatusThread = namedThread "DaemonStatus" $ do - notifier <- liftIO . newNotificationHandle + notifier <- liftIO . newNotificationHandle False =<< changeNotifier <$> getDaemonStatus checkpoint runEvery (Seconds tenMinutes) <~> do diff --git a/Assistant/Threads/PairListener.hs b/Assistant/Threads/PairListener.hs index 4459ee1..cb9a94e 100644 --- a/Assistant/Threads/PairListener.hs +++ b/Assistant/Threads/PairListener.hs @@ -11,7 +11,7 @@ import Assistant.Common 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 @@ pairListenerThread urlrenderer = namedThread "PairListener" $ do 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 diff --git a/Assistant/Threads/TransferPoller.hs b/Assistant/Threads/TransferPoller.hs index 20b8326..68075ca 100644 --- a/Assistant/Threads/TransferPoller.hs +++ b/Assistant/Threads/TransferPoller.hs @@ -21,7 +21,7 @@ import qualified Data.Map as M 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 diff --git a/Assistant/Threads/TransferScanner.hs b/Assistant/Threads/TransferScanner.hs index 4698a0d..4669546 100644 --- a/Assistant/Threads/TransferScanner.hs +++ b/Assistant/Threads/TransferScanner.hs @@ -14,8 +14,11 @@ import Assistant.TransferQueue 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 @@ import qualified Data.Set as S {- 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 @@ transferScannerThread = namedThread "TransferScanner" $ do 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 @@ transferScannerThread = namedThread "TransferScanner" $ do - * 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 @@ failedTransferScan r = do - - 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 @@ expensiveScan rs = unless onlyweb $ do 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 diff --git a/Assistant/Threads/TransferWatcher.hs b/Assistant/Threads/TransferWatcher.hs index 69fa870..7045e84 100644 --- a/Assistant/Threads/TransferWatcher.hs +++ b/Assistant/Threads/TransferWatcher.hs @@ -62,10 +62,8 @@ onAdd file = case parseTransferFile file of 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. - diff --git a/Assistant/Threads/Transferrer.hs b/Assistant/Threads/Transferrer.hs index 3dcbb40..acbac64 100644 --- a/Assistant/Threads/Transferrer.hs +++ b/Assistant/Threads/Transferrer.hs @@ -12,6 +12,7 @@ import Assistant.DaemonStatus 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 @@ genTransfer t info = case (transferRemote info, associatedFile info) of - 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 @@ genTransfer t info = case (transferRemote info, associatedFile info) of (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 diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs index 8d06e66..9bd78b6 100644 --- a/Assistant/Threads/Watcher.hs +++ b/Assistant/Threads/Watcher.hs @@ -35,6 +35,7 @@ import Annex.Direct 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 @@ watchThread = namedThread "Watcher" $ 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 @@ type Handler = FilePath -> Maybe FileStatus -> Assistant (Maybe Change) -} 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 @@ runHandler handler file filestatus = void $ do -- flushing the queue fast enough. liftAnnex $ Annex.Queue.flushWhenFull recordChange change + where + normalize f + | "./" `isPrefixOf` file = drop 2 f + | otherwise = f + +{- 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 :: Handler -onAdd file filestatus - | maybe False isRegularFile filestatus = pendingAddChange file +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 @@ onAddSymlink isdirect file filestatus = go =<< liftAnnex (Backend.lookupFile fil 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 @@ onAddSymlink isdirect file filestatus = go =<< liftAnnex (Backend.lookupFile fil - 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 diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs index 55f3d35..b7bfd0c 100644 --- a/Assistant/Threads/WebApp.hs +++ b/Assistant/Threads/WebApp.hs @@ -18,7 +18,6 @@ import Assistant.WebApp.SideBar 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.AWS 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 diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs index 1242c1d..6f15505 100644 --- a/Assistant/Threads/XMPPClient.hs +++ b/Assistant/Threads/XMPPClient.hs @@ -18,8 +18,9 @@ import Assistant.Sync 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 @@ xmppClient urlrenderer d creds = 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 @@ pairMsgReceived urlrenderer PairReq theiruuid selfjid theirjid 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; diff --git a/Assistant/TransferQueue.hs b/Assistant/TransferQueue.hs index 5974c70..ac9ed32 100644 --- a/Assistant/TransferQueue.hs +++ b/Assistant/TransferQueue.hs @@ -32,6 +32,7 @@ import Annex.Wanted import Control.Concurrent.STM import qualified Data.Map as M +import qualified Data.Set as S type Reason = String @@ -58,6 +59,7 @@ queueTransfersMatching matching reason schedule k f direction | otherwise = go where go = do + rs <- liftAnnex . selectremotes =<< syncDataRemotes <$> getDaemonStatus let matchingrs = filter (matching . Remote.uuid) rs @@ -67,15 +69,21 @@ queueTransfersMatching matching reason schedule k f direction 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 @@ enqueue reason schedule t info 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 () diff --git a/Assistant/Types/Alert.hs b/Assistant/Types/Alert.hs new file mode 100644 index 0000000..34bbc1b --- /dev/null +++ b/Assistant/Types/Alert.hs @@ -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 ()) + } diff --git a/Assistant/Types/Changes.hs b/Assistant/Types/Changes.hs index 6510859..9729acf 100644 --- a/Assistant/Types/Changes.hs +++ b/Assistant/Types/Changes.hs @@ -14,11 +14,11 @@ import Utility.TSet 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 :: Change -> Key -> Change finishedChange c@(InProcessAddChange { keySource = ks }) k = Change { changeTime = changeTime c , _changeFile = keyFilename ks - , changeInfo = AddChange k + , changeInfo = AddKeyChange k } finishedChange c _ = c diff --git a/Assistant/Types/DaemonStatus.hs b/Assistant/Types/DaemonStatus.hs index 99baf15..17e535b 100644 --- a/Assistant/Types/DaemonStatus.hs +++ b/Assistant/Types/DaemonStatus.hs @@ -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 diff --git a/Assistant/Types/NamedThread.hs b/Assistant/Types/NamedThread.hs index 0e88463..a65edc2 100644 --- a/Assistant/Types/NamedThread.hs +++ b/Assistant/Types/NamedThread.hs @@ -14,4 +14,4 @@ import Assistant.Types.ThreadName data NamedThread = NamedThread ThreadName (Assistant ()) namedThread :: String -> Assistant () -> NamedThread -namedThread name a = NamedThread (ThreadName name) a +namedThread = NamedThread . ThreadName diff --git a/Assistant/Types/NetMessager.hs b/Assistant/Types/NetMessager.hs index 05e5104..1ea7db7 100644 --- a/Assistant/Types/NetMessager.hs +++ b/Assistant/Types/NetMessager.hs @@ -104,7 +104,7 @@ getSide side m = m side 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 diff --git a/Assistant/Types/UrlRenderer.hs b/Assistant/Types/UrlRenderer.hs new file mode 100644 index 0000000..521905b --- /dev/null +++ b/Assistant/Types/UrlRenderer.hs @@ -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 diff --git a/Assistant/WebApp.hs b/Assistant/WebApp.hs index 17aa0ac..0812acb 100644 --- a/Assistant/WebApp.hs +++ b/Assistant/WebApp.hs @@ -30,7 +30,7 @@ waitNotifier getbroadcaster nid = liftAssistant $ do 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. -} diff --git a/Assistant/WebApp/Configurators/AWS.hs b/Assistant/WebApp/Configurators/AWS.hs index 3b6fad3..9fb8254 100644 --- a/Assistant/WebApp/Configurators/AWS.hs +++ b/Assistant/WebApp/Configurators/AWS.hs @@ -180,7 +180,7 @@ enableAWSRemote remotetype uuid = do 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 () diff --git a/Assistant/WebApp/Configurators/Delete.hs b/Assistant/WebApp/Configurators/Delete.hs new file mode 100644 index 0000000..90cbc45 --- /dev/null +++ b/Assistant/WebApp/Configurators/Delete.hs @@ -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!" diff --git a/Assistant/WebApp/Configurators/Local.hs b/Assistant/WebApp/Configurators/Local.hs index 1021c85..d94f592 100644 --- a/Assistant/WebApp/Configurators/Local.hs +++ b/Assistant/WebApp/Configurators/Local.hs @@ -27,7 +27,7 @@ import Utility.Mounts 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 @@ combineRepos dir name = liftAnnex $ do 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. -} diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs index 201be88..5ebbb53 100644 --- a/Assistant/WebApp/Configurators/Ssh.hs +++ b/Assistant/WebApp/Configurators/Ssh.hs @@ -148,8 +148,7 @@ postEnableRsyncR u = do _ -> 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 @@ testServer sshinput@(SshInput { inputHostname = Just hn }) = do , 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 @@ testServer sshinput@(SshInput { inputHostname = Just hn }) = do "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 @@ makeSsh' rsync setup sshdata keypair = 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" diff --git a/Assistant/WebApp/Configurators/WebDAV.hs b/Assistant/WebApp/Configurators/WebDAV.hs index b6b1dd2..6108f8b 100644 --- a/Assistant/WebApp/Configurators/WebDAV.hs +++ b/Assistant/WebApp/Configurators/WebDAV.hs @@ -46,7 +46,7 @@ boxComAForm :: AForm WebApp WebApp WebDAVInput 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 @@ postEnableWebDAVR uuid = do 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" diff --git a/Assistant/WebApp/Configurators/XMPP.hs b/Assistant/WebApp/Configurators/XMPP.hs index 62b21f3..32d9b16 100644 --- a/Assistant/WebApp/Configurators/XMPP.hs +++ b/Assistant/WebApp/Configurators/XMPP.hs @@ -50,21 +50,18 @@ xmppNeeded = whenM (isNothing <$> liftAnnex getXMPPCreds) $ do 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 @@ getNeedCloudRepoR for = page "Cloud repository needed" (Just Configuration) $ do buddyname <- liftAssistant $ getBuddyName for $(widgetFile "configurators/xmpp/needcloudrepo") #else -needCloudRepoR = xmppPage $ +getNeedCloudRepoR = xmppPage $ $(widgetFile "configurators/xmpp/disabled") #endif diff --git a/Assistant/WebApp/DashBoard.hs b/Assistant/WebApp/DashBoard.hs index 00738a7..bb97074 100644 --- a/Assistant/WebApp/DashBoard.hs +++ b/Assistant/WebApp/DashBoard.hs @@ -27,9 +27,7 @@ import Text.Hamlet 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 diff --git a/Assistant/WebApp/RepoList.hs b/Assistant/WebApp/RepoList.hs index 23b74a2..a14cd5f 100644 --- a/Assistant/WebApp/RepoList.hs +++ b/Assistant/WebApp/RepoList.hs @@ -20,6 +20,7 @@ import Remote.List (remoteListRefresh) 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 @@ data Actions { setupRepoLink :: Route WebApp , syncToggleLink :: Route WebApp } + | UnwantedRepoActions + { setupRepoLink :: Route WebApp } mkSyncingRepoActions :: UUID -> Actions mkSyncingRepoActions u = SyncingRepoActions @@ -54,6 +57,11 @@ mkNotSyncingRepoActions u = NotSyncingRepoActions , 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 :: Actions -> Bool 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 @@ repoList reposelector | 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 @@ repoList reposelector 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 diff --git a/Assistant/WebApp/SideBar.hs b/Assistant/WebApp/SideBar.hs index a87065f..6c8137b 100644 --- a/Assistant/WebApp/SideBar.hs +++ b/Assistant/WebApp/SideBar.hs @@ -13,7 +13,7 @@ import Assistant.Common 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 diff --git a/Assistant/WebApp/Types.hs b/Assistant/WebApp/Types.hs index 693cf0e..4582929 100644 --- a/Assistant/WebApp/Types.hs +++ b/Assistant/WebApp/Types.hs @@ -14,7 +14,6 @@ module Assistant.WebApp.Types where import Assistant.Common import Assistant.Ssh -import Assistant.Alert import Assistant.Pairing import Assistant.Types.Buddies import Utility.NotificationBroadcaster diff --git a/Assistant/WebApp/routes b/Assistant/WebApp/routes index 24af53b..e213b5f 100644 --- a/Assistant/WebApp/routes +++ b/Assistant/WebApp/routes @@ -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 diff --git a/Assistant/XMPP/Git.hs b/Assistant/XMPP/Git.hs index 135c68f..f90af40 100644 --- a/Assistant/XMPP/Git.hs +++ b/Assistant/XMPP/Git.hs @@ -31,10 +31,6 @@ import qualified Remote as Remote 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 @@ xmppRemotes cid = case baseJID <$> parseJID cid of 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,29 +272,19 @@ handlePushInitiation urlrenderer (Pushing cid PushRequest) = 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 B.hPut h b @@ -11,7 +11,6 @@ module Backend ( genKey, lookupFile, isAnnexLink, - makeAnnexLink, chooseBackend, lookupBackendName, maybeLookupBackendName @@ -95,8 +94,7 @@ lookupFile file = do 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 ++ @@ -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 @@ -40,15 +40,15 @@ dispatch fuzzyok allargs allcmds commonoptions fields header getgitrepo = do 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 @@ findCmd fuzzyok argv cmds err {- 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). @@ -20,7 +20,6 @@ module Command ( isBareRepo, numCopies, numCopiesCheck, - autoCopiesWith, checkAuto, module ReExported ) where @@ -40,7 +39,7 @@ import Config 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 @@ -109,26 +108,6 @@ numCopiesCheck file key vs = do 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) ( checker , return True ) diff --git a/Command/Add.hs b/Command/Add.hs index 343ffbe..30e989e 100644 --- a/Command/Add.hs +++ b/Command/Add.hs @@ -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.Touch 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 @@ undo file key e = do -- 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 @@ cleanup file key hascontent = do 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 diff --git a/Command/AddUnused.hs b/Command/AddUnused.hs index 23dbdfc..c352d87 100644 --- a/Command/AddUnused.hs +++ b/Command/AddUnused.hs @@ -15,7 +15,7 @@ import Types.Key def :: [Command] def = [notDirect $ command "addunused" (paramRepeating paramNumRange) - seek "add back unused files"] + seek SectionMaintenance "add back unused files"] seek :: [CommandSeek] seek = [withUnusedMaps start] diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs index ceb3522..7c23592 100644 --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -26,7 +26,8 @@ import Annex.Content.Direct 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" diff --git a/Command/Assistant.hs b/Command/Assistant.hs index 69a127b..0997088 100644 --- a/Command/Assistant.hs +++ b/Command/Assistant.hs @@ -20,7 +20,8 @@ import System.Posix.Directory 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" diff --git a/Command/Commit.hs b/Command/Commit.hs index 1659061..6f3f9df 100644 --- a/Command/Commit.hs +++ b/Command/Commit.hs @@ -14,7 +14,7 @@ import qualified Git 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] diff --git a/Command/ConfigList.hs b/Command/ConfigList.hs index 505ad99..703d688 100644 --- a/Command/ConfigList.hs +++ b/Command/ConfigList.hs @@ -13,7 +13,7 @@ import Annex.UUID def :: [Command] def = [noCommit $ command "configlist" paramNothing seek - "outputs relevant git configuration"] + SectionPlumbing "outputs relevant git configuration"] seek :: [CommandSeek] seek = [withNothing start] diff --git a/Command/Copy.hs b/Command/Copy.hs index 4b04a24..75b91c8 100644 --- a/Command/Copy.hs +++ b/Command/Copy.hs @@ -15,7 +15,7 @@ import Annex.Wanted 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 -> diff --git a/Command/Dead.hs b/Command/Dead.hs index 3459576..58bb093 100644 --- a/Command/Dead.hs +++ b/Command/Dead.hs @@ -17,7 +17,7 @@ import qualified Data.Set as S 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 @@ start ws = do 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 diff --git a/Command/Describe.hs b/Command/Describe.hs index 61297e7..18851b1 100644 --- a/Command/Describe.hs +++ b/Command/Describe.hs @@ -14,7 +14,7 @@ import Logs.UUID 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] diff --git a/Command/Direct.hs b/Command/Direct.hs index 1617bd9..7ded712 100644 --- a/Command/Direct.hs +++ b/Command/Direct.hs @@ -18,7 +18,8 @@ import Annex.Version 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] diff --git a/Command/Drop.hs b/Command/Drop.hs index 1d09ca3..b3f7d75 100644 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -21,7 +21,7 @@ import Annex.Wanted 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 @@ seek = [withField fromOption Remote.byNameWithUUID $ \from -> 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 @@ notEnoughCopies key need have skip bad = do 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 diff --git a/Command/DropKey.hs b/Command/DropKey.hs index c0d4f85..6249195 100644 --- a/Command/DropKey.hs +++ b/Command/DropKey.hs @@ -16,7 +16,7 @@ import Types.Key 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] diff --git a/Command/DropUnused.hs b/Command/DropUnused.hs index ccf43c0..a23e0cb 100644 --- a/Command/DropUnused.hs +++ b/Command/DropUnused.hs @@ -19,7 +19,7 @@ import qualified Option 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] diff --git a/Command/Find.hs b/Command/Find.hs index 96f47ec..a326b26 100644 --- a/Command/Find.hs +++ b/Command/Find.hs @@ -21,7 +21,7 @@ import qualified Option 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" diff --git a/Command/Fix.hs b/Command/Fix.hs index e15951c..6aedbad 100644 --- a/Command/Fix.hs +++ b/Command/Fix.hs @@ -10,11 +10,10 @@ module Command.Fix where 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 @@ seek = [withFilesInGit $ whenAnnexed start] {- 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 diff --git a/Command/FromKey.hs b/Command/FromKey.hs index d023be6..30b4914 100644 --- a/Command/FromKey.hs +++ b/Command/FromKey.hs @@ -16,7 +16,7 @@ import Types.Key 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 @@ start _ = error "specify a key and a dest file" 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 diff --git a/Command/Fsck.hs b/Command/Fsck.hs index aeed58c..0d70f69 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -36,7 +36,7 @@ import System.Locale 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 @@ check cs = all id <$> sequence cs -} 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 @@ verifyLocationLog key desc = do {- 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 -> Annex Bool 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 @@ checkKeySizeOr bad key file = case Types.Key.keySize key of -} 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 @@ needFsck _ _ = return True -} 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 diff --git a/Command/Get.hs b/Command/Get.hs index 95f71a8..432be31 100644 --- a/Command/Get.hs +++ b/Command/Get.hs @@ -17,7 +17,7 @@ import Annex.Wanted 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 -> diff --git a/Command/Group.hs b/Command/Group.hs index 5513ca3..aee02b6 100644 --- a/Command/Group.hs +++ b/Command/Group.hs @@ -16,7 +16,8 @@ import Types.Group 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] diff --git a/Command/Help.hs b/Command/Help.hs index 95033eb..5762982 100644 --- a/Command/Help.hs +++ b/Command/Help.hs @@ -18,21 +18,30 @@ import qualified Command.Copy 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 @@ showHelp = liftIO $ putStrLn $ unlines , 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 diff --git a/Command/Import.hs b/Command/Import.hs index e8e839e..d86b44b 100644 --- a/Command/Import.hs +++ b/Command/Import.hs @@ -14,7 +14,7 @@ import qualified Command.Add 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] diff --git a/Command/InAnnex.hs b/Command/InAnnex.hs index cd4bff2..4410d72 100644 --- a/Command/InAnnex.hs +++ b/Command/InAnnex.hs @@ -13,7 +13,7 @@ import Annex.Content 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] diff --git a/Command/Indirect.hs b/Command/Indirect.hs index 6290e67..9ce2751 100644 --- a/Command/Indirect.hs +++ b/Command/Indirect.hs @@ -22,7 +22,7 @@ import Init 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 @@ perform = do 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 diff --git a/Command/Init.hs b/Command/Init.hs index 342ef84..3db9a6b 100644 --- a/Command/Init.hs +++ b/Command/Init.hs @@ -13,7 +13,7 @@ import Init 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] diff --git a/Command/InitRemote.hs b/Command/InitRemote.hs index 684f868..c82dc9d 100644 --- a/Command/InitRemote.hs +++ b/Command/InitRemote.hs @@ -20,7 +20,7 @@ import Logs.UUID 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] diff --git a/Command/Lock.hs b/Command/Lock.hs index c34e6a1..6dc58df 100644 --- a/Command/Lock.hs +++ b/Command/Lock.hs @@ -12,7 +12,8 @@ import Command 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] diff --git a/Command/Log.hs b/Command/Log.hs index 6608a99..2d4819f 100644 --- a/Command/Log.hs +++ b/Command/Log.hs @@ -37,7 +37,7 @@ type Outputter = Bool -> POSIXTime -> [UUID] -> Annex () 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] diff --git a/Command/Map.hs b/Command/Map.hs index f2ac520..c88520b 100644 --- a/Command/Map.hs +++ b/Command/Map.hs @@ -28,7 +28,8 @@ data Link = Link Git.Repo Git.Repo 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] diff --git a/Command/Merge.hs b/Command/Merge.hs index 0f46614..382a251 100644 --- a/Command/Merge.hs +++ b/Command/Merge.hs @@ -12,8 +12,8 @@ import Command 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] diff --git a/Command/Migrate.hs b/Command/Migrate.hs index 5374bc9..e0ef650 100644 --- a/Command/Migrate.hs +++ b/Command/Migrate.hs @@ -19,7 +19,8 @@ import qualified Command.Fsck 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 @@ perform file oldkey oldbackend newbackend = do 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 diff --git a/Command/Move.hs b/Command/Move.hs index cc8fb50..31daf55 100644 --- a/Command/Move.hs +++ b/Command/Move.hs @@ -20,7 +20,7 @@ import Logs.Transfer 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" diff --git a/Command/PreCommit.hs b/Command/PreCommit.hs index 23b6ecc..565344d 100644 --- a/Command/PreCommit.hs +++ b/Command/PreCommit.hs @@ -17,7 +17,8 @@ import Annex.Content.Direct 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 = diff --git a/Command/ReKey.hs b/Command/ReKey.hs index 54a345d..d14edb0 100644 --- a/Command/ReKey.hs +++ b/Command/ReKey.hs @@ -20,7 +20,7 @@ import Utility.CopyFile 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 @@ perform file oldkey newkey = do {- 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 diff --git a/Command/RecvKey.hs b/Command/RecvKey.hs index 11a5fd5..041e104 100644 --- a/Command/RecvKey.hs +++ b/Command/RecvKey.hs @@ -11,6 +11,7 @@ import Common.Annex import Command import CmdLine import Annex.Content +import Annex import Utility.Rsync import Logs.Transfer import Command.SendKey (fieldTransfer) @@ -21,7 +22,7 @@ import qualified Backend 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 @@ start key = ifM (inAnnex key) ) ) 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 diff --git a/Command/Reinject.hs b/Command/Reinject.hs index 12657f7..642f389 100644 --- a/Command/Reinject.hs +++ b/Command/Reinject.hs @@ -15,7 +15,7 @@ import qualified Command.Fsck 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] diff --git a/Command/Semitrust.hs b/Command/Semitrust.hs index f8c3062..e205636 100644 --- a/Command/Semitrust.hs +++ b/Command/Semitrust.hs @@ -14,7 +14,7 @@ import Logs.Trust 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] diff --git a/Command/SendKey.hs b/Command/SendKey.hs index dfdec7f..afd1ac1 100644 --- a/Command/SendKey.hs +++ b/Command/SendKey.hs @@ -10,25 +10,30 @@ module Command.SendKey where 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 diff --git a/Command/Status.hs b/Command/Status.hs index ff71e01..37d6500 100644 --- a/Command/Status.hs +++ b/Command/Status.hs @@ -58,7 +58,7 @@ type StatState = StateT StatInfo Annex 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] diff --git a/Command/Sync.hs b/Command/Sync.hs index 39eda90..a25f6a6 100644 --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -14,7 +14,6 @@ import qualified Remote 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 @@ import Data.Hash.MD5 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 @@ resolveMerge' u [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) $ diff --git a/Command/Test.hs b/Command/Test.hs index 7ff9f29..bf15dcf 100644 --- a/Command/Test.hs +++ b/Command/Test.hs @@ -11,7 +11,8 @@ import Command 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] diff --git a/Command/TransferInfo.hs b/Command/TransferInfo.hs index 800b721..4bebdeb 100644 --- a/Command/TransferInfo.hs +++ b/Command/TransferInfo.hs @@ -13,9 +13,10 @@ import Annex.Content 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 @@ start (k:[]) = do (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 diff --git a/Command/TransferKey.hs b/Command/TransferKey.hs index e2c926d..eb657d7 100644 --- a/Command/TransferKey.hs +++ b/Command/TransferKey.hs @@ -20,7 +20,7 @@ import qualified Option 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] diff --git a/Command/TransferKeys.hs b/Command/TransferKeys.hs index 2114e22..458fb31 100644 --- a/Command/TransferKeys.hs +++ b/Command/TransferKeys.hs @@ -23,7 +23,8 @@ data TransferRequest = TransferRequest Direction Remote Key AssociatedFile 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 @@ runRequests readh writeh a = do (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 diff --git a/Command/Trust.hs b/Command/Trust.hs index d976b86..26993ef 100644 --- a/Command/Trust.hs +++ b/Command/Trust.hs @@ -13,7 +13,8 @@ import qualified Remote 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] diff --git a/Command/Unannex.hs b/Command/Unannex.hs index d1f27e8..53b593f 100644 --- a/Command/Unannex.hs +++ b/Command/Unannex.hs @@ -17,7 +17,8 @@ import qualified Git.LsFiles as LsFiles 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 @@ cleanup file key = do 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 diff --git a/Command/Ungroup.hs b/Command/Ungroup.hs index ea5b8ed..a6557f2 100644 --- a/Command/Ungroup.hs +++ b/Command/Ungroup.hs @@ -16,7 +16,8 @@ import Types.Group 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] diff --git a/Command/Uninit.hs b/Command/Uninit.hs index 2ba32a2..c57fff0 100644 --- a/Command/Uninit.hs +++ b/Command/Uninit.hs @@ -19,7 +19,7 @@ import Annex.Content 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 diff --git a/Command/Unlock.hs b/Command/Unlock.hs index 422afcc..1eba26f 100644 --- a/Command/Unlock.hs +++ b/Command/Unlock.hs @@ -18,7 +18,7 @@ def = , 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 @@ perform dest key = do 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" diff --git a/Command/Untrust.hs b/Command/Untrust.hs index e16040e..f186378 100644 --- a/Command/Untrust.hs +++ b/Command/Untrust.hs @@ -14,7 +14,7 @@ import Logs.Trust def :: [Command] def = [command "untrust" (paramRepeating paramRemote) seek - "do not trust a repository"] + SectionSetup "do not trust a repository"] seek :: [CommandSeek] seek = [withWords start] diff --git a/Command/Unused.hs b/Command/Unused.hs index 25cd18c..6c4a61c 100644 --- a/Command/Unused.hs +++ b/Command/Unused.hs @@ -37,7 +37,7 @@ import Types.Key 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" diff --git a/Command/Upgrade.hs b/Command/Upgrade.hs index d1c1eb3..88ca862 100644 --- a/Command/Upgrade.hs +++ b/Command/Upgrade.hs @@ -14,7 +14,8 @@ import Annex.Version 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] diff --git a/Command/Version.hs b/Command/Version.hs index e066bba..9d2399b 100644 --- a/Command/Version.hs +++ b/Command/Version.hs @@ -15,7 +15,7 @@ import BuildFlags 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] diff --git a/Command/Vicfg.hs b/Command/Vicfg.hs index 8aefd86..ad0fa02 100644 --- a/Command/Vicfg.hs +++ b/Command/Vicfg.hs @@ -25,7 +25,7 @@ import Remote def :: [Command] def = [command "vicfg" paramNothing seek - "edit git-annex's configuration"] + SectionSetup "edit git-annex's configuration"] seek :: [CommandSeek] seek = [withNothing start] diff --git a/Command/Watch.hs b/Command/Watch.hs index 25b5c6b..f965c30 100644 --- a/Command/Watch.hs +++ b/Command/Watch.hs @@ -14,7 +14,7 @@ import Option 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 -> diff --git a/Command/WebApp.hs b/Command/WebApp.hs index 5e461ed..33d6f53 100644 --- a/Command/WebApp.hs +++ b/Command/WebApp.hs @@ -31,7 +31,7 @@ import System.Process (env, std_out, std_err) 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 @@ firstRun = do v <- newEmptyMVar let callback a = Just $ a v runAssistant d $ do - startNamedThread (Just urlrenderer) $ + startNamedThread urlrenderer $ webAppThread d urlrenderer True (callback signaler) (callback mainthread) diff --git a/Command/Whereis.hs b/Command/Whereis.hs index 251c4ec..7086bf6 100644 --- a/Command/Whereis.hs +++ b/Command/Whereis.hs @@ -16,7 +16,7 @@ import Logs.Trust 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 -> diff --git a/Command/XMPPGit.hs b/Command/XMPPGit.hs index c54d6a8..c1ff0b1 100644 --- a/Command/XMPPGit.hs +++ b/Command/XMPPGit.hs @@ -13,7 +13,8 @@ import Assistant.XMPP.Git 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] diff --git a/Common/Annex.hs b/Common/Annex.hs index e90825f..3b8bcdb 100644 --- a/Common/Annex.hs +++ b/Common/Annex.hs @@ -3,6 +3,6 @@ module Common.Annex (module X) where 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 @@ -92,7 +92,7 @@ getRemoteCredPair c storage = maybe fromcache (return . Just) =<< fromenv 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) @@ -26,12 +26,11 @@ module Crypto ( 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 Utility.Gpg.Types 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 @@ cipherSize = 512 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 -> KeyIds -> IO StorableCipher 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 @@ decryptCipher (EncryptedCipher t _) = {- 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 @@ encrypt opts = Gpg.feedRead ( Params "--symmetric --force-mdc" : toParams opts ) 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" diff --git a/GitAnnex.hs b/GitAnnex.hs index 6a0139d..b78493d 100644 --- a/GitAnnex.hs +++ b/GitAnnex.hs @@ -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 @@ cmds = concat #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 diff --git a/GitAnnex/Options.hs b/GitAnnex/Options.hs new file mode 100644 index 0000000..7710c2f --- /dev/null +++ b/GitAnnex/Options.hs @@ -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 diff --git a/GitAnnexShell.hs b/GitAnnexShell.hs index fca36cf..31912eb 100644 --- a/GitAnnexShell.hs +++ b/GitAnnexShell.hs @@ -15,6 +15,7 @@ import qualified Git.Construct import CmdLine import Command import Annex.UUID +import Annex (setField) import qualified Option import Fields import Utility.UserInfo @@ -62,7 +63,7 @@ options = Option.common ++ 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 :: String -> String -> [String] -> IO () 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 @@ checkField (field, value) | 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" @@ -18,6 +18,7 @@ import Utility.TempFile 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 @@ import Backend 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 @@ initialize mdescription = do prepUUID setVersion defaultVersion checkCrippledFileSystem + checkFifoSupport Annex.Branch.create gitPreCommitHookWrite createInodeSentinalFile @@ -132,7 +134,7 @@ probeCrippledFileSystem = do 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 @@ checkCrippledFileSystem = whenM (probeCrippledFileSystem) $ do 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) @@ -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 @@ limitIn name = Right $ \notpresent -> check $ 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 @@ addCopies = addLimit . limitCopies 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 @@ limitCopies want = case split ":" want of 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 @@ addSmallerThan = addLimit . limitSize (<) 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 diff --git a/Locations.hs b/Locations.hs index 9f892a8..cb98b84 100644 --- a/Locations.hs +++ b/Locations.hs @@ -11,6 +11,7 @@ module Locations ( keyPaths, keyPath, gitAnnexLocation, + gitAnnexLink, gitAnnexMapping, gitAnnexInodeCache, gitAnnexInodeSentinal, @@ -88,7 +89,7 @@ annexLocations key = map (annexLocation key) annexHashes 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 @@ annexLocation key hasher = objectDir </> keyPath key hasher - 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 @@ gitAnnexObjectDir r = addTrailingPathSeparator $ Git.localGitDir r </> objectDir 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 diff --git a/Logs/Group.hs b/Logs/Group.hs index a069edc..85906f0 100644 --- a/Logs/Group.hs +++ b/Logs/Group.hs @@ -13,6 +13,7 @@ module Logs.Group ( groupMap, groupMapLoad, getStandardGroup, + inUnwantedGroup ) where import qualified Data.Map as M @@ -66,11 +67,15 @@ makeGroupMap :: M.Map UUID (S.Set Group) -> GroupMap 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 diff --git a/Logs/PreferredContent.hs b/Logs/PreferredContent.hs index 3340cf5..d980cd3 100644 --- a/Logs/PreferredContent.hs +++ b/Logs/PreferredContent.hs @@ -27,8 +27,8 @@ import qualified Annex 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 @@ preferredContentSet uuid@(UUID _) val = do 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 @@ preferredContentMapRaw = simpleMap . parseLog Just - 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. -} diff --git a/Logs/Remote.hs b/Logs/Remote.hs index 55fb40f..89792b0 100644 --- a/Logs/Remote.hs +++ b/Logs/Remote.hs @@ -93,7 +93,7 @@ prop_idempotent_configEscape s = s == (configUnEscape . configEscape) s 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 diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs index e739331..7789325 100644 --- a/Logs/Transfer.hs +++ b/Logs/Transfer.hs @@ -13,6 +13,7 @@ import Annex.Exception import qualified Git import Types.Remote import Types.Key +import Utility.Metered import Utility.Percentage import Utility.QuickCheck @@ -69,6 +70,7 @@ describeTransfer t info = unwords [ 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 @@ runTransfer t file shouldretry a = do 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 @@ mkProgressUpdater t info = do 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 @@ checkTransfer t = do {- 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 @@ transferLockFile infofile = let (d,f) = splitFileName infofile in {- 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 @@ writeTransferInfoFile info tfile = do 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 @@ instance Arbitrary TransferInfo where 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) diff --git a/Logs/Trust.hs b/Logs/Trust.hs index 0582507..89a5404 100644 --- a/Logs/Trust.hs +++ b/Logs/Trust.hs @@ -70,7 +70,7 @@ trustPartition level ls 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 diff --git a/Logs/Unused.hs b/Logs/Unused.hs index bef78a9..437b01f 100644 --- a/Logs/Unused.hs +++ b/Logs/Unused.hs @@ -31,7 +31,7 @@ readUnusedLog :: FilePath -> Annex UnusedMap 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 ) @@ -50,7 +50,7 @@ test: git-annex # 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. diff --git a/Messages.hs b/Messages.hs index d79c91a..cc82b90 100644 --- a/Messages.hs +++ b/Messages.hs @@ -43,14 +43,15 @@ import System.Log.Logger 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 @@ showProgress = handle q $ {- 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 @@ metered combinemeterupdate key a = go (keySize key) {- 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 @@ meteredBytes combinemeterupdate size a = withOutputType go 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 diff --git a/Messages/JSON.hs b/Messages/JSON.hs index e262192..d57d693 100644 --- a/Messages/JSON.hs +++ b/Messages/JSON.hs @@ -34,7 +34,4 @@ add :: JSON a => [(String, a)] -> IO () 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 diff --git a/Meters.hs b/Meters.hs deleted file mode 100644 index 378e570..0000000 --- a/Meters.hs +++ /dev/null @@ -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 @@ -1,4 +1,4 @@ -{- git-annex command-line options +{- common command-line options - - Copyright 2010-2011 Joey Hess <joey@kitenet.net> - @@ -28,6 +28,7 @@ module Remote ( byCost, prettyPrintUUIDs, prettyListUUIDs, + prettyUUID, remoteFromUUID, remotesWithUUID, remotesWithoutUUID, @@ -150,7 +151,7 @@ prettyListUUIDs :: [UUID] -> Annex [String] 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 @@ -159,6 +160,10 @@ prettyListUUIDs uuids = do 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. -} remoteFromUUID :: UUID -> Annex (Maybe Remote) diff --git a/Remote/Bup.hs b/Remote/Bup.hs index d168f07..1c69d0a 100644 --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -29,6 +29,7 @@ import Data.ByteString.Lazy.UTF8 (fromString) import Data.Digest.Pure.SHA import Utility.UserInfo import Annex.Content +import Utility.Metered type BupRepo = String diff --git a/Remote/Directory.hs b/Remote/Directory.hs index be533d0..8c5fa79 100644 --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -24,7 +24,7 @@ import Remote.Helper.Encryptable import Remote.Helper.Chunked import Crypto import Annex.Content -import Meters +import Utility.Metered remote :: RemoteType remote = RemoteType { @@ -154,17 +154,20 @@ storeSplit' :: MeterUpdate -> Int64 -> [FilePath] -> [S.ByteString] -> [FilePath 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 diff --git a/Remote/Git.hs b/Remote/Git.hs index 207655b..eecc9cf 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -40,6 +40,7 @@ import Init import Types.Key import qualified Fields import Logs.Location +import Utility.Metered import Control.Concurrent import Control.Concurrent.MSampleVar @@ -110,6 +111,7 @@ gen r u _ gc = go <$> remoteCost gc defcst 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 @@ copyFromRemote r key file dest : 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 @@ copyFromRemote r key file dest 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 @@ rsyncOrCopyFile rsyncparams src dest p = 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 diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs index ea5df31..088c62f 100644 --- a/Remote/Glacier.hs +++ b/Remote/Glacier.hs @@ -22,7 +22,7 @@ import Remote.Helper.Encryptable import qualified Remote.Helper.AWS as AWS import Crypto import Creds -import Meters +import Utility.Metered import qualified Annex import Annex.Content diff --git a/Remote/Helper/Chunked.hs b/Remote/Helper/Chunked.hs index 11b8604..46678de 100644 --- a/Remote/Helper/Chunked.hs +++ b/Remote/Helper/Chunked.hs @@ -10,7 +10,7 @@ module Remote.Helper.Chunked where 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 diff --git a/Remote/Helper/Encryptable.hs b/Remote/Helper/Encryptable.hs index 242fcfe..f3b6bb7 100644 --- a/Remote/Helper/Encryptable.hs +++ b/Remote/Helper/Encryptable.hs @@ -12,9 +12,11 @@ import qualified Data.Map as M 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 @@ embedCreds c 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 diff --git a/Remote/Hook.hs b/Remote/Hook.hs index 97691d0..46ee800 100644 --- a/Remote/Hook.hs +++ b/Remote/Hook.hs @@ -21,6 +21,7 @@ import Annex.Content import Remote.Helper.Special import Remote.Helper.Encryptable import Crypto +import Utility.Metered remote :: RemoteType remote = RemoteType { diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs index 1425601..a575043 100644 --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -22,6 +22,7 @@ import Remote.Helper.Encryptable import Crypto import Utility.Rsync import Utility.CopyFile +import Utility.Metered import Annex.Perms type RsyncUrl = String @@ -126,7 +127,7 @@ retrieveCheap :: RsyncOpts -> Key -> FilePath -> Annex Bool 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) $ diff --git a/Remote/S3.hs b/Remote/S3.hs index 0ca86f1..0178866 100644 --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -27,7 +27,7 @@ import Remote.Helper.Encryptable import qualified Remote.Helper.AWS as AWS import Crypto import Creds -import Meters +import Utility.Metered import Annex.Content remote :: RemoteType diff --git a/Remote/Web.hs b/Remote/Web.hs index b0d1200..5af3c52 100644 --- a/Remote/Web.hs +++ b/Remote/Web.hs @@ -17,6 +17,7 @@ import Config.Cost import Logs.Web import qualified Utility.Url as Url import Types.Key +import Utility.Metered import qualified Data.Map as M diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs index 3b729fe..db55354 100644 --- a/Remote/WebDAV.hs +++ b/Remote/WebDAV.hs @@ -30,7 +30,7 @@ import Remote.Helper.Encryptable import Remote.Helper.Chunked import Crypto import Creds -import Meters +import Utility.Metered import Annex.Content type DavUrl = String @@ -28,7 +28,7 @@ seekHelper a params = do 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 @@ -72,7 +72,7 @@ main = do 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 @@ quickcheck = , 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 @@ cleanup dir = do -- removed via directory permissions; undo recurseDir SystemFS dir >>= filterM doesDirectoryExist >>= - mapM_ Utility.FileMode.allowWrite + mapM_ Utility.FileMode.allowWrite removeDirectoryRecursive dir checklink :: FilePath -> Assertion @@ -14,8 +14,7 @@ module Types ( RemoteGitConfig(..), Remote, RemoteType, - Option, - MeterUpdate + Option ) where import Annex @@ -25,7 +24,6 @@ import Types.Key import Types.UUID import Types.Remote import Types.Option -import Types.Meters type Backend = BackendA Annex type Remote = RemoteA Annex diff --git a/Types/Command.hs b/Types/Command.hs index b652bda..4b92ca1 100644 --- a/Types/Command.hs +++ b/Types/Command.hs @@ -42,6 +42,7 @@ data Command = Command , 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 CommandCheck where 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" diff --git a/Types/Crypto.hs b/Types/Crypto.hs index 135522b..e97d02b 100644 --- a/Types/Crypto.hs +++ b/Types/Crypto.hs @@ -9,8 +9,16 @@ module Types.Crypto ( 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 @@ newtype Cipher = Cipher String 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 diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs index b42f8f2..c06e3ec 100644 --- a/Types/GitConfig.hs +++ b/Types/GitConfig.hs @@ -37,6 +37,7 @@ data GitConfig = GitConfig , annexAutoCommit :: Bool , annexWebOptions :: [String] , annexCrippledFileSystem :: Bool + , annexLargeFiles :: Maybe String , coreSymlinks :: Bool } @@ -59,6 +60,7 @@ extractGitConfig r = GitConfig , 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 @@ data RemoteGitConfig = RemoteGitConfig , 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 @@ data RemoteGitConfig = RemoteGitConfig , 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 @@ extractRemoteGitConfig r remotename = RemoteGitConfig , 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 diff --git a/Types/Meters.hs b/Types/Meters.hs deleted file mode 100644 index ef304d1..0000000 --- a/Types/Meters.hs +++ /dev/null @@ -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 ()) diff --git a/Types/Remote.hs b/Types/Remote.hs index 64a7710..e653675 100644 --- a/Types/Remote.hs +++ b/Types/Remote.hs @@ -15,9 +15,9 @@ import Data.Ord 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 diff --git a/Types/StandardGroups.hs b/Types/StandardGroups.hs index 8c19e14..434600f 100644 --- a/Types/StandardGroups.hs +++ b/Types/StandardGroups.hs @@ -16,6 +16,7 @@ data StandardGroup | FullArchiveGroup | SourceGroup | ManualGroup + | UnwantedGroup deriving (Eq, Ord, Enum, Bounded, Show) fromStandardGroup :: StandardGroup -> String @@ -27,6 +28,7 @@ fromStandardGroup SmallArchiveGroup = "smallarchive" 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 "smallarchive" = Just SmallArchiveGroup 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 SmallArchiveGroup = "small archive: archives files located in 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)" diff --git a/Upgrade/V1.hs b/Upgrade/V1.hs index 72e105d..f356e2c 100644 --- a/Upgrade/V1.hs +++ b/Upgrade/V1.hs @@ -92,7 +92,7 @@ updateSymlinks = do 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] @@ -8,46 +8,54 @@ 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 paramPaths = paramOptional $ paramRepeating paramPath -- most often used diff --git a/Utility/Metered.hs b/Utility/Metered.hs new file mode 100644 index 0000000..f33ad44 --- /dev/null +++ b/Utility/Metered.hs @@ -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 diff --git a/Utility/NotificationBroadcaster.hs b/Utility/NotificationBroadcaster.hs index 413ec2d..b873df6 100644 --- a/Utility/NotificationBroadcaster.hs +++ b/Utility/NotificationBroadcaster.hs @@ -40,14 +40,23 @@ data NotificationHandle = NotificationHandle NotificationBroadcaster Notificatio 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] diff --git a/Utility/Observed.hs b/Utility/Observed.hs deleted file mode 100644 index 3ee9734..0000000 --- a/Utility/Observed.hs +++ /dev/null @@ -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 diff --git a/Utility/Rsync.hs b/Utility/Rsync.hs index e038242..a36c607 100644 --- a/Utility/Rsync.hs +++ b/Utility/Rsync.hs @@ -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 @@ rsyncShell command = [Param "-e", Param $ unwords $ map escape (toCommand comman 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 @@ rsyncServerParams = 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 @@ rsyncProgress callback params = do 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 @@ parseRsyncProgress = go [] . reverse . progresschunks ([], _) -> 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) "" diff --git a/Utility/SafeCommand.hs b/Utility/SafeCommand.hs index e6075e8..785aec5 100644 --- a/Utility/SafeCommand.hs +++ b/Utility/SafeCommand.hs @@ -55,8 +55,16 @@ safeSystemEnv command params environ = do { 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 diff --git a/debian/changelog b/debian/changelog index 51d17c5..46f1b4d 100644 --- a/debian/changelog +++ b/debian/changelog @@ -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 diff --git a/debian/control b/debian/control index be65a39..c8a15ed 100644 --- a/debian/control +++ b/debian/control @@ -4,7 +4,6 @@ Priority: optional Build-Depends: debhelper (>= 9), ghc (>= 7.4), - cabal-install, libghc-mtl-dev (>= 2.1.1), libghc-missingh-dev, libghc-hslogger-dev, diff --git a/debian/rules b/debian/rules index 7155bad..99bcd6a 100755 --- a/debian/rules +++ b/debian/rules @@ -1,5 +1,8 @@ #!/usr/bin/make -f +# Avoid using cabal, as it writes to $HOME +export CABAL=runghc Setup.hs + %: dh $@ diff --git a/doc/assistant.mdwn b/doc/assistant.mdwn index 0f6c46b..9f9ed0c 100644 --- a/doc/assistant.mdwn +++ b/doc/assistant.mdwn @@ -18,25 +18,15 @@ the [[release_notes]] for known infelicities and upgrade instructions. ## 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 diff --git a/doc/assistant/.release_notes.mdwn.swp b/doc/assistant/.release_notes.mdwn.swp Binary files differdeleted file mode 100644 index eed4092..0000000 --- a/doc/assistant/.release_notes.mdwn.swp +++ /dev/null diff --git a/doc/assistant/deleterepository.png b/doc/assistant/deleterepository.png Binary files differnew file mode 100644 index 0000000..20db674 --- /dev/null +++ b/doc/assistant/deleterepository.png diff --git a/doc/assistant/pairing_walkthrough.mdwn b/doc/assistant/local_pairing_walkthrough.mdwn index 07b6399..07b6399 100644 --- a/doc/assistant/pairing_walkthrough.mdwn +++ b/doc/assistant/local_pairing_walkthrough.mdwn diff --git a/doc/assistant/pairing_walkthrough/addrepository.png b/doc/assistant/local_pairing_walkthrough/addrepository.png Binary files differindex b82efdb..b82efdb 100644 --- a/doc/assistant/pairing_walkthrough/addrepository.png +++ b/doc/assistant/local_pairing_walkthrough/addrepository.png diff --git a/doc/assistant/pairing_walkthrough/pairing.png b/doc/assistant/local_pairing_walkthrough/pairing.png Binary files differindex dfbbf06..dfbbf06 100644 --- a/doc/assistant/pairing_walkthrough/pairing.png +++ b/doc/assistant/local_pairing_walkthrough/pairing.png diff --git a/doc/assistant/pairing_walkthrough/pairrequest.png b/doc/assistant/local_pairing_walkthrough/pairrequest.png Binary files differindex 8d3f603..8d3f603 100644 --- a/doc/assistant/pairing_walkthrough/pairrequest.png +++ b/doc/assistant/local_pairing_walkthrough/pairrequest.png diff --git a/doc/assistant/pairing_walkthrough/secret.png b/doc/assistant/local_pairing_walkthrough/secret.png Binary files differindex 1eb8051..1eb8051 100644 --- a/doc/assistant/pairing_walkthrough/secret.png +++ b/doc/assistant/local_pairing_walkthrough/secret.png diff --git a/doc/assistant/pairing_walkthrough/secretempty.png b/doc/assistant/local_pairing_walkthrough/secretempty.png Binary files differindex 4918787..4918787 100644 --- a/doc/assistant/pairing_walkthrough/secretempty.png +++ b/doc/assistant/local_pairing_walkthrough/secretempty.png diff --git a/doc/assistant/quickstart.mdwn b/doc/assistant/quickstart.mdwn index 3fd5d07..0472ba4 100644 --- a/doc/assistant/quickstart.mdwn +++ b/doc/assistant/quickstart.mdwn @@ -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 @@ git, and synced to repositories on other computers. You can use the 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. diff --git a/doc/assistant/release_notes.mdwn b/doc/assistant/release_notes.mdwn index bdbf65e..4965601 100644 --- a/doc/assistant/release_notes.mdwn +++ b/doc/assistant/release_notes.mdwn @@ -71,7 +71,7 @@ will work. Some examples of use cases supported by this release include: * 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 @@ will work. Some examples of use cases supported by this release include: * 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 @@ will work. Some examples of use cases supported by this release include: * 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 @@ beta. 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 @@ This is the first beta release of the git-annex assistant. 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 diff --git a/doc/assistant/remote_sharing_walkthrough.mdwn b/doc/assistant/remote_sharing_walkthrough.mdwn new file mode 100644 index 0000000..57a3e29 --- /dev/null +++ b/doc/assistant/remote_sharing_walkthrough.mdwn @@ -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]]. diff --git a/doc/assistant/share_with_a_friend_walkthrough.mdwn b/doc/assistant/share_with_a_friend_walkthrough.mdwn index a748ebd..38544d1 100644 --- a/doc/assistant/share_with_a_friend_walkthrough.mdwn +++ b/doc/assistant/share_with_a_friend_walkthrough.mdwn @@ -7,7 +7,7 @@ works with any Jabber account you use, not just Google Talk.) 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*` diff --git a/doc/assistant/thanks.mdwn b/doc/assistant/thanks.mdwn index cd7f80b..a6cfb73 100644 --- a/doc/assistant/thanks.mdwn +++ b/doc/assistant/thanks.mdwn @@ -231,6 +231,9 @@ Tyree, Aaron Whitehouse 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. diff --git a/doc/bugs/Creating_an_encrypted_S3_does_not_check_for_presence_of_GPG.mdwn b/doc/bugs/Creating_an_encrypted_S3_does_not_check_for_presence_of_GPG.mdwn index f497c87..a4bfdcb 100644 --- a/doc/bugs/Creating_an_encrypted_S3_does_not_check_for_presence_of_GPG.mdwn +++ b/doc/bugs/Creating_an_encrypted_S3_does_not_check_for_presence_of_GPG.mdwn @@ -15,4 +15,4 @@ What version of git-annex are you using? On what operating system? Please provide any additional information below. -[[!tag /design/assistant/OSX]] +[[!tag /design/assistant]] diff --git a/doc/bugs/Detection_assumes_that_shell_is_bash.mdwn b/doc/bugs/Detection_assumes_that_shell_is_bash.mdwn index 46b159e..9bb0629 100644 --- a/doc/bugs/Detection_assumes_that_shell_is_bash.mdwn +++ b/doc/bugs/Detection_assumes_that_shell_is_bash.mdwn @@ -18,3 +18,7 @@ git-annex version: 3.20121017 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]] diff --git a/doc/bugs/No_progress_bars_with_S3.mdwn b/doc/bugs/No_progress_bars_with_S3.mdwn index 907b3cb..afa7ba5 100644 --- a/doc/bugs/No_progress_bars_with_S3.mdwn +++ b/doc/bugs/No_progress_bars_with_S3.mdwn @@ -19,3 +19,8 @@ I expect a changing status bar and percentage. Instead I see no changes when an 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]] diff --git a/doc/bugs/Segfaults_on_Fedora_18_with_SELinux_enabled.mdwn b/doc/bugs/Segfaults_on_Fedora_18_with_SELinux_enabled.mdwn new file mode 100644 index 0000000..39b860e --- /dev/null +++ b/doc/bugs/Segfaults_on_Fedora_18_with_SELinux_enabled.mdwn @@ -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]] diff --git a/doc/bugs/The_webapp_doesn__39__t_allow_deleting_repositories.mdwn b/doc/bugs/The_webapp_doesn__39__t_allow_deleting_repositories.mdwn index f90b88c..88e39ef 100644 --- a/doc/bugs/The_webapp_doesn__39__t_allow_deleting_repositories.mdwn +++ b/doc/bugs/The_webapp_doesn__39__t_allow_deleting_repositories.mdwn @@ -21,3 +21,13 @@ What version of git-annex are you using? On what operating system? 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]] diff --git a/doc/bugs/WEBDAV_443.mdwn b/doc/bugs/WEBDAV_443.mdwn index ffe1c0d..cfde1a1 100644 --- a/doc/bugs/WEBDAV_443.mdwn +++ b/doc/bugs/WEBDAV_443.mdwn @@ -302,3 +302,6 @@ Some tests failed! > 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]] diff --git a/doc/bugs/allows_repository_with_the_same_name_twice.mdwn b/doc/bugs/allows_repository_with_the_same_name_twice.mdwn new file mode 100644 index 0000000..91a31f3 --- /dev/null +++ b/doc/bugs/allows_repository_with_the_same_name_twice.mdwn @@ -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. + diff --git a/doc/bugs/git-annex_add_should_repack_as_it_goes.mdwn b/doc/bugs/git-annex_add_should_repack_as_it_goes.mdwn new file mode 100644 index 0000000..c26e584 --- /dev/null +++ b/doc/bugs/git-annex_add_should_repack_as_it_goes.mdwn @@ -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 diff --git a/doc/bugs/host_with_rysnc_installed__44___not_recognized.mdwn b/doc/bugs/host_with_rysnc_installed__44___not_recognized.mdwn index e411eaf..4513ad9 100644 --- a/doc/bugs/host_with_rysnc_installed__44___not_recognized.mdwn +++ b/doc/bugs/host_with_rysnc_installed__44___not_recognized.mdwn @@ -13,3 +13,7 @@ ssh keys were installed to allow login, when ssh-askpass was not found on osx ve [[!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]] diff --git a/doc/bugs/ssh_connection_caching_broken_on_NTFS.mdwn b/doc/bugs/ssh_connection_caching_broken_on_NTFS.mdwn index bfb2211..fc3168e 100644 --- a/doc/bugs/ssh_connection_caching_broken_on_NTFS.mdwn +++ b/doc/bugs/ssh_connection_caching_broken_on_NTFS.mdwn @@ -61,3 +61,6 @@ However ssh connection caching breaks things on NTFS volumes. If I turn off con 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]] diff --git a/doc/coding_style.mdwn b/doc/coding_style.mdwn index ae76d23..101ac4f 100644 --- a/doc/coding_style.mdwn +++ b/doc/coding_style.mdwn @@ -24,7 +24,7 @@ of the function, and avoids excessive indentation of the where cause content. The definitions within the where clause should be put on separate lines, each indented with a tab. - foo = do + main = do foo bar foo diff --git a/doc/design/assistant.mdwn b/doc/design/assistant.mdwn index 96c9bd6..a6e8344 100644 --- a/doc/design/assistant.mdwn +++ b/doc/design/assistant.mdwn @@ -11,13 +11,14 @@ and use cases to add. Feel free to chip in with comments! --[[Joey]] * 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,12 +29,17 @@ We are, approximately, here: ## 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 I'm blogging about my progress in the [[blog]] on a semi-daily basis. diff --git a/doc/design/assistant/OSX.mdwn b/doc/design/assistant/OSX.mdwn index a9f526f..de48721 100644 --- a/doc/design/assistant/OSX.mdwn +++ b/doc/design/assistant/OSX.mdwn @@ -2,16 +2,10 @@ Misc OSX porting things: * 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: [[!inline pages="tagged(design/assistant/OSX) and !link(bugs/done)" show=0 archive=yes]] diff --git a/doc/design/assistant/android.mdwn b/doc/design/assistant/android.mdwn index 65360c0..b43699b 100644 --- a/doc/design/assistant/android.mdwn +++ b/doc/design/assistant/android.mdwn @@ -42,5 +42,9 @@ TH and once for cross. * 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. diff --git a/doc/design/assistant/blog/day_222__back.mdwn b/doc/design/assistant/blog/day_222__back.mdwn new file mode 100644 index 0000000..9c3c170 --- /dev/null +++ b/doc/design/assistant/blog/day_222__back.mdwn @@ -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. diff --git a/doc/design/assistant/blog/day_223__progress_revisited.mdwn b/doc/design/assistant/blog/day_223__progress_revisited.mdwn new file mode 100644 index 0000000..9f89989 --- /dev/null +++ b/doc/design/assistant/blog/day_223__progress_revisited.mdwn @@ -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. diff --git a/doc/design/assistant/blog/day_224__annex.largefiles.mdwn b/doc/design/assistant/blog/day_224__annex.largefiles.mdwn new file mode 100644 index 0000000..4fab93f --- /dev/null +++ b/doc/design/assistant/blog/day_224__annex.largefiles.mdwn @@ -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. diff --git a/doc/design/assistant/blog/day_225__back_from_the_dead.mdwn b/doc/design/assistant/blog/day_225__back_from_the_dead.mdwn new file mode 100644 index 0000000..e550c6b --- /dev/null +++ b/doc/design/assistant/blog/day_225__back_from_the_dead.mdwn @@ -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! diff --git a/doc/design/assistant/blog/day_226__poll_results.mdwn b/doc/design/assistant/blog/day_226__poll_results.mdwn new file mode 100644 index 0000000..e79ff25 --- /dev/null +++ b/doc/design/assistant/blog/day_226__poll_results.mdwn @@ -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.) diff --git a/doc/design/assistant/blog/day_227__bigfixing_all_day_today.mdwn b/doc/design/assistant/blog/day_227__bigfixing_all_day_today.mdwn new file mode 100644 index 0000000..74e9fd8 --- /dev/null +++ b/doc/design/assistant/blog/day_227__bigfixing_all_day_today.mdwn @@ -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. diff --git a/doc/design/assistant/blog/day_228__more_work_on_repository_removals.mdwn b/doc/design/assistant/blog/day_228__more_work_on_repository_removals.mdwn new file mode 100644 index 0000000..f8b4502 --- /dev/null +++ b/doc/design/assistant/blog/day_228__more_work_on_repository_removals.mdwn @@ -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. diff --git a/doc/design/assistant/blog/day_229__rainy_day_bugfixes.mdwn b/doc/design/assistant/blog/day_229__rainy_day_bugfixes.mdwn new file mode 100644 index 0000000..87611a9 --- /dev/null +++ b/doc/design/assistant/blog/day_229__rainy_day_bugfixes.mdwn @@ -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. diff --git a/doc/design/assistant/encrypted_git_remotes.mdwn b/doc/design/assistant/encrypted_git_remotes.mdwn new file mode 100644 index 0000000..63b7be6 --- /dev/null +++ b/doc/design/assistant/encrypted_git_remotes.mdwn @@ -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? diff --git a/doc/design/assistant/polls/goals_for_April.mdwn b/doc/design/assistant/polls/goals_for_April.mdwn new file mode 100644 index 0000000..53132dd --- /dev/null +++ b/doc/design/assistant/polls/goals_for_April.mdwn @@ -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) diff --git a/doc/design/assistant/rate_limiting.mdwn b/doc/design/assistant/rate_limiting.mdwn new file mode 100644 index 0000000..3ab8043 --- /dev/null +++ b/doc/design/assistant/rate_limiting.mdwn @@ -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. diff --git a/doc/design/assistant/syncing.mdwn b/doc/design/assistant/syncing.mdwn index d27a50b..5b2a11a 100644 --- a/doc/design/assistant/syncing.mdwn +++ b/doc/design/assistant/syncing.mdwn @@ -25,11 +25,6 @@ syncs? ## 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. diff --git a/doc/design/encryption.mdwn b/doc/design/encryption.mdwn index b7acbb7..45eb43c 100644 --- a/doc/design/encryption.mdwn +++ b/doc/design/encryption.mdwn @@ -59,10 +59,11 @@ for each file in the repository, contact the encrypted remote to check 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 diff --git a/doc/encryption.mdwn b/doc/encryption.mdwn index cc61fea..5349e8c 100644 --- a/doc/encryption.mdwn +++ b/doc/encryption.mdwn @@ -21,6 +21,13 @@ If you want to use encryption, run `git annex initremote` with 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. diff --git a/doc/forum/Howto_remove_unused_files.mdwn b/doc/forum/Howto_remove_unused_files.mdwn new file mode 100644 index 0000000..db77045 --- /dev/null +++ b/doc/forum/Howto_remove_unused_files.mdwn @@ -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! diff --git a/doc/forum/Stupid_mistake:_recoverable__63__.mdwn b/doc/forum/Stupid_mistake:_recoverable__63__.mdwn new file mode 100644 index 0000000..8e25d70 --- /dev/null +++ b/doc/forum/Stupid_mistake:_recoverable__63__.mdwn @@ -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. diff --git a/doc/forum/Will_git-annex_solve_my_problem__63__.mdwn b/doc/forum/Will_git-annex_solve_my_problem__63__.mdwn new file mode 100644 index 0000000..0aa2ded --- /dev/null +++ b/doc/forum/Will_git-annex_solve_my_problem__63__.mdwn @@ -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? diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn index 751a347..2f4bb5c 100644 --- a/doc/git-annex.mdwn +++ b/doc/git-annex.mdwn @@ -688,6 +688,9 @@ file contents are present at either of two repositories. 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 @@ file contents are present at either of two repositories. 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 @@ Here are all the supported configuration settings. 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 @@ Here are all the supported configuration settings. 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 @@ Here are all the supported configuration settings. 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 @@ but the SHA256E backend for ogg files: *.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 diff --git a/doc/install/Fedora.mdwn b/doc/install/Fedora.mdwn index d7d0771..9a6006e 100644 --- a/doc/install/Fedora.mdwn +++ b/doc/install/Fedora.mdwn @@ -6,6 +6,21 @@ Should be as simple as: `yum install git-annex` ---- +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 @@ cabal install --bindir=$HOME/bin Note: You can't just use `cabal install git-annex`, because Fedora does not yet ship ghc 7.4. - diff --git a/doc/install/Linux_standalone.mdwn b/doc/install/Linux_standalone.mdwn index d0af502..37f3f6d 100644 --- a/doc/install/Linux_standalone.mdwn +++ b/doc/install/Linux_standalone.mdwn @@ -22,5 +22,5 @@ Warning: This is a last resort. Most Linux users should instead 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/)) diff --git a/doc/install/OSX/comment_15_336e0acb00e84943715e69917643a69e._comment b/doc/install/OSX/comment_15_336e0acb00e84943715e69917643a69e._comment new file mode 100644 index 0000000..05f5654 --- /dev/null +++ b/doc/install/OSX/comment_15_336e0acb00e84943715e69917643a69e._comment @@ -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?* + + +"""]] diff --git a/doc/internals.mdwn b/doc/internals.mdwn index 8ca0355..de81679 100644 --- a/doc/internals.mdwn +++ b/doc/internals.mdwn @@ -10,6 +10,7 @@ to the file content. 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 @@ somewhere else. 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. diff --git a/doc/internals/hashing.mdwn b/doc/internals/hashing.mdwn new file mode 100644 index 0000000..f479cfc --- /dev/null +++ b/doc/internals/hashing.mdwn @@ -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. diff --git a/doc/news/version_3.20130207.mdwn b/doc/news/version_3.20130207.mdwn deleted file mode 100644 index 1e69d05..0000000 --- a/doc/news/version_3.20130207.mdwn +++ /dev/null @@ -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."""]]
\ No newline at end of file diff --git a/doc/news/version_4.20130405.mdwn b/doc/news/version_4.20130405.mdwn new file mode 100644 index 0000000..9c82253 --- /dev/null +++ b/doc/news/version_4.20130405.mdwn @@ -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."""]]
\ No newline at end of file diff --git a/doc/preferred_content.mdwn b/doc/preferred_content.mdwn index 763e348..f8fd29c 100644 --- a/doc/preferred_content.mdwn +++ b/doc/preferred_content.mdwn @@ -77,13 +77,18 @@ drop content that is present! Don't go there.. 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 @@ USB drive used in a sneakernet. 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 @@ All content is preferred. 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 @@ local copy of every file. Instead, you can manually run `git annex get`, 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=*` diff --git a/doc/special_remotes.mdwn b/doc/special_remotes.mdwn index 2cc0cf4..086726a 100644 --- a/doc/special_remotes.mdwn +++ b/doc/special_remotes.mdwn @@ -14,6 +14,7 @@ They cannot be used by other git commands though. * [[rsync]] * [[webdav]] * [[web]] +* [[xmpp]] * [[hook]] The above special remotes can be used to tie git-annex diff --git a/doc/special_remotes/bup/comment_6_5942333cde09fd98e26c4f1d389cb76f._comment b/doc/special_remotes/bup/comment_6_5942333cde09fd98e26c4f1d389cb76f._comment new file mode 100644 index 0000000..288f876 --- /dev/null +++ b/doc/special_remotes/bup/comment_6_5942333cde09fd98e26c4f1d389cb76f._comment @@ -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? +"""]] diff --git a/doc/special_remotes/bup/comment_7_cb1a0d3076e9d06e7a24204478f6fa98._comment b/doc/special_remotes/bup/comment_7_cb1a0d3076e9d06e7a24204478f6fa98._comment new file mode 100644 index 0000000..a2284c3 --- /dev/null +++ b/doc/special_remotes/bup/comment_7_cb1a0d3076e9d06e7a24204478f6fa98._comment @@ -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. +"""]] diff --git a/doc/special_remotes/xmpp.mdwn b/doc/special_remotes/xmpp.mdwn new file mode 100644 index 0000000..ef5e855 --- /dev/null +++ b/doc/special_remotes/xmpp.mdwn @@ -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]] diff --git a/doc/tips/replacing_Sparkleshare_or_dvcs-autosync_with_the_assistant.mdwn b/doc/tips/replacing_Sparkleshare_or_dvcs-autosync_with_the_assistant.mdwn new file mode 100644 index 0000000..4363dc8 --- /dev/null +++ b/doc/tips/replacing_Sparkleshare_or_dvcs-autosync_with_the_assistant.mdwn @@ -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=*" diff --git a/doc/todo/stream_feature__63__.mdwn b/doc/todo/stream_feature__63__.mdwn new file mode 100644 index 0000000..860edfc --- /dev/null +++ b/doc/todo/stream_feature__63__.mdwn @@ -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 diff --git a/doc/videos/git-annex_assistant_archiving.mdwn b/doc/videos/git-annex_assistant_archiving.mdwn index c8486dd..6e400ae 100644 --- a/doc/videos/git-annex_assistant_archiving.mdwn +++ b/doc/videos/git-annex_assistant_archiving.mdwn @@ -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>. diff --git a/doc/videos/git-annex_assistant_introduction.mdwn b/doc/videos/git-annex_assistant_introduction.mdwn index 7be2a27..7014da2 100644 --- a/doc/videos/git-annex_assistant_introduction.mdwn +++ b/doc/videos/git-annex_assistant_introduction.mdwn @@ -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>. diff --git a/doc/videos/git-annex_assistant_remote_sharing.mdwn b/doc/videos/git-annex_assistant_remote_sharing.mdwn new file mode 100644 index 0000000..5aacc6e --- /dev/null +++ b/doc/videos/git-annex_assistant_remote_sharing.mdwn @@ -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. diff --git a/git-annex.1 b/git-annex.1 index e20f4c6..63e3af9 100644 --- a/git-annex.1 +++ b/git-annex.1 @@ -612,6 +612,9 @@ Matches only files that git\-annex believes have the specified number of 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 @@ Opens a group of file matching options. .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 @@ commit logs). Can be specified with any commonly used units, for example, .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 @@ git annex unused. The default accuracy is 1000 \-\- 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 @@ to close it. On Mac OSX, when not using direct mode this defaults to 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 @@ but the SHA256E backend for ogg files: *.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 diff --git a/git-annex.cabal b/git-annex.cabal index 8a36e5f..5e67fc9 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -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> diff --git a/templates/configurators/delete/currentrepository.hamlet b/templates/configurators/delete/currentrepository.hamlet new file mode 100644 index 0000000..d7f7c02 --- /dev/null +++ b/templates/configurators/delete/currentrepository.hamlet @@ -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 diff --git a/templates/configurators/delete/finished.hamlet b/templates/configurators/delete/finished.hamlet new file mode 100644 index 0000000..62fc136 --- /dev/null +++ b/templates/configurators/delete/finished.hamlet @@ -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. diff --git a/templates/configurators/delete/start.hamlet b/templates/configurators/delete/start.hamlet new file mode 100644 index 0000000..a328346 --- /dev/null +++ b/templates/configurators/delete/start.hamlet @@ -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 diff --git a/templates/configurators/editrepository.hamlet b/templates/configurators/editrepository.hamlet index 68d42e8..2639228 100644 --- a/templates/configurators/editrepository.hamlet +++ b/templates/configurators/editrepository.hamlet @@ -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 # diff --git a/templates/controlmenu.hamlet b/templates/controlmenu.hamlet index eda99d9..886f691 100644 --- a/templates/controlmenu.hamlet +++ b/templates/controlmenu.hamlet @@ -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 diff --git a/templates/documentation/repogroup.hamlet b/templates/documentation/repogroup.hamlet index 0b04b6a..e9c1a3b 100644 --- a/templates/documentation/repogroup.hamlet +++ b/templates/documentation/repogroup.hamlet @@ -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. diff --git a/templates/repolist.hamlet b/templates/repolist.hamlet index 6b3930e..0fd02e5 100644 --- a/templates/repolist.hamlet +++ b/templates/repolist.hamlet @@ -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> - Sync your files with another drive, device, or # + Sync your files with another device, or # share with a friend. |
