summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoeyHess <>2013-04-05 16:26:05 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2013-04-05 16:26:05 (GMT)
commit0ef77235d5c3743f0189030a5200a81a557f8e31 (patch)
tree628967eaf483cd43f5e284f2e38df1bee6b27d48
parentf299fa19ebd7a929ca6f3ac402c21815effd89f9 (diff)
version 4.201304054.20130405
-rw-r--r--Annex.hs6
-rw-r--r--Annex/Branch.hs6
-rw-r--r--Annex/Content.hs60
-rw-r--r--Annex/Content/Direct.hs9
-rw-r--r--Annex/Direct.hs17
-rw-r--r--Annex/FileMatcher.hs86
-rw-r--r--Annex/Link.hs4
-rw-r--r--Annex/Ssh.hs2
-rw-r--r--Assistant.hs25
-rw-r--r--Assistant/Alert.hs219
-rw-r--r--Assistant/Alert/Utility.hs130
-rw-r--r--Assistant/Common.hs1
-rw-r--r--Assistant/DaemonStatus.hs9
-rw-r--r--Assistant/DeleteRemote.hs93
-rw-r--r--Assistant/Drop.hs30
-rw-r--r--Assistant/NamedThread.hs31
-rw-r--r--Assistant/Sync.hs20
-rw-r--r--Assistant/Threads/Committer.hs2
-rw-r--r--Assistant/Threads/DaemonStatus.hs2
-rw-r--r--Assistant/Threads/PairListener.hs12
-rw-r--r--Assistant/Threads/TransferPoller.hs2
-rw-r--r--Assistant/Threads/TransferScanner.hs48
-rw-r--r--Assistant/Threads/TransferWatcher.hs4
-rw-r--r--Assistant/Threads/Transferrer.hs7
-rw-r--r--Assistant/Threads/Watcher.hs87
-rw-r--r--Assistant/Threads/WebApp.hs3
-rw-r--r--Assistant/Threads/XMPPClient.hs24
-rw-r--r--Assistant/TransferQueue.hs44
-rw-r--r--Assistant/Types/Alert.hs74
-rw-r--r--Assistant/Types/Changes.hs6
-rw-r--r--Assistant/Types/DaemonStatus.hs2
-rw-r--r--Assistant/Types/NamedThread.hs2
-rw-r--r--Assistant/Types/NetMessager.hs2
-rw-r--r--Assistant/Types/UrlRenderer.hs26
-rw-r--r--Assistant/WebApp.hs2
-rw-r--r--Assistant/WebApp/Configurators/AWS.hs2
-rw-r--r--Assistant/WebApp/Configurators/Delete.hs125
-rw-r--r--Assistant/WebApp/Configurators/Local.hs5
-rw-r--r--Assistant/WebApp/Configurators/Ssh.hs8
-rw-r--r--Assistant/WebApp/Configurators/WebDAV.hs4
-rw-r--r--Assistant/WebApp/Configurators/XMPP.hs23
-rw-r--r--Assistant/WebApp/DashBoard.hs4
-rw-r--r--Assistant/WebApp/RepoList.hs35
-rw-r--r--Assistant/WebApp/SideBar.hs2
-rw-r--r--Assistant/WebApp/Types.hs1
-rw-r--r--Assistant/WebApp/routes7
-rw-r--r--Assistant/XMPP/Git.hs30
-rw-r--r--Backend.hs4
-rw-r--r--CHANGELOG37
-rw-r--r--CmdLine.hs15
-rw-r--r--Command.hs23
-rw-r--r--Command/Add.hs28
-rw-r--r--Command/AddUnused.hs2
-rw-r--r--Command/AddUrl.hs3
-rw-r--r--Command/Assistant.hs3
-rw-r--r--Command/Commit.hs2
-rw-r--r--Command/ConfigList.hs2
-rw-r--r--Command/Copy.hs2
-rw-r--r--Command/Dead.hs8
-rw-r--r--Command/Describe.hs2
-rw-r--r--Command/Direct.hs3
-rw-r--r--Command/Drop.hs25
-rw-r--r--Command/DropKey.hs2
-rw-r--r--Command/DropUnused.hs2
-rw-r--r--Command/Find.hs2
-rw-r--r--Command/Fix.hs5
-rw-r--r--Command/FromKey.hs4
-rw-r--r--Command/Fsck.hs14
-rw-r--r--Command/Get.hs2
-rw-r--r--Command/Group.hs3
-rw-r--r--Command/Help.hs21
-rw-r--r--Command/Import.hs2
-rw-r--r--Command/InAnnex.hs2
-rw-r--r--Command/Indirect.hs8
-rw-r--r--Command/Init.hs2
-rw-r--r--Command/InitRemote.hs2
-rw-r--r--Command/Lock.hs3
-rw-r--r--Command/Log.hs2
-rw-r--r--Command/Map.hs3
-rw-r--r--Command/Merge.hs4
-rw-r--r--Command/Migrate.hs5
-rw-r--r--Command/Move.hs2
-rw-r--r--Command/PreCommit.hs3
-rw-r--r--Command/ReKey.hs4
-rw-r--r--Command/RecvKey.hs18
-rw-r--r--Command/Reinject.hs2
-rw-r--r--Command/Semitrust.hs2
-rw-r--r--Command/SendKey.hs21
-rw-r--r--Command/Status.hs2
-rw-r--r--Command/Sync.hs5
-rw-r--r--Command/Test.hs3
-rw-r--r--Command/TransferInfo.hs11
-rw-r--r--Command/TransferKey.hs2
-rw-r--r--Command/TransferKeys.hs8
-rw-r--r--Command/Trust.hs3
-rw-r--r--Command/Unannex.hs5
-rw-r--r--Command/Ungroup.hs3
-rw-r--r--Command/Uninit.hs2
-rw-r--r--Command/Unlock.hs4
-rw-r--r--Command/Untrust.hs2
-rw-r--r--Command/Unused.hs2
-rw-r--r--Command/Upgrade.hs3
-rw-r--r--Command/Version.hs2
-rw-r--r--Command/Vicfg.hs2
-rw-r--r--Command/Watch.hs2
-rw-r--r--Command/WebApp.hs4
-rw-r--r--Command/Whereis.hs2
-rw-r--r--Command/XMPPGit.hs3
-rw-r--r--Common/Annex.hs2
-rw-r--r--Creds.hs2
-rw-r--r--Crypto.hs51
-rw-r--r--GitAnnex.hs53
-rw-r--r--GitAnnex/Options.hs60
-rw-r--r--GitAnnexShell.hs33
-rw-r--r--Init.hs25
-rw-r--r--Limit.hs24
-rw-r--r--Locations.hs52
-rw-r--r--Logs/Group.hs9
-rw-r--r--Logs/PreferredContent.hs56
-rw-r--r--Logs/Remote.hs2
-rw-r--r--Logs/Transfer.hs29
-rw-r--r--Logs/Trust.hs2
-rw-r--r--Logs/Unused.hs2
-rw-r--r--Makefile2
-rw-r--r--Messages.hs11
-rw-r--r--Messages/JSON.hs5
-rw-r--r--Meters.hs40
-rw-r--r--Option.hs2
-rw-r--r--Remote.hs7
-rw-r--r--Remote/Bup.hs1
-rw-r--r--Remote/Directory.hs17
-rw-r--r--Remote/Git.hs13
-rw-r--r--Remote/Glacier.hs2
-rw-r--r--Remote/Helper/Chunked.hs2
-rw-r--r--Remote/Helper/Encryptable.hs5
-rw-r--r--Remote/Hook.hs1
-rw-r--r--Remote/Rsync.hs3
-rw-r--r--Remote/S3.hs2
-rw-r--r--Remote/Web.hs1
-rw-r--r--Remote/WebDAV.hs2
-rw-r--r--Seek.hs2
-rw-r--r--Test.hs6
-rw-r--r--Types.hs4
-rw-r--r--Types/Command.hs21
-rw-r--r--Types/Crypto.hs49
-rw-r--r--Types/GitConfig.hs12
-rw-r--r--Types/Meters.hs12
-rw-r--r--Types/Remote.hs2
-rw-r--r--Types/StandardGroups.hs28
-rw-r--r--Upgrade/V1.hs2
-rw-r--r--Usage.hs66
-rw-r--r--Utility/Metered.hs116
-rw-r--r--Utility/NotificationBroadcaster.hs17
-rw-r--r--Utility/Observed.hs43
-rw-r--r--Utility/Rsync.hs33
-rw-r--r--Utility/SafeCommand.hs10
-rw-r--r--debian/changelog37
-rw-r--r--debian/control1
-rwxr-xr-xdebian/rules3
-rw-r--r--doc/assistant.mdwn26
-rw-r--r--doc/assistant/.release_notes.mdwn.swpbin20480 -> 0 bytes
-rw-r--r--doc/assistant/deleterepository.pngbin0 -> 22780 bytes
-rw-r--r--doc/assistant/local_pairing_walkthrough.mdwn (renamed from doc/assistant/pairing_walkthrough.mdwn)0
-rw-r--r--doc/assistant/local_pairing_walkthrough/addrepository.png (renamed from doc/assistant/pairing_walkthrough/addrepository.png)bin2259 -> 2259 bytes
-rw-r--r--doc/assistant/local_pairing_walkthrough/pairing.png (renamed from doc/assistant/pairing_walkthrough/pairing.png)bin6771 -> 6771 bytes
-rw-r--r--doc/assistant/local_pairing_walkthrough/pairrequest.png (renamed from doc/assistant/pairing_walkthrough/pairrequest.png)bin5383 -> 5383 bytes
-rw-r--r--doc/assistant/local_pairing_walkthrough/secret.png (renamed from doc/assistant/pairing_walkthrough/secret.png)bin5132 -> 5132 bytes
-rw-r--r--doc/assistant/local_pairing_walkthrough/secretempty.png (renamed from doc/assistant/pairing_walkthrough/secretempty.png)bin9575 -> 9575 bytes
-rw-r--r--doc/assistant/quickstart.mdwn15
-rw-r--r--doc/assistant/release_notes.mdwn10
-rw-r--r--doc/assistant/remote_sharing_walkthrough.mdwn12
-rw-r--r--doc/assistant/share_with_a_friend_walkthrough.mdwn2
-rw-r--r--doc/assistant/thanks.mdwn3
-rw-r--r--doc/bugs/Creating_an_encrypted_S3_does_not_check_for_presence_of_GPG.mdwn2
-rw-r--r--doc/bugs/Detection_assumes_that_shell_is_bash.mdwn4
-rw-r--r--doc/bugs/No_progress_bars_with_S3.mdwn5
-rw-r--r--doc/bugs/Segfaults_on_Fedora_18_with_SELinux_enabled.mdwn65
-rw-r--r--doc/bugs/The_webapp_doesn__39__t_allow_deleting_repositories.mdwn10
-rw-r--r--doc/bugs/WEBDAV_443.mdwn3
-rw-r--r--doc/bugs/allows_repository_with_the_same_name_twice.mdwn23
-rw-r--r--doc/bugs/git-annex_add_should_repack_as_it_goes.mdwn24
-rw-r--r--doc/bugs/host_with_rysnc_installed__44___not_recognized.mdwn4
-rw-r--r--doc/bugs/ssh_connection_caching_broken_on_NTFS.mdwn3
-rw-r--r--doc/coding_style.mdwn2
-rw-r--r--doc/design/assistant.mdwn12
-rw-r--r--doc/design/assistant/OSX.mdwn8
-rw-r--r--doc/design/assistant/android.mdwn4
-rw-r--r--doc/design/assistant/blog/day_222__back.mdwn16
-rw-r--r--doc/design/assistant/blog/day_223__progress_revisited.mdwn24
-rw-r--r--doc/design/assistant/blog/day_224__annex.largefiles.mdwn23
-rw-r--r--doc/design/assistant/blog/day_225__back_from_the_dead.mdwn47
-rw-r--r--doc/design/assistant/blog/day_226__poll_results.mdwn28
-rw-r--r--doc/design/assistant/blog/day_227__bigfixing_all_day_today.mdwn21
-rw-r--r--doc/design/assistant/blog/day_228__more_work_on_repository_removals.mdwn27
-rw-r--r--doc/design/assistant/blog/day_229__rainy_day_bugfixes.mdwn17
-rw-r--r--doc/design/assistant/encrypted_git_remotes.mdwn21
-rw-r--r--doc/design/assistant/polls/goals_for_April.mdwn17
-rw-r--r--doc/design/assistant/rate_limiting.mdwn57
-rw-r--r--doc/design/assistant/syncing.mdwn5
-rw-r--r--doc/design/encryption.mdwn9
-rw-r--r--doc/encryption.mdwn7
-rw-r--r--doc/forum/Howto_remove_unused_files.mdwn31
-rw-r--r--doc/forum/Stupid_mistake:_recoverable__63__.mdwn31
-rw-r--r--doc/forum/Will_git-annex_solve_my_problem__63__.mdwn7
-rw-r--r--doc/git-annex.mdwn50
-rw-r--r--doc/install/Fedora.mdwn16
-rw-r--r--doc/install/Linux_standalone.mdwn4
-rw-r--r--doc/install/OSX/comment_15_336e0acb00e84943715e69917643a69e._comment35
-rw-r--r--doc/internals.mdwn5
-rw-r--r--doc/internals/hashing.mdwn30
-rw-r--r--doc/news/version_3.20130207.mdwn18
-rw-r--r--doc/news/version_4.20130405.mdwn34
-rw-r--r--doc/preferred_content.mdwn27
-rw-r--r--doc/special_remotes.mdwn1
-rw-r--r--doc/special_remotes/bup/comment_6_5942333cde09fd98e26c4f1d389cb76f._comment10
-rw-r--r--doc/special_remotes/bup/comment_7_cb1a0d3076e9d06e7a24204478f6fa98._comment10
-rw-r--r--doc/special_remotes/xmpp.mdwn24
-rw-r--r--doc/tips/replacing_Sparkleshare_or_dvcs-autosync_with_the_assistant.mdwn41
-rw-r--r--doc/todo/stream_feature__63__.mdwn23
-rw-r--r--doc/videos/git-annex_assistant_archiving.mdwn2
-rw-r--r--doc/videos/git-annex_assistant_introduction.mdwn2
-rw-r--r--doc/videos/git-annex_assistant_remote_sharing.mdwn6
-rw-r--r--git-annex.146
-rw-r--r--git-annex.cabal2
-rw-r--r--templates/configurators/delete/currentrepository.hamlet34
-rw-r--r--templates/configurators/delete/finished.hamlet14
-rw-r--r--templates/configurators/delete/start.hamlet11
-rw-r--r--templates/configurators/editrepository.hamlet9
-rw-r--r--templates/controlmenu.hamlet4
-rw-r--r--templates/documentation/repogroup.hamlet2
-rw-r--r--templates/repolist.hamlet29
231 files changed, 2765 insertions, 1043 deletions
diff --git a/Annex.hs b/Annex.hs
index 117bd28..58040a2 100644
--- a/Annex.hs
+++ b/Annex.hs
@@ -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
diff --git a/Backend.hs b/Backend.hs
index 6bbf3f7..2ee14ac 100644
--- a/Backend.hs
+++ b/Backend.hs
@@ -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 ++
diff --git a/CHANGELOG b/CHANGELOG
index 51d17c5..46f1b4d 100644
--- a/CHANGELOG
+++ b/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/CmdLine.hs b/CmdLine.hs
index 0b15521..63d36c7 100644
--- a/CmdLine.hs
+++ b/CmdLine.hs
@@ -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).
diff --git a/Command.hs b/Command.hs
index 8225f7b..0612610 100644
--- a/Command.hs
+++ b/Command.hs
@@ -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
diff --git a/Creds.hs b/Creds.hs
index ee0a673..4c68966 100644
--- a/Creds.hs
+++ b/Creds.hs
@@ -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)
diff --git a/Crypto.hs b/Crypto.hs
index 2777a9a..be326bf 100644
--- a/Crypto.hs
+++ b/Crypto.hs
@@ -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"
diff --git a/Init.hs b/Init.hs
index 358a54e..62b1228 100644
--- a/Init.hs
+++ b/Init.hs
@@ -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)
diff --git a/Limit.hs b/Limit.hs
index d7f82eb..9ce9d59 100644
--- a/Limit.hs
+++ b/Limit.hs
@@ -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
)
diff --git a/Makefile b/Makefile
index 68d2aa3..d0e6588 100644
--- a/Makefile
+++ b/Makefile
@@ -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
diff --git a/Option.hs b/Option.hs
index 78fc434..d59af43 100644
--- a/Option.hs
+++ b/Option.hs
@@ -1,4 +1,4 @@
-{- git-annex command-line options
+{- common command-line options
-
- Copyright 2010-2011 Joey Hess <joey@kitenet.net>
-
diff --git a/Remote.hs b/Remote.hs
index 01d6da3..27e69a5 100644
--- a/Remote.hs
+++ b/Remote.hs
@@ -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
diff --git a/Seek.hs b/Seek.hs
index 6f87e8e..70f5a90 100644
--- a/Seek.hs
+++ b/Seek.hs
@@ -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
diff --git a/Test.hs b/Test.hs
index a383a0a..56c7057 100644
--- a/Test.hs
+++ b/Test.hs
@@ -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
diff --git a/Types.hs b/Types.hs
index d19ac3d..ea0fa6b 100644
--- a/Types.hs
+++ b/Types.hs
@@ -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]
diff --git a/Usage.hs b/Usage.hs
index fc62bf5..a9c8fa7 100644
--- a/Usage.hs
+++ b/Usage.hs
@@ -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
deleted file mode 100644
index eed4092..0000000
--- a/doc/assistant/.release_notes.mdwn.swp
+++ /dev/null
Binary files differ
diff --git a/doc/assistant/deleterepository.png b/doc/assistant/deleterepository.png
new file mode 100644
index 0000000..20db674
--- /dev/null
+++ b/doc/assistant/deleterepository.png
Binary files differ
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
index b82efdb..b82efdb 100644
--- a/doc/assistant/pairing_walkthrough/addrepository.png
+++ b/doc/assistant/local_pairing_walkthrough/addrepository.png
Binary files differ
diff --git a/doc/assistant/pairing_walkthrough/pairing.png b/doc/assistant/local_pairing_walkthrough/pairing.png
index dfbbf06..dfbbf06 100644
--- a/doc/assistant/pairing_walkthrough/pairing.png
+++ b/doc/assistant/local_pairing_walkthrough/pairing.png
Binary files differ
diff --git a/doc/assistant/pairing_walkthrough/pairrequest.png b/doc/assistant/local_pairing_walkthrough/pairrequest.png
index 8d3f603..8d3f603 100644
--- a/doc/assistant/pairing_walkthrough/pairrequest.png
+++ b/doc/assistant/local_pairing_walkthrough/pairrequest.png
Binary files differ
diff --git a/doc/assistant/pairing_walkthrough/secret.png b/doc/assistant/local_pairing_walkthrough/secret.png
index 1eb8051..1eb8051 100644
--- a/doc/assistant/pairing_walkthrough/secret.png
+++ b/doc/assistant/local_pairing_walkthrough/secret.png
Binary files differ
diff --git a/doc/assistant/pairing_walkthrough/secretempty.png b/doc/assistant/local_pairing_walkthrough/secretempty.png
index 4918787..4918787 100644
--- a/doc/assistant/pairing_walkthrough/secretempty.png
+++ b/doc/assistant/local_pairing_walkthrough/secretempty.png
Binary files differ
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>
- &nbsp; Sync your files with another drive, device, or #
+ &nbsp; Sync your files with another device, or #
share with a friend.