diff --git a/Annex/Content.hs b/Annex/Content.hs --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -242,6 +242,7 @@ storedirect' [] = storeobject =<< calcRepo (gitAnnexLocation key) storedirect' (dest:fs) = do + thawContentDir =<< calcRepo (gitAnnexLocation key) updateInodeCache key src thawContent src replaceFile dest $ liftIO . moveFile src @@ -353,12 +354,12 @@ removeAnnex key = withObjectLoc key remove removedirect where remove file = do - unlessM crippledFileSystem $ - liftIO $ allowWrite $ parentDir file + thawContentDir file liftIO $ nukeFile file removeInodeCache key cleanObjectLoc key removedirect fs = do + thawContentDir =<< calcRepo (gitAnnexLocation key) cache <- recordedInodeCache key removeInodeCache key mapM_ (resetfile cache) fs @@ -374,8 +375,7 @@ fromAnnex :: Key -> FilePath -> Annex () fromAnnex key dest = do file <- calcRepo $ gitAnnexLocation key - unlessM crippledFileSystem $ - liftIO $ allowWrite $ parentDir file + thawContentDir file thawContent file liftIO $ moveFile file dest cleanObjectLoc key @@ -388,8 +388,7 @@ bad <- fromRepo gitAnnexBadDir let dest = bad takeFileName src createAnnexDirectory (parentDir dest) - unlessM crippledFileSystem $ - liftIO $ allowWrite (parentDir src) + thawContentDir src liftIO $ moveFile src dest cleanObjectLoc key logStatus key InfoMissing diff --git a/Annex/Direct.hs b/Annex/Direct.hs --- a/Annex/Direct.hs +++ b/Annex/Direct.hs @@ -25,6 +25,7 @@ import Annex.Link import Utility.InodeCache import Utility.CopyFile +import Annex.Perms {- Uses git ls-files to find files that need to be committed, and stages - them into the index. Returns True if some changes were staged. -} @@ -43,10 +44,15 @@ - efficiently as we can, by getting any key that's associated - with it in git, as well as its stat info. -} go (file, Just sha) = do - mkey <- catKey sha + shakey <- catKey sha mstat <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus file - case (mkey, mstat, toInodeCache =<< mstat) of - (Just key, _, Just cache) -> do + filekey <- isAnnexLink file + case (shakey, filekey, mstat, toInodeCache =<< mstat) of + (_, Just key, _, _) + | shakey == filekey -> noop + {- A changed symlink. -} + | otherwise -> stageannexlink file key + (Just key, _, _, Just cache) -> do {- All direct mode files will show as - modified, so compare the cache to see if - it really was. -} @@ -55,9 +61,9 @@ [] -> modifiedannexed file key cache _ -> unlessM (elemInodeCaches cache oldcache) $ modifiedannexed file key cache - (Just key, Nothing, _) -> deletedannexed file key - (Nothing, Nothing, _) -> deletegit file - (_, Just _, _) -> addgit file + (Just key, _, Nothing, _) -> deletedannexed file key + (Nothing, _, Nothing, _) -> deletegit file + (_, _, Just _, _) -> addgit file go _ = noop modifiedannexed file oldkey cache = do @@ -68,6 +74,11 @@ void $ removeAssociatedFile key file deletegit file + stageannexlink file key = do + l <- inRepo $ gitAnnexLink file key + stageSymlink file =<< hashSymlink l + void $ addAssociatedFile key file + addgit file = Annex.Queue.addCommand "add" [Param "-f"] [file] deletegit file = Annex.Queue.addCommand "rm" [Param "-f"] [file] @@ -177,6 +188,7 @@ [] -> ifM (liftIO $ doesFileExist loc) ( return $ Just $ do {- Move content from annex to direct file. -} + thawContentDir loc updateInodeCache k loc thawContent loc replaceFile f $ liftIO . moveFile loc diff --git a/Annex/Environment.hs b/Annex/Environment.hs new file mode 100644 --- /dev/null +++ b/Annex/Environment.hs @@ -0,0 +1,31 @@ +{- git-annex environment + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Annex.Environment where + +import Common.Annex +import Utility.UserInfo +import qualified Git.Config + +import System.Posix.Env + +{- Checks that the system's environment allows git to function. + - Git requires a GECOS username, or suitable git configuration, or + - environment variables. -} +checkEnvironment :: Annex () +checkEnvironment = do + gitusername <- fromRepo $ Git.Config.getMaybe "user.name" + when (gitusername == Nothing || gitusername == Just "") $ + liftIO checkEnvironmentIO + +checkEnvironmentIO :: IO () +checkEnvironmentIO = do + whenM (null <$> myUserGecos) $ do + username <- myUserName + -- existing environment is not overwritten + setEnv "GIT_AUTHOR_NAME" username False + setEnv "GIT_COMMITTER_NAME" username False diff --git a/Annex/FileMatcher.hs b/Annex/FileMatcher.hs --- a/Annex/FileMatcher.hs +++ b/Annex/FileMatcher.hs @@ -14,9 +14,11 @@ import Utility.Matcher import Types.Group import Logs.Group +import Logs.Remote import Annex.UUID import qualified Annex import Git.FilePath +import Types.Remote (RemoteConfig) import Data.Either import qualified Data.Set as S @@ -45,10 +47,22 @@ ([], vs) -> Right $ generate vs (es, _) -> Left $ unwords $ map ("Parse failure: " ++) es -parseToken :: MkLimit -> GroupMap -> String -> Either String (Token MatchFiles) -parseToken checkpresent groupmap t +exprParser :: GroupMap -> M.Map UUID RemoteConfig -> Maybe UUID -> String -> [Either String (Token MatchFiles)] +exprParser groupmap configmap mu expr = + map parse $ tokenizeMatcher expr + where + parse = parseToken + (limitPresent mu) + (limitInDir preferreddir) + groupmap + preferreddir = fromMaybe "public" $ + M.lookup "preferreddir" =<< (`M.lookup` configmap) =<< mu + +parseToken :: MkLimit -> MkLimit -> GroupMap -> String -> Either String (Token MatchFiles) +parseToken checkpresent checkpreferreddir groupmap t | t `elem` tokens = Right $ token t | t == "present" = use checkpresent + | t == "inpreferreddir" = use checkpreferreddir | otherwise = maybe (Left $ "near " ++ show t) use $ M.lookup k $ M.fromList [ ("include", limitInclude) @@ -78,9 +92,9 @@ where go Nothing = return matchAll go (Just expr) = do - m <- groupMap + gm <- groupMap + rc <- readRemoteLog u <- getUUID - either badexpr return $ parsedToMatcher $ - map (parseToken (limitPresent $ Just u) m) - (tokenizeMatcher expr) + either badexpr return $ + parsedToMatcher $ exprParser gm rc (Just u) expr badexpr e = error $ "bad annex.largefiles configuration: " ++ e diff --git a/Annex/Perms.hs b/Annex/Perms.hs --- a/Annex/Perms.hs +++ b/Annex/Perms.hs @@ -12,6 +12,7 @@ noUmask, createContentDir, freezeContentDir, + thawContentDir, ) where import Common.Annex @@ -86,6 +87,10 @@ go GroupShared = groupWriteRead dir go AllShared = groupWriteRead dir go _ = preventWrite dir + +thawContentDir :: FilePath -> Annex () +thawContentDir file = unlessM crippledFileSystem $ + liftIO $ allowWrite $ parentDir file {- Makes the directory tree to store an annexed file's content, - with appropriate permissions on each level. -} diff --git a/Annex/TaggedPush.hs b/Annex/TaggedPush.hs --- a/Annex/TaggedPush.hs +++ b/Annex/TaggedPush.hs @@ -30,7 +30,7 @@ - refs, per git-check-ref-format. -} toTaggedBranch :: UUID -> Maybe String -> Git.Branch -> Git.Branch -toTaggedBranch u info b = Git.Ref $ join "/" $ catMaybes +toTaggedBranch u info b = Git.Ref $ intercalate "/" $ catMaybes [ Just "refs/synced" , Just $ fromUUID u , toB64 <$> info diff --git a/Assistant.hs b/Assistant.hs --- a/Assistant.hs +++ b/Assistant.hs @@ -154,7 +154,6 @@ #warning Building without the webapp. You probably need to install Yesod.. import Assistant.Types.UrlRenderer #endif -import Assistant.Environment import qualified Utility.Daemon import Utility.LogFile import Utility.ThreadScheduler @@ -198,8 +197,6 @@ | otherwise = "watch" start daemonize webappwaiter = withThreadState $ \st -> do checkCanWatch - when assistant - checkEnvironment dstatus <- startDaemonStatus logfile <- fromRepo gitAnnexLogFile liftIO $ debugM desc $ "logging to " ++ logfile diff --git a/Assistant/Alert.hs b/Assistant/Alert.hs --- a/Assistant/Alert.hs +++ b/Assistant/Alert.hs @@ -66,7 +66,7 @@ , alertClosable = True , alertPriority = High , alertIcon = Just ErrorIcon - , alertCombiner = Just $ dataCombiner (++) + , alertCombiner = Just $ dataCombiner $ \_old new -> new , alertName = Just $ WarningAlert name , alertButton = Nothing } @@ -233,7 +233,7 @@ render fs = tenseWords $ msg : fs combiner new old = take 10 $ new ++ old -addFileAlert :: FilePath -> Alert +addFileAlert :: String -> Alert addFileAlert = fileAlert (Tensed "Adding" "Added") {- This is only used as a success alert after a transfer, not during it. -} diff --git a/Assistant/Changes.hs b/Assistant/Changes.hs --- a/Assistant/Changes.hs +++ b/Assistant/Changes.hs @@ -1,6 +1,6 @@ {- git-annex assistant change tracking - - - Copyright 2012 Joey Hess + - Copyright 2012-2013 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -9,7 +9,7 @@ import Assistant.Common import Assistant.Types.Changes -import Utility.TSet +import Utility.TList import Data.Time.Clock import Control.Concurrent.STM @@ -28,17 +28,20 @@ {- Gets all unhandled changes. - Blocks until at least one change is made. -} getChanges :: Assistant [Change] -getChanges = (atomically . getTSet) <<~ changeChan +getChanges = (atomically . getTList) <<~ changePool {- Gets all unhandled changes, without blocking. -} getAnyChanges :: Assistant [Change] -getAnyChanges = (atomically . readTSet) <<~ changeChan +getAnyChanges = (atomically . takeTList) <<~ changePool -{- Puts unhandled changes back into the channel. +{- Puts unhandled changes back into the pool. - Note: Original order is not preserved. -} refillChanges :: [Change] -> Assistant () -refillChanges cs = (atomically . flip putTSet cs) <<~ changeChan +refillChanges cs = (atomically . flip appendTList cs) <<~ changePool -{- Records a change in the channel. -} +{- Records a change to the pool. -} recordChange :: Change -> Assistant () -recordChange c = (atomically . flip putTSet1 c) <<~ changeChan +recordChange c = (atomically . flip snocTList c) <<~ changePool + +recordChanges :: [Change] -> Assistant () +recordChanges = refillChanges diff --git a/Assistant/Commits.hs b/Assistant/Commits.hs --- a/Assistant/Commits.hs +++ b/Assistant/Commits.hs @@ -9,20 +9,15 @@ import Assistant.Common import Assistant.Types.Commits -import Utility.TSet +import Utility.TList import Control.Concurrent.STM {- Gets all unhandled commits. - Blocks until at least one commit is made. -} getCommits :: Assistant [Commit] -getCommits = (atomically . getTSet) <<~ commitChan - -{- Puts unhandled commits back into the channel. - - Note: Original order is not preserved. -} -refillCommits :: [Commit] -> Assistant () -refillCommits cs = (atomically . flip putTSet cs) <<~ commitChan +getCommits = (atomically . getTList) <<~ commitChan {- Records a commit in the channel. -} recordCommit :: Assistant () -recordCommit = (atomically . flip putTSet1 Commit) <<~ commitChan +recordCommit = (atomically . flip consTList Commit) <<~ commitChan diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs --- a/Assistant/DaemonStatus.hs +++ b/Assistant/DaemonStatus.hs @@ -48,18 +48,19 @@ calcSyncRemotes :: Annex (DaemonStatus -> DaemonStatus) calcSyncRemotes = do rs <- filter (remoteAnnexSync . Remote.gitconfig) . - concat . Remote.byCost <$> Remote.enabledRemoteList + concat . Remote.byCost <$> Remote.remoteList alive <- trustExclude DeadTrusted (map Remote.uuid rs) let good r = Remote.uuid r `elem` alive let syncable = filter good rs - let nonxmpp = filter (not . isXMPPRemote) syncable + let syncdata = filter (not . remoteAnnexIgnore . Remote.gitconfig) $ + filter (not . isXMPPRemote) syncable return $ \dstatus -> dstatus { syncRemotes = syncable , syncGitRemotes = filter (not . Remote.specialRemote) syncable - , syncDataRemotes = nonxmpp - , syncingToCloudRemote = any iscloud nonxmpp + , syncDataRemotes = syncdata + , syncingToCloudRemote = any iscloud syncdata } where iscloud r = not (Remote.readonly r) && Remote.globallyAvailable r diff --git a/Assistant/DeleteRemote.hs b/Assistant/DeleteRemote.hs --- a/Assistant/DeleteRemote.hs +++ b/Assistant/DeleteRemote.hs @@ -18,6 +18,7 @@ import qualified Remote import Remote.List import qualified Git.Command +import qualified Git.Version import Logs.Trust import qualified Annex @@ -36,7 +37,11 @@ liftAnnex $ do inRepo $ Git.Command.run [ Param "remote" - , Param "remove" + -- name of this subcommand changed + , Param $ + if Git.Version.older "1.8.0" + then "rm" + else "remove" , Param (Remote.name remote) ] void $ remoteListRefresh diff --git a/Assistant/Environment.hs b/Assistant/Environment.hs deleted file mode 100644 --- a/Assistant/Environment.hs +++ /dev/null @@ -1,26 +0,0 @@ -{- git-annex assistant environment - - - - Copyright 2012 Joey Hess - - - - Licensed under the GNU GPL version 3 or higher. - -} - -module Assistant.Environment where - -import Assistant.Common -import Utility.UserInfo -import qualified Git.Config - -import System.Posix.Env - -{- Checks that the system's environment allows git to function. - - Git requires a GECOS username, or suitable git configuration, or - - environment variables. -} -checkEnvironment :: Annex () -checkEnvironment = do - username <- liftIO myUserName - gecos <- liftIO myUserGecos - gitusername <- fromRepo $ Git.Config.getMaybe "user.name" - when (null gecos && (gitusername == Nothing || gitusername == Just "")) $ - -- existing environment is not overwritten - liftIO $ setEnv "GIT_AUTHOR_NAME" username False diff --git a/Assistant/Install.hs b/Assistant/Install.hs --- a/Assistant/Install.hs +++ b/Assistant/Install.hs @@ -11,8 +11,9 @@ import Assistant.Common import Assistant.Install.AutoStart +import Assistant.Install.Menu import Assistant.Ssh -import Locations.UserConfig +import Config.Files import Utility.FileMode import Utility.Shell import Utility.TempFile @@ -49,6 +50,8 @@ #ifdef darwin_HOST_OS autostartfile <- userAutoStart osxAutoStartLabel #else + installMenu program + =<< desktopMenuFilePath "git-annex" <$> userDataDir autostartfile <- autoStartPath "git-annex" <$> userConfigDir #endif installAutoStart program autostartfile diff --git a/Assistant/Install/Menu.hs b/Assistant/Install/Menu.hs new file mode 100644 --- /dev/null +++ b/Assistant/Install/Menu.hs @@ -0,0 +1,30 @@ +{- Assistant menu installation. + - + - Copyright 2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Assistant.Install.Menu where + +import Utility.FreeDesktop + +installMenu :: FilePath -> FilePath -> IO () +installMenu command file = +#ifdef darwin_HOST_OS + return () +#else + writeDesktopMenuFile (fdoDesktopMenu command) file +#endif + +{- The command can be either just "git-annex", or the full path to use + - to run it. -} +fdoDesktopMenu :: FilePath -> DesktopEntry +fdoDesktopMenu command = genDesktopEntry + "Git Annex" + "Track and sync the files in your Git Annex" + False + (command ++ " webapp") + ["Network", "FileTransfer"] diff --git a/Assistant/Install/Menu.o b/Assistant/Install/Menu.o new file mode 100644 Binary files /dev/null and b/Assistant/Install/Menu.o differ diff --git a/Assistant/MakeRemote.hs b/Assistant/MakeRemote.hs --- a/Assistant/MakeRemote.hs +++ b/Assistant/MakeRemote.hs @@ -1,6 +1,6 @@ {- git-annex assistant remote creation utilities - - - Copyright 2012 Joey Hess + - Copyright 2012, 2013 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -22,6 +22,7 @@ import Git.Remote import Config import Config.Cost +import Creds import qualified Data.Text as T import qualified Data.Map as M @@ -69,17 +70,22 @@ , ("type", "rsync") ] -{- Inits a special remote. Currently, only 'weak' ciphers can be - - generated from the assistant, because otherwise GnuPG may block once - - the entropy pool is drained, and as of now there's no way to tell the - - user to perform IO actions to refill the pool. -} +{- Inits a new special remote, or enables an existing one. + - + - Currently, only 'weak' ciphers can be generated from the assistant, + - because otherwise GnuPG may block once the entropy pool is drained, + - and as of now there's no way to tell the user to perform IO actions + - to refill the pool. -} makeSpecialRemote :: String -> RemoteType -> R.RemoteConfig -> Annex () -makeSpecialRemote name remotetype config = do - (u, c) <- Command.InitRemote.findByName name - c' <- R.setup remotetype u $ - M.insert "highRandomQuality" "false" $ M.union config c - describeUUID u name - configSet u c' +makeSpecialRemote name remotetype config = + go =<< Command.InitRemote.findExisting name + where + go Nothing = go =<< Just <$> Command.InitRemote.generateNew name + go (Just (u, c)) = do + c' <- R.setup remotetype u $ + M.insert "highRandomQuality" "false" $ M.union config c + describeUUID u name + configSet u c' {- Returns the name of the git remote it created. If there's already a - remote at the location, returns its name. -} @@ -120,3 +126,25 @@ | n == 0 = legalbasename | otherwise = legalbasename ++ show n legalbasename = makeLegalName basename + +{- Finds a CredPair belonging to any Remote that is of a given type + - and matches some other criteria. + - + - This can be used as a default when another repository is being set up + - using the same service. + - + - A function must be provided that returns the CredPairStorage + - to use for a particular Remote's uuid. + -} +previouslyUsedCredPair + :: (UUID -> CredPairStorage) + -> RemoteType + -> (Remote -> Bool) + -> Annex (Maybe CredPair) +previouslyUsedCredPair getstorage remotetype criteria = + getM fromstorage =<< filter criteria . filter sametype <$> remoteList + where + sametype r = R.typename (R.remotetype r) == R.typename remotetype + fromstorage r = do + let storage = getstorage (R.uuid r) + getRemoteCredPair (R.config r) storage diff --git a/Assistant/Monad.hs b/Assistant/Monad.hs --- a/Assistant/Monad.hs +++ b/Assistant/Monad.hs @@ -66,7 +66,7 @@ , transferrerPool :: TransferrerPool , failedPushMap :: FailedPushMap , commitChan :: CommitChan - , changeChan :: ChangeChan + , changePool :: ChangePool , branchChangeHandle :: BranchChangeHandle , buddyList :: BuddyList , netMessager :: NetMessager @@ -83,7 +83,7 @@ <*> newTransferrerPool <*> newFailedPushMap <*> newCommitChan - <*> newChangeChan + <*> newChangePool <*> newBranchChangeHandle <*> newBuddyList <*> newNetMessager diff --git a/Assistant/Ssh.hs b/Assistant/Ssh.hs --- a/Assistant/Ssh.hs +++ b/Assistant/Ssh.hs @@ -105,11 +105,11 @@ - present. -} addAuthorizedKeysCommand :: Bool -> FilePath -> SshPubKey -> String -addAuthorizedKeysCommand rsynconly dir pubkey = join "&&" +addAuthorizedKeysCommand rsynconly dir pubkey = intercalate "&&" [ "mkdir -p ~/.ssh" - , join "; " + , intercalate "; " [ "if [ ! -e " ++ wrapper ++ " ]" - , "then (" ++ join ";" (map echoval script) ++ ") > " ++ wrapper + , "then (" ++ intercalate ";" (map echoval script) ++ ") > " ++ wrapper , "fi" ] , "chmod 700 " ++ wrapper @@ -217,7 +217,7 @@ mangleSshHostName sshdata = "git-annex-" ++ T.unpack (sshHostName sshdata) ++ "-" ++ filter safe extra where - extra = join "_" $ map T.unpack $ catMaybes + extra = intercalate "_" $ map T.unpack $ catMaybes [ sshUserName sshdata , Just $ sshDirectory sshdata ] @@ -229,7 +229,7 @@ {- Extracts the real hostname from a mangled ssh hostname. -} unMangleSshHostName :: String -> String unMangleSshHostName h = case split "-" h of - ("git":"annex":rest) -> join "-" (beginning rest) + ("git":"annex":rest) -> intercalate "-" (beginning rest) _ -> h {- Does ssh have known_hosts data for a hostname? -} diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs --- a/Assistant/Sync.hs +++ b/Assistant/Sync.hs @@ -68,7 +68,9 @@ go = do (failed, diverged) <- sync =<< liftAnnex (inRepo Git.Branch.current) - addScanRemotes diverged nonxmppremotes + addScanRemotes diverged $ + filter (not . remoteAnnexIgnore . Remote.gitconfig) + nonxmppremotes return failed {- Updates the local sync branch, then pushes it to all remotes, in @@ -111,7 +113,7 @@ let (xmppremotes, normalremotes) = partition isXMPPRemote remotes ret <- go True branch g u normalremotes forM_ xmppremotes $ \r -> - sendNetMessage $ Pushing (getXMPPClientID r) CanPush + sendNetMessage $ Pushing (getXMPPClientID r) (CanPush u) return ret where go _ Nothing _ _ _ = return [] -- no branch, so nothing to do @@ -200,8 +202,9 @@ haddiverged <- liftAnnex Annex.Branch.forceUpdate forM_ normalremotes $ \r -> liftAnnex $ Command.Sync.mergeRemote r currentbranch + u <- liftAnnex getUUID forM_ xmppremotes $ \r -> - sendNetMessage $ Pushing (getXMPPClientID r) PushRequest + sendNetMessage $ Pushing (getXMPPClientID r) (PushRequest u) return (catMaybes failed, haddiverged) {- Start syncing a remote, using a background thread. -} diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs --- a/Assistant/Threads/Committer.hs +++ b/Assistant/Threads/Committer.hs @@ -52,7 +52,7 @@ =<< annexDelayAdd <$> Annex.getGitConfig waitChangeTime $ \(changes, time) -> do readychanges <- handleAdds delayadd changes - if shouldCommit time readychanges + if shouldCommit time (length readychanges) readychanges then do debug [ "committing" @@ -62,8 +62,12 @@ void $ alertWhile commitAlert $ liftAnnex commitStaged recordCommit + let numchanges = length readychanges mapM_ checkChangeContent readychanges - else refill readychanges + return numchanges + else do + refill readychanges + return 0 refill :: [Change] -> Assistant () refill [] = noop @@ -72,21 +76,33 @@ refillChanges cs {- Wait for one or more changes to arrive to be committed. -} -waitChangeTime :: (([Change], UTCTime) -> Assistant ()) -> Assistant () -waitChangeTime a = runEvery (Seconds 1) <~> do - -- We already waited one second as a simple rate limiter. - -- Next, wait until at least one change is available for - -- processing. - changes <- getChanges - -- See if now's a good time to commit. - now <- liftIO getCurrentTime - case (shouldCommit now changes, possiblyrename changes) of - (True, False) -> a (changes, now) - (True, True) -> do - morechanges <- getrelatedchanges changes - a (changes ++ morechanges, now) - _ -> refill changes +waitChangeTime :: (([Change], UTCTime) -> Assistant Int) -> Assistant () +waitChangeTime a = go [] 0 where + go unhandled lastcommitsize = do + -- Wait one one second as a simple rate limiter. + liftIO $ threadDelaySeconds (Seconds 1) + -- Now, wait until at least one change is available for + -- processing. + cs <- getChanges + let changes = unhandled ++ cs + let len = length changes + -- See if now's a good time to commit. + now <- liftIO getCurrentTime + case (lastcommitsize >= maxCommitSize, shouldCommit now len changes, possiblyrename changes) of + (True, True, _) + | len > maxCommitSize -> + go [] =<< a (changes, now) + | otherwise -> aftermaxcommit changes + (_, True, False) -> + go [] =<< a (changes, now) + (_, True, True) -> do + morechanges <- getrelatedchanges changes + go [] =<< a (changes ++ morechanges, now) + _ -> do + refill changes + go [] lastcommitsize + {- Did we perhaps only get one of the AddChange and RmChange pair - that make up a file rename? Or some of the pairs that make up - a directory rename? @@ -116,6 +132,41 @@ then return cs else getbatchchanges (cs':cs) + {- The last commit was maximum size, so it's very likely there + - are more changes and we'd like to ensure we make another commit + - of maximum size if possible. + - + - But, it can take a while for the Watcher to wake back up + - after a commit. It can get blocked by another thread + - that is using the Annex state, such as a git-annex branch + - commit. Especially after such a large commit, this can + - take several seconds. When this happens, it defeats the + - normal commit batching, which sees some old changes the + - Watcher found while the commit was being prepared, and sees + - no recent ones, and wants to commit immediately. + - + - All that we need to do, then, is wait for the Watcher to + - wake up, and queue up one more change. + - + - However, it's also possible that we're at the end of changes for + - now. So to avoid waiting a really long time before committing + - those changes we have, poll for up to 30 seconds, and then + - commit them. + - + - Also, try to run something in Annex, to ensure we block + - longer if the Annex state is indeed blocked. + -} + aftermaxcommit oldchanges = loop (30 :: Int) + where + loop 0 = go oldchanges 0 + loop n = do + liftAnnex noop -- ensure Annex state is free + liftIO $ threadDelaySeconds (Seconds 1) + changes <- getAnyChanges + if null changes + then loop (n - 1) + else go (oldchanges ++ changes) 0 + isRmChange :: Change -> Bool isRmChange (Change { changeInfo = i }) | i == RmChange = True isRmChange _ = False @@ -131,20 +182,22 @@ humanImperceptibleDelay = threadDelay $ truncate $ humanImperceptibleInterval * fromIntegral oneSecond +maxCommitSize :: Int +maxCommitSize = 5000 + {- Decide if now is a good time to make a commit. - Note that the list of changes has an undefined order. - - Current strategy: If there have been 10 changes within the past second, - a batch activity is taking place, so wait for later. -} -shouldCommit :: UTCTime -> [Change] -> Bool -shouldCommit now changes +shouldCommit :: UTCTime -> Int -> [Change] -> Bool +shouldCommit now len changes | len == 0 = False - | len > 10000 = True -- avoid bloating queue too much + | len >= maxCommitSize = True | length recentchanges < 10 = True | otherwise = False -- batch activity where - len = length changes thissecond c = timeDelta c <= 1 recentchanges = filter thissecond changes timeDelta c = now `diffUTCTime` changeTime c @@ -157,28 +210,30 @@ case v of Left _ -> return False Right _ -> do - direct <- isDirect - let params = nomessage $ catMaybes - [ Just $ Param "--quiet" - {- In indirect mode, avoid running the - - usual git-annex pre-commit hook; - - watch does the same symlink fixing, - - and we don't want to deal with unlocked - - files in these commits. -} - , if direct then Nothing else Just $ Param "--no-verify" - ] {- Empty commits may be made if tree changes cancel - each other out, etc. Git returns nonzero on those, - so don't propigate out commit failures. -} void $ inRepo $ catchMaybeIO . - Git.Command.runQuiet (Param "commit" : params) + Git.Command.runQuiet + (Param "commit" : nomessage params) return True where + params = + [ Param "--quiet" + {- Avoid running the usual pre-commit hook; + - the Watcher does the same symlink fixing, + - and direct mode bookkeeping updating. -} + , Param "--no-verify" + ] nomessage ps - | Git.Version.older "1.7.2" = Param "-m" - : Param "autocommit" : ps - | otherwise = Param "--allow-empty-message" - : Param "-m" : Param "" : ps + | Git.Version.older "1.7.2" = + Param "-m" : Param "autocommit" : ps + | Git.Version.older "1.7.8" = + Param "--allow-empty-message" : + Param "-m" : Param "" : ps + | otherwise = + Param "--allow-empty-message" : + Param "--no-edit" : Param "-m" : Param "" : ps {- OSX needs a short delay after a file is added before locking it down, - when using a non-direct mode repository, as pasting a file seems to @@ -227,9 +282,10 @@ refillChanges postponed returnWhen (null toadd) $ do - added <- catMaybes <$> if direct - then adddirect toadd - else forM toadd add + added <- addaction toadd $ + catMaybes <$> if direct + then adddirect toadd + else forM toadd add if DirWatcher.eventsCoalesce || null added || direct then return $ added ++ otherchanges else do @@ -252,19 +308,13 @@ | otherwise = a add :: Change -> Assistant (Maybe Change) - add change@(InProcessAddChange { keySource = ks }) = do - alertWhile' (addFileAlert $ keyFilename ks) $ - liftM ret $ catchMaybeIO <~> do - sanitycheck ks $ do - key <- liftAnnex $ do - showStart "add" $ keyFilename ks - Command.Add.ingest $ Just ks - maybe failedingest (done change $ keyFilename ks) key - where - {- Add errors tend to be transient and will be automatically - - dealt with, so don't pass to the alert code. -} - ret (Just j@(Just _)) = (True, j) - ret _ = (True, Nothing) + add change@(InProcessAddChange { keySource = ks }) = + catchDefaultIO Nothing <~> do + sanitycheck ks $ do + key <- liftAnnex $ do + showStart "add" $ keyFilename ks + Command.Add.ingest $ Just ks + maybe (failedingest change) (done change $ keyFilename ks) key add _ = return Nothing {- In direct mode, avoid overhead of re-injesting a renamed @@ -302,7 +352,8 @@ mkpairs k = map (\c -> (inodeCacheToKey ct c, k)) <$> recordedInodeCache k - failedingest = do + failedingest change = do + refill [retryChange change] liftAnnex showEndFail return Nothing @@ -330,6 +381,26 @@ when (contentLocation keysource /= keyFilename keysource) $ void $ liftIO $ tryIO $ removeFile $ contentLocation keysource return Nothing + + {- Shown an alert while performing an action to add a file or + - files. When only one file is added, its name is shown + - in the alert. When it's a batch add, the number of files added + - is shown. + - + - Add errors tend to be transient and will be + - automatically dealt with, so the alert is always told + - the add succeeded. + -} + addaction [] a = a + addaction toadd a = alertWhile' (addFileAlert msg) $ + (,) + <$> pure True + <*> a + where + msg = case toadd of + (InProcessAddChange { keySource = ks }:[]) -> + keyFilename ks + _ -> show (length toadd) ++ " files" {- Files can Either be Right to be added now, - or are unsafe, and must be Left for later. diff --git a/Assistant/Threads/Merger.hs b/Assistant/Threads/Merger.hs --- a/Assistant/Threads/Merger.hs +++ b/Assistant/Threads/Merger.hs @@ -32,10 +32,11 @@ let dir = Git.localGitDir g "refs" liftIO $ createDirectoryIfMissing True dir let hook a = Just <$> asIO2 (runHandler a) - addhook <- hook onAdd + changehook <- hook onChange errhook <- hook onErr let hooks = mkWatchHooks - { addHook = addhook + { addHook = changehook + , modifyHook = changehook , errHook = errhook } void $ liftIO $ watchDir dir (const False) hooks id @@ -55,19 +56,14 @@ onErr :: Handler onErr msg = error msg -{- Called when a new branch ref is written. - - - - This relies on git's atomic method of updating branch ref files, - - which is to first write the new file to .lock, and then rename it - - over the old file. So, ignore .lock files, and the rename ensures - - the watcher sees a new file being added on each update. +{- Called when a new branch ref is written, or a branch ref is modified. - - At startup, synthetic add events fire, causing this to run, but that's - ok; it ensures that any changes pushed since the last time the assistant - ran are merged in. -} -onAdd :: Handler -onAdd file +onChange :: Handler +onChange file | ".lock" `isSuffixOf` file = noop | isAnnexBranch file = do branchChanged @@ -75,7 +71,7 @@ when diverged $ unlessM handleDesynced $ queueDeferredDownloads "retrying deferred download" Later - | "/synced/" `isInfixOf` file = do + | "/synced/" `isInfixOf` file = mergecurrent =<< liftAnnex (inRepo Git.Branch.current) | otherwise = noop where diff --git a/Assistant/Threads/MountWatcher.hs b/Assistant/Threads/MountWatcher.hs --- a/Assistant/Threads/MountWatcher.hs +++ b/Assistant/Threads/MountWatcher.hs @@ -157,7 +157,7 @@ handleMount dir = do debug ["detected mount of", dir] rs <- filter (Git.repoIsLocal . Remote.repo) <$> remotesUnder dir - reconnectRemotes True $ filter (not . remoteAnnexIgnore . Remote.gitconfig) rs + reconnectRemotes True rs {- Finds remotes located underneath the mount point. - diff --git a/Assistant/Threads/NetWatcher.hs b/Assistant/Threads/NetWatcher.hs --- a/Assistant/Threads/NetWatcher.hs +++ b/Assistant/Threads/NetWatcher.hs @@ -128,4 +128,4 @@ {- Finds network remotes. -} networkRemotes :: Assistant [Remote] networkRemotes = liftAnnex $ - filter (isNothing . Remote.localpath) <$> enabledRemoteList + filter (isNothing . Remote.localpath) <$> remoteList diff --git a/Assistant/Threads/Pusher.hs b/Assistant/Threads/Pusher.hs --- a/Assistant/Threads/Pusher.hs +++ b/Assistant/Threads/Pusher.hs @@ -9,7 +9,6 @@ import Assistant.Common import Assistant.Commits -import Assistant.Types.Commits import Assistant.Pushes import Assistant.DaemonStatus import Assistant.Sync @@ -33,13 +32,9 @@ pushThread = namedThread "Pusher" $ runEvery (Seconds 2) <~> do -- We already waited two seconds as a simple rate limiter. -- Next, wait until at least one commit has been made - commits <- getCommits + void getCommits -- Now see if now's a good time to push. - if shouldPush commits - then void $ pushToRemotes True =<< pushTargets - else do - debug ["delaying push of", show (length commits), "commits"] - refillCommits commits + void $ pushToRemotes True =<< pushTargets {- We want to avoid pushing to remotes that are marked readonly. - @@ -51,14 +46,3 @@ where candidates = filter (not . Remote.readonly) . syncGitRemotes available = maybe (return True) doesDirectoryExist . Remote.localpath - -{- Decide if now is a good time to push to remotes. - - - - Current strategy: Immediately push all commits. The commit machinery - - already determines batches of changes, so we can't easily determine - - batches better. - -} -shouldPush :: [Commit] -> Bool -shouldPush commits - | not (null commits) = True - | otherwise = False diff --git a/Assistant/Threads/Transferrer.hs b/Assistant/Threads/Transferrer.hs --- a/Assistant/Threads/Transferrer.hs +++ b/Assistant/Threads/Transferrer.hs @@ -22,7 +22,7 @@ import qualified Remote import qualified Types.Remote as Remote import qualified Git -import Locations.UserConfig +import Config.Files import Assistant.Threads.TransferWatcher import Annex.Wanted diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs --- a/Assistant/Threads/Watcher.hs +++ b/Assistant/Threads/Watcher.hs @@ -130,8 +130,7 @@ top <- liftAnnex $ fromRepo Git.repoPath (fs, cleanup) <- liftAnnex $ inRepo $ LsFiles.deleted [top] forM_ fs $ \f -> do - liftAnnex $ Annex.Queue.addUpdateIndex =<< - inRepo (Git.UpdateIndex.unstageFile f) + liftAnnex $ onDel' f maybe noop recordChange =<< madeChange f RmChange void $ liftIO $ cleanup @@ -204,9 +203,12 @@ - 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) + ( ifM (scanComplete <$> getDaemonStatus) + ( do + link <- liftAnnex $ inRepo $ gitAnnexLink file key + addLink file link (Just key) + , noChange + ) , guardSymlinkStandin (Just key) $ do debug ["changed direct", file] liftAnnex $ changedDirect key file @@ -296,11 +298,19 @@ onDel :: Handler onDel file _ = do debug ["file deleted", file] - liftAnnex $ - Annex.Queue.addUpdateIndex =<< - inRepo (Git.UpdateIndex.unstageFile file) + liftAnnex $ onDel' file madeChange file RmChange +onDel' :: FilePath -> Annex () +onDel' file = do + whenM isDirect $ do + mkey <- catKeyFile file + case mkey of + Nothing -> noop + Just key -> void $ removeAssociatedFile key file + Annex.Queue.addUpdateIndex =<< + inRepo (Git.UpdateIndex.unstageFile file) + {- A directory has been deleted, or moved, so tell git to remove anything - that was inside it from its cache. Since it could reappear at any time, - use --cached to only delete it from the index. @@ -312,13 +322,12 @@ debug ["directory deleted", dir] (fs, clean) <- liftAnnex $ inRepo $ LsFiles.deleted [dir] - liftAnnex $ forM_ fs $ \f -> Annex.Queue.addUpdateIndex =<< - inRepo (Git.UpdateIndex.unstageFile f) + liftAnnex $ mapM_ onDel' fs -- Get the events queued up as fast as possible, so the -- committer sees them all in one block. now <- liftIO getCurrentTime - forM_ fs $ \f -> recordChange $ Change now f RmChange + recordChanges $ map (\f -> Change now f RmChange) fs void $ liftIO $ clean liftAnnex $ Annex.Queue.flushWhenFull diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs --- a/Assistant/Threads/WebApp.hs +++ b/Assistant/Threads/WebApp.hs @@ -22,6 +22,7 @@ import Assistant.WebApp.Configurators.Ssh import Assistant.WebApp.Configurators.Pairing import Assistant.WebApp.Configurators.AWS +import Assistant.WebApp.Configurators.IA import Assistant.WebApp.Configurators.WebDAV import Assistant.WebApp.Configurators.XMPP import Assistant.WebApp.Configurators.Preferences @@ -37,7 +38,6 @@ import Git import Yesod -import Yesod.Static import Network.Socket (SockAddr, HostName) import Data.Text (pack, unpack) diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs --- a/Assistant/Threads/XMPPClient.hs +++ b/Assistant/Threads/XMPPClient.hs @@ -25,6 +25,7 @@ import Assistant.Pairing import Assistant.XMPP.Git import Annex.UUID +import Logs.UUID import Network.Protocol.XMPP import Control.Concurrent @@ -84,7 +85,7 @@ inAssistant $ do modifyDaemonStatus_ $ \s -> s { xmppClientID = Just $ xmppJID creds } - debug ["connected", show selfjid] + debug ["connected", logJid selfjid] xmppThread $ receivenotifications selfjid forever $ do @@ -94,7 +95,7 @@ receivenotifications selfjid = forever $ do l <- decodeStanza selfjid <$> getStanza inAssistant $ debug - ["received:", show $ map sanitizeXMPPEvent l] + ["received:", show $ map logXMPPEvent l] mapM_ (handle selfjid) l handle selfjid (PresenceMessage p) = do @@ -123,8 +124,8 @@ let msg' = readdressNetMessage msg c inAssistant $ debug [ "sending to new client:" - , show c - , show $ sanitizeNetMessage msg' + , logJid jid + , show $ logNetMessage msg' ] a <- inAssistant $ convertNetMsg msg' selfjid a @@ -139,10 +140,29 @@ | ProtocolError ReceivedStanza deriving Show -sanitizeXMPPEvent :: XMPPEvent -> XMPPEvent -sanitizeXMPPEvent (GotNetMessage m) = GotNetMessage $ sanitizeNetMessage m -sanitizeXMPPEvent v = v +logXMPPEvent :: XMPPEvent -> String +logXMPPEvent (GotNetMessage m) = logNetMessage m +logXMPPEvent (PresenceMessage p) = logPresence p +logXMPPEvent (Ignorable (ReceivedPresence p)) = "Ignorable " ++ logPresence p +logXMPPEvent v = show v +logPresence :: Presence -> String +logPresence (p@Presence { presenceFrom = Just jid }) = unwords + [ "Presence from" + , logJid jid + , show $ extractGitAnnexTag p + ] +logPresence _ = "Presence from unknown" + +logJid :: JID -> String +logJid jid = + let name = T.unpack (buddyName jid) + resource = maybe "" (T.unpack . strResource) (jidResource jid) + in take 1 name ++ show (length name) ++ "/" ++ resource + +logClient :: Client -> String +logClient (Client jid) = logJid jid + {- Decodes an XMPP stanza into one or more events. -} decodeStanza :: JID -> ReceivedStanza -> [XMPPEvent] decodeStanza selfjid s@(ReceivedPresence p) @@ -180,7 +200,7 @@ relayNetMessage :: JID -> Assistant (XMPP ()) relayNetMessage selfjid = do msg <- waitNetMessage - debug ["sending:", show $ sanitizeNetMessage msg] + debug ["sending:", logNetMessage msg] a1 <- handleImportant msg a2 <- convert msg return (a1 >> a2) @@ -197,10 +217,12 @@ then do clients <- maybe [] (S.toList . buddyAssistants) <$> getBuddy (genBuddyKey tojid) <<~ buddyList - debug ["exploded undirected message to clients", show clients] + debug ["exploded undirected message to clients", unwords $ map logClient clients] return $ forM_ (clients) $ \(Client jid) -> putStanza $ pushMessage pushstage jid selfjid - else return $ putStanza $ pushMessage pushstage tojid selfjid + else do + debug ["to client:", logJid tojid] + return $ putStanza $ pushMessage pushstage tojid selfjid convert msg = convertNetMsg msg selfjid {- Converts a NetMessage to an XMPP action. -} @@ -261,19 +283,26 @@ unlessM (null . fst <$> manualPull branch [r]) $ pullone rs branch +{- PairReq from another client using our JID is automatically + - accepted. This is so pairing devices all using the same XMPP + - account works without confirmations. + - + - Also, autoaccept PairReq from the same JID of any repo we've + - already paired with, as long as the UUID in the PairReq is + - one we know about. +-} pairMsgReceived :: UrlRenderer -> PairStage -> UUID -> JID -> JID -> Assistant () pairMsgReceived urlrenderer PairReq theiruuid selfjid theirjid | baseJID selfjid == baseJID theirjid = autoaccept | otherwise = do knownjids <- catMaybes . map (parseJID . getXMPPClientID) . filter isXMPPRemote . syncRemotes <$> getDaemonStatus - if any (== baseJID theirjid) knownjids + um <- liftAnnex uuidMap + if any (== baseJID theirjid) knownjids && M.member theiruuid um then autoaccept else showalert where - -- PairReq from another client using our JID, or the JID of - -- any repo we're already paired with is automatically accepted. autoaccept = do selfuuid <- liftAnnex getUUID sendNetMessage $ @@ -288,9 +317,9 @@ (T.unpack $ buddyName theirjid) button +{- PairAck must come from one of the buddies we are pairing with; + - don't pair with just anyone. -} pairMsgReceived _ PairAck theiruuid _selfjid theirjid = - {- PairAck must come from one of the buddies we are pairing with; - - don't pair with just anyone. -} whenM (isBuddyPairing theirjid) $ do changeBuddyPairing theirjid False selfuuid <- liftAnnex getUUID diff --git a/Assistant/TransferQueue.hs b/Assistant/TransferQueue.hs --- a/Assistant/TransferQueue.hs +++ b/Assistant/TransferQueue.hs @@ -29,6 +29,7 @@ import qualified Remote import qualified Types.Remote as Remote import Annex.Wanted +import Utility.TList import Control.Concurrent.STM import qualified Data.Map as M @@ -38,7 +39,7 @@ {- Reads the queue's content without blocking or changing it. -} getTransferQueue :: Assistant [(Transfer, TransferInfo)] -getTransferQueue = (atomically . readTVar . queuelist) <<~ transferQueue +getTransferQueue = (atomically . readTList . queuelist) <<~ transferQueue stubInfo :: AssociatedFile -> Remote -> TransferInfo stubInfo f r = stubTransferInfo @@ -94,8 +95,7 @@ | direction == Download = do q <- getAssistant transferQueue void $ liftIO $ atomically $ - modifyTVar' (deferreddownloads q) $ - \l -> (k, f):l + consTList (deferreddownloads q) (k, f) | otherwise = noop {- Queues any deferred downloads that can now be accomplished, leaving @@ -103,12 +103,11 @@ queueDeferredDownloads :: Reason -> Schedule -> Assistant () queueDeferredDownloads reason schedule = do q <- getAssistant transferQueue - l <- liftIO $ atomically $ swapTVar (deferreddownloads q) [] + l <- liftIO $ atomically $ readTList (deferreddownloads q) rs <- syncDataRemotes <$> getDaemonStatus left <- filterM (queue rs) l unless (null left) $ - liftIO $ atomically $ modifyTVar' (deferreddownloads q) $ - \new -> new ++ left + liftIO $ atomically $ appendTList (deferreddownloads q) left where queue rs (k, f) = do uuids <- liftAnnex $ Remote.keyLocations k @@ -127,10 +126,9 @@ enqueue :: Reason -> Schedule -> Transfer -> TransferInfo -> Assistant () enqueue reason schedule t info - | schedule == Next = go (new:) - | otherwise = go (\l -> l++[new]) + | schedule == Next = go consTList + | otherwise = go snocTList where - new = (t, info) go modlist = whenM (add modlist) $ do debug [ "queued", describeTransfer t info, ": " ++ reason ] notifyTransfer @@ -140,11 +138,11 @@ liftIO $ atomically $ ifM (checkRunningTransferSTM dstatus t) ( return False , do - l <- readTVar (queuelist q) + l <- readTList (queuelist q) if (t `notElem` map fst l) then do void $ modifyTVar' (queuesize q) succ - void $ modifyTVar' (queuelist q) modlist + void $ modlist (queuelist q) (t, info) return True else return False ) @@ -185,9 +183,9 @@ if sz < 1 then retry -- blocks until queuesize changes else do - (r@(t,info):rest) <- readTVar (queuelist q) - writeTVar (queuelist q) rest + (r@(t,info):rest) <- readTList (queuelist q) void $ modifyTVar' (queuesize q) pred + setTList (queuelist q) rest if acceptable info then do adjustTransfersSTM dstatus $ @@ -219,8 +217,7 @@ dequeueTransfersSTM :: TransferQueue -> (Transfer -> Bool) -> STM [(Transfer, TransferInfo)] dequeueTransfersSTM q c = do - (removed, ts) <- partition (c . fst) - <$> readTVar (queuelist q) + (removed, ts) <- partition (c . fst) <$> readTList (queuelist q) void $ writeTVar (queuesize q) (length ts) - void $ writeTVar (queuelist q) ts + setTList (queuelist q) ts return removed diff --git a/Assistant/Types/Changes.hs b/Assistant/Types/Changes.hs --- a/Assistant/Types/Changes.hs +++ b/Assistant/Types/Changes.hs @@ -1,6 +1,6 @@ {- git-annex assistant change tracking - - - Copyright 2012 Joey Hess + - Copyright 2012-2013 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -9,23 +9,22 @@ import Types.KeySource import Types.Key -import Utility.TSet +import Utility.TList -import Data.Time.Clock import Control.Concurrent.STM - -data ChangeInfo = AddKeyChange Key | AddFileChange | LinkChange (Maybe Key) | RmChange - deriving (Show, Eq) - -changeInfoKey :: ChangeInfo -> Maybe Key -changeInfoKey (AddKeyChange k) = Just k -changeInfoKey (LinkChange (Just k)) = Just k -changeInfoKey _ = Nothing +import Data.Time.Clock -type ChangeChan = TSet Change +{- An un-ordered pool of Changes that have been noticed and should be + - staged and committed. Changes will typically be in order, but ordering + - may be lost. In any case, order should not matter, as any given Change + - may later be reverted by a later Change (ie, a file is added and then + - deleted). Code that processes the changes needs to deal with such + - scenarios. + -} +type ChangePool = TList Change -newChangeChan :: IO ChangeChan -newChangeChan = atomically newTSet +newChangePool :: IO ChangePool +newChangePool = atomically newTList data Change = Change @@ -43,6 +42,14 @@ } deriving (Show) +data ChangeInfo = AddKeyChange Key | AddFileChange | LinkChange (Maybe Key) | RmChange + deriving (Show, Eq, Ord) + +changeInfoKey :: ChangeInfo -> Maybe Key +changeInfoKey (AddKeyChange k) = Just k +changeInfoKey (LinkChange (Just k)) = Just k +changeInfoKey _ = Nothing + changeFile :: Change -> FilePath changeFile (Change _ f _) = f changeFile (PendingAddChange _ f) = f @@ -55,6 +62,11 @@ isInProcessAddChange :: Change -> Bool isInProcessAddChange (InProcessAddChange {}) = True isInProcessAddChange _ = False + +retryChange :: Change -> Change +retryChange (InProcessAddChange time ks) = + PendingAddChange time (keyFilename ks) +retryChange c = c finishedChange :: Change -> Key -> Change finishedChange c@(InProcessAddChange { keySource = ks }) k = Change diff --git a/Assistant/Types/Commits.hs b/Assistant/Types/Commits.hs --- a/Assistant/Types/Commits.hs +++ b/Assistant/Types/Commits.hs @@ -7,13 +7,13 @@ module Assistant.Types.Commits where -import Utility.TSet +import Utility.TList import Control.Concurrent.STM -type CommitChan = TSet Commit +type CommitChan = TList Commit data Commit = Commit newCommitChan :: IO CommitChan -newCommitChan = atomically newTSet +newCommitChan = atomically newTList diff --git a/Assistant/Types/NetMessager.hs b/Assistant/Types/NetMessager.hs --- a/Assistant/Types/NetMessager.hs +++ b/Assistant/Types/NetMessager.hs @@ -10,11 +10,12 @@ import Common.Annex import Assistant.Pairing -import Data.Text (Text) import Control.Concurrent.STM import Control.Concurrent.MSampleVar import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B8 +import Data.Text (Text) +import qualified Data.Text as T import qualified Data.Set as S import qualified Data.Map as M @@ -36,11 +37,11 @@ data PushStage -- indicates that we have data to push over the out of band network - = CanPush + = CanPush UUID -- request that a git push be sent over the out of band network - | PushRequest + | PushRequest UUID -- indicates that a push is starting - | StartingPush + | StartingPush UUID -- a chunk of output of git receive-pack | ReceivePackOutput SequenceNum ByteString -- a chuck of output of git send-pack @@ -57,8 +58,8 @@ {- NetMessages that are important (and small), and should be stored to be - resent when new clients are seen. -} isImportantNetMessage :: NetMessage -> Maybe ClientID -isImportantNetMessage (Pushing c CanPush) = Just c -isImportantNetMessage (Pushing c PushRequest) = Just c +isImportantNetMessage (Pushing c (CanPush _)) = Just c +isImportantNetMessage (Pushing c (PushRequest _)) = Just c isImportantNetMessage _ = Nothing readdressNetMessage :: NetMessage -> ClientID -> NetMessage @@ -67,29 +68,35 @@ readdressNetMessage m _ = m {- Convert a NetMessage to something that can be logged. -} -sanitizeNetMessage :: NetMessage -> NetMessage -sanitizeNetMessage (Pushing c stage) = Pushing c $ case stage of - ReceivePackOutput n _ -> ReceivePackOutput n elided - SendPackOutput n _ -> SendPackOutput n elided - s -> s +logNetMessage :: NetMessage -> String +logNetMessage (Pushing c stage) = show $ Pushing (logClientID c) $ + case stage of + ReceivePackOutput n _ -> ReceivePackOutput n elided + SendPackOutput n _ -> SendPackOutput n elided + s -> s where elided = B8.pack "" -sanitizeNetMessage m = m +logNetMessage (PairingNotification stage c uuid) = + show $ PairingNotification stage (logClientID c) uuid +logNetMessage m = show m +logClientID :: ClientID -> ClientID +logClientID c = T.concat [T.take 1 c, T.pack $ show $ T.length c] + {- Things that initiate either side of a push, but do not actually send data. -} isPushInitiation :: PushStage -> Bool -isPushInitiation CanPush = True -isPushInitiation PushRequest = True -isPushInitiation StartingPush = True +isPushInitiation (CanPush _) = True +isPushInitiation (PushRequest _) = True +isPushInitiation (StartingPush _) = True isPushInitiation _ = False data PushSide = SendPack | ReceivePack deriving (Eq, Ord) pushDestinationSide :: PushStage -> PushSide -pushDestinationSide CanPush = ReceivePack -pushDestinationSide PushRequest = SendPack -pushDestinationSide StartingPush = ReceivePack +pushDestinationSide (CanPush _) = ReceivePack +pushDestinationSide (PushRequest _) = SendPack +pushDestinationSide (StartingPush _) = ReceivePack pushDestinationSide (ReceivePackOutput _ _) = SendPack pushDestinationSide (SendPackOutput _ _) = ReceivePack pushDestinationSide (ReceivePackDone _) = SendPack diff --git a/Assistant/Types/TransferQueue.hs b/Assistant/Types/TransferQueue.hs --- a/Assistant/Types/TransferQueue.hs +++ b/Assistant/Types/TransferQueue.hs @@ -12,11 +12,12 @@ import Types.Remote import Control.Concurrent.STM +import Utility.TList data TransferQueue = TransferQueue { queuesize :: TVar Int - , queuelist :: TVar [(Transfer, TransferInfo)] - , deferreddownloads :: TVar [(Key, AssociatedFile)] + , queuelist :: TList (Transfer, TransferInfo) + , deferreddownloads :: TList (Key, AssociatedFile) } data Schedule = Next | Later @@ -25,5 +26,5 @@ newTransferQueue :: IO TransferQueue newTransferQueue = atomically $ TransferQueue <$> newTVar 0 - <*> newTVar [] - <*> newTVar [] + <*> newTList + <*> newTList diff --git a/Assistant/WebApp/Configurators.hs b/Assistant/WebApp/Configurators.hs --- a/Assistant/WebApp/Configurators.hs +++ b/Assistant/WebApp/Configurators.hs @@ -36,5 +36,9 @@ makeMiscRepositories :: Widget makeMiscRepositories = $(widgetFile "configurators/addrepository/misc") -makeCloudRepositories :: Bool -> Widget -makeCloudRepositories onlyTransfer = $(widgetFile "configurators/addrepository/cloud") +makeCloudRepositories :: Widget +makeCloudRepositories = $(widgetFile "configurators/addrepository/cloud") + +makeArchiveRepositories :: Widget +makeArchiveRepositories = $(widgetFile "configurators/addrepository/archive") + diff --git a/Assistant/WebApp/Configurators/AWS.hs b/Assistant/WebApp/Configurators/AWS.hs --- a/Assistant/WebApp/Configurators/AWS.hs +++ b/Assistant/WebApp/Configurators/AWS.hs @@ -19,9 +19,11 @@ import qualified Remote.Helper.AWS as AWS import Logs.Remote import qualified Remote +import qualified Types.Remote as Remote import Types.Remote (RemoteConfig) import Types.StandardGroups import Logs.PreferredContent +import Creds import qualified Data.Text as T import qualified Data.Map as M @@ -61,10 +63,10 @@ extractCreds :: AWSInput -> AWSCreds extractCreds i = AWSCreds (accessKeyID i) (secretAccessKey i) -s3InputAForm :: AForm WebApp WebApp AWSInput -s3InputAForm = AWSInput - <$> accessKeyIDField - <*> secretAccessKeyField +s3InputAForm :: Maybe CredPair -> AForm WebApp WebApp AWSInput +s3InputAForm defcreds = AWSInput + <$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds) + <*> secretAccessKeyField (T.pack . snd <$> defcreds) <*> datacenterField AWS.S3 <*> areq (selectFieldList storageclasses) "Storage class" (Just StandardRedundancy) <*> areq textField "Repository name" (Just "S3") @@ -76,30 +78,33 @@ , ("Reduced redundancy (costs less)", ReducedRedundancy) ] -glacierInputAForm :: AForm WebApp WebApp AWSInput -glacierInputAForm = AWSInput - <$> accessKeyIDField - <*> secretAccessKeyField +glacierInputAForm :: Maybe CredPair -> AForm WebApp WebApp AWSInput +glacierInputAForm defcreds = AWSInput + <$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds) + <*> secretAccessKeyField (T.pack . snd <$> defcreds) <*> datacenterField AWS.Glacier <*> pure StandardRedundancy <*> areq textField "Repository name" (Just "glacier") <*> enableEncryptionField -awsCredsAForm :: AForm WebApp WebApp AWSCreds -awsCredsAForm = AWSCreds - <$> accessKeyIDField - <*> secretAccessKeyField +awsCredsAForm :: Maybe CredPair -> AForm WebApp WebApp AWSCreds +awsCredsAForm defcreds = AWSCreds + <$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds) + <*> secretAccessKeyField (T.pack . snd <$> defcreds) -accessKeyIDField :: AForm WebApp WebApp Text -accessKeyIDField = areq (textField `withNote` help) "Access Key ID" Nothing +accessKeyIDField :: Widget -> Maybe Text -> AForm WebApp WebApp Text +accessKeyIDField help def = areq (textField `withNote` help) "Access Key ID" def + +accessKeyIDFieldWithHelp :: Maybe Text -> AForm WebApp WebApp Text +accessKeyIDFieldWithHelp def = accessKeyIDField help def where help = [whamlet| Get Amazon access keys |] -secretAccessKeyField :: AForm WebApp WebApp Text -secretAccessKeyField = areq passwordField "Secret Access Key" Nothing +secretAccessKeyField :: Maybe Text -> AForm WebApp WebApp Text +secretAccessKeyField def = areq passwordField "Secret Access Key" def datacenterField :: AWS.Service -> AForm WebApp WebApp Text datacenterField service = areq (selectFieldList list) "Datacenter" defregion @@ -113,8 +118,9 @@ postAddS3R :: Handler RepHtml #ifdef WITH_S3 postAddS3R = awsConfigurator $ do + defcreds <- liftAnnex previouslyUsedAWSCreds ((result, form), enctype) <- lift $ - runFormPost $ renderBootstrap s3InputAForm + runFormPost $ renderBootstrap $ s3InputAForm defcreds case result of FormSuccess input -> lift $ do let name = T.unpack $ repoName input @@ -137,8 +143,9 @@ postAddGlacierR :: Handler RepHtml postAddGlacierR = glacierConfigurator $ do + defcreds <- liftAnnex previouslyUsedAWSCreds ((result, form), enctype) <- lift $ - runFormPost $ renderBootstrap glacierInputAForm + runFormPost $ renderBootstrap $ glacierInputAForm defcreds case result of FormSuccess input -> lift $ do let name = T.unpack $ repoName input @@ -153,11 +160,19 @@ setStandardGroup (Remote.uuid r) SmallArchiveGroup getEnableS3R :: UUID -> Handler RepHtml +#ifdef WITH_S3 +getEnableS3R uuid = do + m <- liftAnnex readRemoteLog + if isIARemoteConfig $ fromJust $ M.lookup uuid m + then redirect $ EnableIAR uuid + else postEnableS3R uuid +#else getEnableS3R = postEnableS3R +#endif postEnableS3R :: UUID -> Handler RepHtml #ifdef WITH_S3 -postEnableS3R = awsConfigurator . enableAWSRemote S3.remote +postEnableS3R uuid = awsConfigurator $ enableAWSRemote S3.remote uuid #else postEnableS3R _ = error "S3 not supported by this build" #endif @@ -170,8 +185,9 @@ enableAWSRemote :: RemoteType -> UUID -> Widget enableAWSRemote remotetype uuid = do + defcreds <- liftAnnex previouslyUsedAWSCreds ((result, form), enctype) <- lift $ - runFormPost $ renderBootstrap awsCredsAForm + runFormPost $ renderBootstrap $ awsCredsAForm defcreds case result of FormSuccess creds -> lift $ do m <- liftAnnex readRemoteLog @@ -199,3 +215,19 @@ hostname = case filter isAlphaNum name of [] -> "aws" n -> n + +getRepoInfo :: RemoteConfig -> Widget +getRepoInfo c = [whamlet|S3 remote using bucket: #{bucket}|] + where + bucket = fromMaybe "" $ M.lookup "bucket" c + +#ifdef WITH_S3 +isIARemoteConfig :: RemoteConfig -> Bool +isIARemoteConfig = S3.isIAHost . fromMaybe "" . M.lookup "host" +#endif + +previouslyUsedAWSCreds :: Annex (Maybe CredPair) +previouslyUsedAWSCreds = getM gettype [S3.remote, Glacier.remote] + where + gettype t = previouslyUsedCredPair AWS.creds t $ + not . isIARemoteConfig . Remote.config diff --git a/Assistant/WebApp/Configurators/Delete.hs b/Assistant/WebApp/Configurators/Delete.hs --- a/Assistant/WebApp/Configurators/Delete.hs +++ b/Assistant/WebApp/Configurators/Delete.hs @@ -16,7 +16,7 @@ import Assistant.ScanRemotes import qualified Remote import qualified Git -import Locations.UserConfig +import Config.Files import Utility.FileMode import Logs.Trust import Logs.Remote diff --git a/Assistant/WebApp/Configurators/Edit.hs b/Assistant/WebApp/Configurators/Edit.hs --- a/Assistant/WebApp/Configurators/Edit.hs +++ b/Assistant/WebApp/Configurators/Edit.hs @@ -5,7 +5,7 @@ - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-} +{-# LANGUAGE CPP, TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-} module Assistant.WebApp.Configurators.Edit where @@ -15,12 +15,18 @@ import Assistant.MakeRemote (uniqueRemoteName) import Assistant.WebApp.Configurators.XMPP (xmppNeeded) import Assistant.ScanRemotes +import qualified Assistant.WebApp.Configurators.AWS as AWS +import qualified Assistant.WebApp.Configurators.IA as IA +#ifdef WITH_S3 +import qualified Remote.S3 as S3 +#endif import qualified Remote import qualified Types.Remote as Remote import qualified Remote.List as Remote import Logs.UUID import Logs.Group import Logs.PreferredContent +import Logs.Remote import Types.StandardGroups import qualified Git import qualified Git.Command @@ -39,26 +45,32 @@ { repoName :: Text , repoDescription :: Maybe Text , repoGroup :: RepoGroup + , repoAssociatedDirectory :: Maybe Text , repoSyncable :: Bool } deriving (Show) getRepoConfig :: UUID -> Maybe Remote -> Annex RepoConfig -getRepoConfig uuid mremote = RepoConfig - <$> pure (T.pack $ maybe "here" Remote.name mremote) - <*> (maybe Nothing (Just . T.pack) . M.lookup uuid <$> uuidMap) - <*> getrepogroup - <*> getsyncing - where - getrepogroup = do - groups <- lookupGroups uuid - return $ - maybe (RepoGroupCustom $ unwords $ S.toList groups) RepoGroupStandard - (getStandardGroup groups) - getsyncing = case mremote of +getRepoConfig uuid mremote = do + groups <- lookupGroups uuid + remoteconfig <- M.lookup uuid <$> readRemoteLog + let (repogroup, associateddirectory) = case getStandardGroup groups of + Nothing -> (RepoGroupCustom $ unwords $ S.toList groups, Nothing) + Just g -> (RepoGroupStandard g, associatedDirectory remoteconfig g) + + description <- maybe Nothing (Just . T.pack) . M.lookup uuid <$> uuidMap + + syncable <- case mremote of Just r -> return $ remoteAnnexSync $ Remote.gitconfig r Nothing -> annexAutoCommit <$> Annex.getGitConfig + return $ RepoConfig + (T.pack $ maybe "here" Remote.name mremote) + description + repogroup + (T.pack <$> associateddirectory) + syncable + setRepoConfig :: UUID -> Maybe Remote -> RepoConfig -> RepoConfig -> Handler () setRepoConfig uuid mremote oldc newc = do when descriptionChanged $ liftAnnex $ do @@ -85,6 +97,17 @@ ] void $ Remote.remoteListRefresh liftAssistant updateSyncRemotes + when associatedDirectoryChanged $ case repoAssociatedDirectory newc of + Nothing -> noop + Just t + | T.null t -> noop + | otherwise -> liftAnnex $ do + let dir = takeBaseName $ T.unpack t + m <- readRemoteLog + case M.lookup uuid m of + Nothing -> noop + Just remoteconfig -> configSet uuid $ + M.insert "preferreddir" dir remoteconfig when groupChanged $ do liftAnnex $ case repoGroup newc of RepoGroupStandard g -> setStandardGroup uuid g @@ -102,6 +125,7 @@ changeSyncable mremote (repoSyncable newc) where syncableChanged = repoSyncable oldc /= repoSyncable newc + associatedDirectoryChanged = repoAssociatedDirectory oldc /= repoAssociatedDirectory newc groupChanged = repoGroup oldc /= repoGroup newc nameChanged = isJust mremote && legalName oldc /= legalName newc descriptionChanged = repoDescription oldc /= repoDescription newc @@ -113,6 +137,7 @@ <$> areq textField "Name" (Just $ repoName def) <*> aopt textField "Description" (Just $ repoDescription def) <*> areq (selectFieldList groups `withNote` help) "Repository group" (Just $ repoGroup def) + <*> associateddirectory <*> areq checkBoxField "Syncing enabled" (Just $ repoSyncable def) where groups = customgroups ++ standardgroups @@ -125,6 +150,10 @@ _ -> [] help = [whamlet|What's this?|] + associateddirectory = case repoAssociatedDirectory def of + Nothing -> aopt hiddenField "" Nothing + Just d -> aopt textField "Associated directory" (Just $ Just d) + getEditRepositoryR :: UUID -> Handler RepHtml getEditRepositoryR = postEditRepositoryR @@ -147,30 +176,47 @@ editForm new uuid = page "Configure repository" (Just Configuration) $ do mremote <- liftAnnex $ Remote.remoteFromUUID uuid curr <- liftAnnex $ getRepoConfig uuid mremote - lift $ checkarchivedirectory curr + liftAnnex $ checkAssociatedDirectory curr mremote ((result, form), enctype) <- lift $ runFormPost $ renderBootstrap $ editRepositoryAForm curr case result of FormSuccess input -> lift $ do - checkarchivedirectory input setRepoConfig uuid mremote curr input + liftAnnex $ checkAssociatedDirectory input mremote redirect DashboardR - _ -> showform form enctype curr - where - showform form enctype curr = do - let istransfer = repoGroup curr == RepoGroupStandard TransferGroup - $(widgetFile "configurators/editrepository") + _ -> do + let istransfer = repoGroup curr == RepoGroupStandard TransferGroup + repoInfo <- getRepoInfo mremote . M.lookup uuid + <$> liftAnnex readRemoteLog + $(widgetFile "configurators/editrepository") - {- Makes a toplevel archive directory, so the user can get on with - - using it. This is done both when displaying the form, as well - - as after it's posted, because the user may not post the form, - - but may see that the repo is set up to use the archive - - directory. -} - checkarchivedirectory cfg - | repoGroup cfg == RepoGroupStandard SmallArchiveGroup = go - | repoGroup cfg == RepoGroupStandard FullArchiveGroup = go - | otherwise = noop - where - go = liftAnnex $ inRepo $ \g -> - createDirectoryIfMissing True $ - Git.repoPath g "archive" +{- Makes any directory associated with the repository. -} +checkAssociatedDirectory :: RepoConfig -> Maybe Remote -> Annex () +checkAssociatedDirectory _ Nothing = noop +checkAssociatedDirectory cfg (Just r) = do + repoconfig <- M.lookup (Remote.uuid r) <$> readRemoteLog + case repoGroup cfg of + RepoGroupStandard gr -> case associatedDirectory repoconfig gr of + Just d -> inRepo $ \g -> + createDirectoryIfMissing True $ + Git.repoPath g d + Nothing -> noop + _ -> noop + +getRepoInfo :: Maybe Remote.Remote -> Maybe Remote.RemoteConfig -> Widget +getRepoInfo (Just r) (Just c) = case M.lookup "type" c of + Just "S3" +#ifdef WITH_S3 + | S3.isIA c -> IA.getRepoInfo c +#endif + | otherwise -> AWS.getRepoInfo c + Just t + | t /= "git" -> [whamlet|#{t} remote|] + _ -> getGitRepoInfo $ Remote.repo r +getRepoInfo (Just r) _ = getRepoInfo (Just r) (Just $ Remote.config r) +getRepoInfo _ _ = [whamlet|git repository|] + +getGitRepoInfo :: Git.Repo -> Widget +getGitRepoInfo r = do + let loc = Git.repoLocation r + [whamlet|git repository located at #{loc}|] diff --git a/Assistant/WebApp/Configurators/IA.hs b/Assistant/WebApp/Configurators/IA.hs new file mode 100644 --- /dev/null +++ b/Assistant/WebApp/Configurators/IA.hs @@ -0,0 +1,211 @@ +{- git-annex assistant webapp configurators for Internet Archive + - + - Copyright 2013 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE CPP, FlexibleContexts, TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-} + +module Assistant.WebApp.Configurators.IA where + +import Assistant.WebApp.Common +import qualified Assistant.WebApp.Configurators.AWS as AWS +#ifdef WITH_S3 +import qualified Remote.S3 as S3 +import qualified Remote.Helper.AWS as AWS +import Assistant.MakeRemote +#endif +import qualified Remote +import qualified Types.Remote as Remote +import Types.StandardGroups +import Types.Remote (RemoteConfig) +import Logs.PreferredContent +import Logs.Remote +import qualified Utility.Url as Url +import Creds + +import qualified Data.Text as T +import qualified Data.Map as M +import Data.Char +import Network.URI + +iaConfigurator :: Widget -> Handler RepHtml +iaConfigurator = page "Add an Internet Archive repository" (Just Configuration) + +data IAInput = IAInput + { accessKeyID :: Text + , secretAccessKey :: Text + , mediaType :: MediaType + , itemName :: Text + } + +extractCreds :: IAInput -> AWS.AWSCreds +extractCreds i = AWS.AWSCreds (accessKeyID i) (secretAccessKey i) + +{- IA defines only a few media types currently, or the media type + - may be omitted + - + - We add a few other common types, mapped to what we've been told + - is the closest match. + -} +data MediaType = MediaImages | MediaAudio | MediaVideo | MediaText | MediaSoftware | MediaOmitted + deriving (Eq, Ord, Enum, Bounded) + +{- Format a MediaType for entry into the IA metadata -} +formatMediaType :: MediaType -> String +formatMediaType MediaText = "texts" +formatMediaType MediaImages = "image" +formatMediaType MediaSoftware = "software" +formatMediaType MediaVideo = "movies" +formatMediaType MediaAudio = "audio" +formatMediaType MediaOmitted = "" + +{- A default collection to use for each Mediatype. -} +collectionMediaType :: MediaType -> Maybe String +collectionMediaType MediaText = Just "opensource" +collectionMediaType MediaImages = Just "opensource" -- not ideal +collectionMediaType MediaSoftware = Just "opensource" -- not ideal +collectionMediaType MediaVideo = Just "opensource_movies" +collectionMediaType MediaAudio = Just "opensource_audio" +collectionMediaType MediaOmitted = Just "opensource" + +{- Format a MediaType for user display. -} +showMediaType :: MediaType -> String +showMediaType MediaText = "texts" +showMediaType MediaImages = "photos & images" +showMediaType MediaSoftware = "software" +showMediaType MediaVideo = "videos & movies" +showMediaType MediaAudio = "audio & music" +showMediaType MediaOmitted = "other" + +iaInputAForm :: Maybe CredPair -> AForm WebApp WebApp IAInput +iaInputAForm defcreds = IAInput + <$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds) + <*> AWS.secretAccessKeyField (T.pack . snd <$> defcreds) + <*> areq (selectFieldList mediatypes) "Media Type" (Just MediaOmitted) + <*> areq (textField `withExpandableNote` ("Help", itemNameHelp)) "Item Name" Nothing + where + mediatypes :: [(Text, MediaType)] + mediatypes = map (\t -> (T.pack $ showMediaType t, t)) [minBound..] + +itemNameHelp :: Widget +itemNameHelp = [whamlet| +
+ Each item stored in the Internet Archive must have a unique name. +
+ Once you create the item, a special directory will appear # + with a name matching the item name. Files you put in that directory # + will be uploaded to your Internet Archive item. +|] + +iaCredsAForm :: Maybe CredPair -> AForm WebApp WebApp AWS.AWSCreds +iaCredsAForm defcreds = AWS.AWSCreds + <$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds) + <*> AWS.secretAccessKeyField (T.pack . snd <$> defcreds) + +#ifdef WITH_S3 +previouslyUsedIACreds :: Annex (Maybe CredPair) +previouslyUsedIACreds = previouslyUsedCredPair AWS.creds S3.remote $ + AWS.isIARemoteConfig . Remote.config +#endif + +accessKeyIDFieldWithHelp :: Maybe Text -> AForm WebApp WebApp Text +accessKeyIDFieldWithHelp def = AWS.accessKeyIDField help def + where + help = [whamlet| + + Get Internet Archive access keys +|] + +getAddIAR :: Handler RepHtml +getAddIAR = postAddIAR + +postAddIAR :: Handler RepHtml +#ifdef WITH_S3 +postAddIAR = iaConfigurator $ do + defcreds <- liftAnnex previouslyUsedIACreds + ((result, form), enctype) <- lift $ + runFormPost $ renderBootstrap $ iaInputAForm defcreds + case result of + FormSuccess input -> lift $ do + let name = escapeBucket $ T.unpack $ itemName input + AWS.makeAWSRemote S3.remote (extractCreds input) name setgroup $ + M.fromList $ catMaybes + [ Just $ configureEncryption NoEncryption + , Just ("type", "S3") + , Just ("host", S3.iaHost) + , Just ("bucket", escapeHeader name) + , Just ("x-archive-meta-title", escapeHeader $ T.unpack $ itemName input) + , if mediaType input == MediaOmitted + then Nothing + else Just ("x-archive-mediatype", formatMediaType $ mediaType input) + , (,) <$> pure "x-archive-meta-collection" <*> collectionMediaType (mediaType input) + -- Make item show up ASAP. + , Just ("x-archive-interactive-priority", "1") + , Just ("preferreddir", name) + ] + _ -> $(widgetFile "configurators/addia") + where + setgroup r = liftAnnex $ + setStandardGroup (Remote.uuid r) PublicGroup +#else +postAddIAR = error "S3 not supported by this build" +#endif + +getEnableIAR :: UUID -> Handler RepHtml +getEnableIAR = postEnableIAR + +postEnableIAR :: UUID -> Handler RepHtml +#ifdef WITH_S3 +postEnableIAR = iaConfigurator . enableIARemote +#else +postEnableIAR _ = error "S3 not supported by this build" +#endif + +#ifdef WITH_S3 +enableIARemote :: UUID -> Widget +enableIARemote uuid = do + defcreds <- liftAnnex previouslyUsedIACreds + ((result, form), enctype) <- lift $ + runFormPost $ renderBootstrap $ iaCredsAForm defcreds + case result of + FormSuccess creds -> lift $ do + m <- liftAnnex readRemoteLog + let name = fromJust $ M.lookup "name" $ + fromJust $ M.lookup uuid m + AWS.makeAWSRemote S3.remote creds name (const noop) M.empty + _ -> do + description <- liftAnnex $ + T.pack <$> Remote.prettyUUID uuid + $(widgetFile "configurators/enableia") +#endif + +{- Convert a description into a bucket item name, which will also be + - used as the repository name, and the preferreddir. + - IA seems to need only lower case, and no spaces. -} +escapeBucket :: String -> String +escapeBucket = map toLower . replace " " "-" + +{- IA S3 API likes headers to be URI escaped, escaping spaces looks ugly. -} +escapeHeader :: String -> String +escapeHeader = escapeURIString (\c -> isUnescapedInURI c && c /= ' ') + +getRepoInfo :: RemoteConfig -> Widget +getRepoInfo c = do + exists <- liftIO $ catchDefaultIO False $ fst <$> Url.exists url [] + [whamlet| + + Internet Archive item +$if (not exists) +

+ The page will only be available once some files # + have been uploaded, and the Internet Archive has processed them. +|] + where + bucket = fromMaybe "" $ M.lookup "bucket" c +#ifdef WITH_S3 + url = S3.iaItemUrl bucket +#else + url = "" +#endif diff --git a/Assistant/WebApp/Configurators/Local.hs b/Assistant/WebApp/Configurators/Local.hs --- a/Assistant/WebApp/Configurators/Local.hs +++ b/Assistant/WebApp/Configurators/Local.hs @@ -19,7 +19,7 @@ import qualified Git.Config import qualified Git.Command import qualified Annex -import Locations.UserConfig +import Config.Files import Utility.FreeDesktop #ifdef WITH_CLIBS import Utility.Mounts @@ -98,14 +98,19 @@ - ~/Desktop/annex, when a Desktop directory exists, and ~/annex otherwise. - - If run in another directory, that the user can write to, - - the user probably wants to put it there. -} + - the user probably wants to put it there. Unless that directory + - contains a git-annex file, in which case the user has probably + - browsed to a directory with git-annex and run it from there. -} defaultRepositoryPath :: Bool -> IO FilePath defaultRepositoryPath firstrun = do cwd <- liftIO $ getCurrentDirectory home <- myHomeDir if home == cwd && firstrun then inhome - else ifM (canWrite cwd) ( return cwd, inhome ) + else ifM (legit cwd <&&> canWrite cwd) + ( return cwd + , inhome + ) where inhome = do desktop <- userDesktopDir @@ -113,6 +118,7 @@ ( relHome $ desktop gitAnnexAssistantDefaultDir , return $ "~" gitAnnexAssistantDefaultDir ) + legit d = not <$> doesFileExist (d "git-annex") newRepositoryForm :: FilePath -> Form RepositoryPath newRepositoryForm defpath msg = do diff --git a/Assistant/WebApp/Configurators/Pairing.hs b/Assistant/WebApp/Configurators/Pairing.hs --- a/Assistant/WebApp/Configurators/Pairing.hs +++ b/Assistant/WebApp/Configurators/Pairing.hs @@ -14,6 +14,7 @@ import Assistant.WebApp.Common import Assistant.WebApp.Configurators import Assistant.Types.Buddies +import Annex.UUID #ifdef WITH_PAIRING import Assistant.Pairing.Network import Assistant.Pairing.MakeRemote @@ -22,7 +23,6 @@ import Assistant.DaemonStatus import Utility.Verifiable import Utility.Network -import Annex.UUID #endif #ifdef WITH_XMPP import Assistant.XMPP.Client @@ -60,8 +60,7 @@ $(widgetFile "configurators/pairing/xmpp/friend/prompt") , do -- go get XMPP configured, then come back - setUltDestCurrent - redirect XMPPR + redirect XMPPConfigForPairFriendR ) #else getStartXMPPPairFriendR = noXMPPPairing @@ -76,8 +75,7 @@ where go Nothing = do -- go get XMPP configured, then come back - setUltDestCurrent - redirect XMPPR + redirect XMPPConfigForPairSelfR go (Just creds) = do {- Ask buddies to send presence info, to get - the buddy list populated. -} diff --git a/Assistant/WebApp/Configurators/Preferences.hs b/Assistant/WebApp/Configurators/Preferences.hs --- a/Assistant/WebApp/Configurators/Preferences.hs +++ b/Assistant/WebApp/Configurators/Preferences.hs @@ -16,7 +16,7 @@ import qualified Annex import qualified Git import Config -import Locations.UserConfig +import Config.Files import Utility.DataUnits import qualified Data.Text as T diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs --- a/Assistant/WebApp/Configurators/Ssh.hs +++ b/Assistant/WebApp/Configurators/Ssh.hs @@ -205,7 +205,7 @@ , rsyncOnly = status == UsableRsyncServer } probe extraopts = do - let remotecommand = shellWrap $ join ";" + let remotecommand = shellWrap $ intercalate ";" [ report "loggedin" , checkcommand "git-annex-shell" , checkcommand "rsync" @@ -287,10 +287,10 @@ where sshhost = genSshHost (sshHostName sshdata) (sshUserName sshdata) remotedir = T.unpack $ sshDirectory sshdata - remoteCommand = shellWrap $ join "&&" $ catMaybes + remoteCommand = shellWrap $ intercalate "&&" $ catMaybes [ Just $ "mkdir -p " ++ shellEscape remotedir , Just $ "cd " ++ shellEscape remotedir - , if rsync then Nothing else Just "git init --bare --shared" + , if rsync then Nothing else Just "if [ ! -d .git ]; then git init --bare --shared; fi" , if rsync then Nothing else Just "git annex init" , if needsPubKey sshdata then addAuthorizedKeysCommand (rsyncOnly sshdata) remotedir . sshPubKey <$> keypair @@ -323,17 +323,14 @@ "That is not a rsync.net host name." _ -> showform UntestedServer where - hostnamefield = textField `withNote` help + hostnamefield = textField `withExpandableNote` ("Help", help) help = [whamlet| - - Help -

-
- When you sign up for a Rsync.net account, you should receive an # - email from them with the host name and user name to put here. -
- The host name will be something like "usw-s001.rsync.net", and the # - user name something like "7491" +
+ When you sign up for a Rsync.net account, you should receive an # + email from them with the host name and user name to put here. +
+ The host name will be something like "usw-s001.rsync.net", and the # + user name something like "7491" |] makeRsyncNet :: SshInput -> String -> (Remote -> Handler ()) -> Handler RepHtml @@ -353,7 +350,7 @@ - one recommended by rsync.net documentation. I touch the file first - to not need to use a different method to create it. -} - let remotecommand = join ";" + let remotecommand = intercalate ";" [ "mkdir -p .ssh" , "touch .ssh/authorized_keys" , "dd of=.ssh/authorized_keys oflag=append conv=notrunc" diff --git a/Assistant/WebApp/Configurators/WebDAV.hs b/Assistant/WebApp/Configurators/WebDAV.hs --- a/Assistant/WebApp/Configurators/WebDAV.hs +++ b/Assistant/WebApp/Configurators/WebDAV.hs @@ -1,6 +1,6 @@ {- git-annex assistant webapp configurators for WebDAV remotes - - - Copyright 2012 Joey Hess + - Copyright 2012, 2013 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -10,20 +10,21 @@ module Assistant.WebApp.Configurators.WebDAV where import Assistant.WebApp.Common -import Assistant.MakeRemote -import Assistant.Sync +import Creds #ifdef WITH_WEBDAV import qualified Remote.WebDAV as WebDAV -#endif +import Assistant.MakeRemote +import Assistant.Sync import qualified Remote import Types.Remote (RemoteConfig) import Types.StandardGroups import Logs.PreferredContent import Logs.Remote -import Creds -import qualified Data.Text as T import qualified Data.Map as M +#endif +import qualified Data.Text as T +import Network.URI webDAVConfigurator :: Widget -> Handler RepHtml webDAVConfigurator = page "Add a WebDAV repository" (Just Configuration) @@ -42,18 +43,18 @@ toCredPair :: WebDAVInput -> CredPair toCredPair input = (T.unpack $ user input, T.unpack $ password input) -boxComAForm :: AForm WebApp WebApp WebDAVInput -boxComAForm = WebDAVInput - <$> areq textField "Username or Email" Nothing - <*> areq passwordField "Box.com Password" Nothing +boxComAForm :: Maybe CredPair -> AForm WebApp WebApp WebDAVInput +boxComAForm defcreds = WebDAVInput + <$> areq textField "Username or Email" (T.pack . fst <$> defcreds) + <*> areq passwordField "Box.com Password" (T.pack . snd <$> defcreds) <*> areq checkBoxField "Share this account with other devices and friends?" (Just True) <*> areq textField "Directory" (Just "annex") <*> enableEncryptionField -webDAVCredsAForm :: AForm WebApp WebApp WebDAVInput -webDAVCredsAForm = WebDAVInput - <$> areq textField "Username or Email" Nothing - <*> areq passwordField "Password" Nothing +webDAVCredsAForm :: Maybe CredPair -> AForm WebApp WebApp WebDAVInput +webDAVCredsAForm defcreds = WebDAVInput + <$> areq textField "Username or Email" (T.pack . fst <$> defcreds) + <*> areq passwordField "Password" (T.pack . snd <$> defcreds) <*> pure False <*> pure T.empty <*> pure NoEncryption -- not used! @@ -63,8 +64,9 @@ postAddBoxComR :: Handler RepHtml #ifdef WITH_WEBDAV postAddBoxComR = boxConfigurator $ do + defcreds <- liftAnnex $ previouslyUsedWebDAVCreds "box.com" ((result, form), enctype) <- lift $ - runFormPost $ renderBootstrap boxComAForm + runFormPost $ renderBootstrap $ boxComAForm defcreds case result of FormSuccess input -> lift $ makeWebDavRemote "box.com" (toCredPair input) setgroup $ M.fromList @@ -106,8 +108,11 @@ webDAVConfigurator $ showform name url where showform name url = do + defcreds <- liftAnnex $ + maybe (pure Nothing) previouslyUsedWebDAVCreds $ + urlHost url ((result, form), enctype) <- lift $ - runFormPost $ renderBootstrap webDAVCredsAForm + runFormPost $ renderBootstrap $ webDAVCredsAForm defcreds case result of FormSuccess input -> lift $ makeWebDavRemote name (toCredPair input) (const noop) M.empty @@ -131,3 +136,15 @@ liftAssistant $ syncRemote r redirect $ EditNewCloudRepositoryR $ Remote.uuid r #endif + +{- Only returns creds previously used for the same hostname. -} +previouslyUsedWebDAVCreds :: String -> Annex (Maybe CredPair) +previouslyUsedWebDAVCreds hostname = + previouslyUsedCredPair WebDAV.davCreds WebDAV.remote samehost + where + samehost url = case urlHost =<< WebDAV.configUrl url of + Nothing -> False + Just h -> h == hostname + +urlHost :: String -> Maybe String +urlHost url = uriRegName <$> (uriAuthority =<< parseURI url) diff --git a/Assistant/WebApp/Configurators/XMPP.hs b/Assistant/WebApp/Configurators/XMPP.hs --- a/Assistant/WebApp/Configurators/XMPP.hs +++ b/Assistant/WebApp/Configurators/XMPP.hs @@ -43,7 +43,7 @@ close <- asIO1 removeAlert addAlert $ xmppNeededAlert $ AlertButton { buttonLabel = "Configure a Jabber account" - , buttonUrl = urlrender XMPPR + , buttonUrl = urlrender XMPPConfigR , buttonAction = Just close } #else @@ -91,11 +91,27 @@ $(widgetFile "configurators/xmpp/disabled") #endif -getXMPPR :: Handler RepHtml -getXMPPR = postXMPPR -postXMPPR :: Handler RepHtml +getXMPPConfigR :: Handler RepHtml +getXMPPConfigR = postXMPPConfigR + +postXMPPConfigR :: Handler RepHtml +postXMPPConfigR = xmppform DashboardR + +getXMPPConfigForPairFriendR :: Handler RepHtml +getXMPPConfigForPairFriendR = postXMPPConfigForPairFriendR + +postXMPPConfigForPairFriendR :: Handler RepHtml +postXMPPConfigForPairFriendR = xmppform StartXMPPPairFriendR + +getXMPPConfigForPairSelfR :: Handler RepHtml +getXMPPConfigForPairSelfR = postXMPPConfigForPairSelfR + +postXMPPConfigForPairSelfR :: Handler RepHtml +postXMPPConfigForPairSelfR = xmppform StartXMPPPairSelfR + +xmppform :: Route WebApp -> Handler RepHtml #ifdef WITH_XMPP -postXMPPR = xmppPage $ do +xmppform next = xmppPage $ do ((result, form), enctype) <- lift $ do oldcreds <- liftAnnex getXMPPCreds runFormPost $ renderBootstrap $ xmppAForm $ @@ -109,9 +125,9 @@ storecreds creds = do void $ liftAnnex $ setXMPPCreds creds liftAssistant notifyNetMessagerRestart - redirectUltDest DashboardR + redirect next #else -postXMPPR = xmppPage $ +xmppform = xmppPage $ $(widgetFile "configurators/xmpp/disabled") #endif diff --git a/Assistant/WebApp/Control.hs b/Assistant/WebApp/Control.hs --- a/Assistant/WebApp/Control.hs +++ b/Assistant/WebApp/Control.hs @@ -10,7 +10,7 @@ module Assistant.WebApp.Control where import Assistant.WebApp.Common -import Locations.UserConfig +import Config.Files import Utility.LogFile import Assistant.DaemonStatus import Assistant.WebApp.Utility diff --git a/Assistant/WebApp/Form.hs b/Assistant/WebApp/Form.hs --- a/Assistant/WebApp/Form.hs +++ b/Assistant/WebApp/Form.hs @@ -47,6 +47,17 @@ let fieldwidget = (fieldView field) theId name attrs val isReq in [whamlet|^{fieldwidget}  ^{note}|] +{- Note that the toggle string must be unique on the form. -} +withExpandableNote :: Field sub master v -> (String, GWidget sub master ()) -> Field sub master v +withExpandableNote field (toggle, note) = withNote field $ [whamlet| + + #{toggle} +
+ ^{note} +|] + where + ident = "toggle_" ++ toggle + data EnableEncryption = SharedEncryption | NoEncryption deriving (Eq) diff --git a/Assistant/WebApp/OtherRepos.hs b/Assistant/WebApp/OtherRepos.hs --- a/Assistant/WebApp/OtherRepos.hs +++ b/Assistant/WebApp/OtherRepos.hs @@ -14,7 +14,7 @@ import Assistant.WebApp.Page import qualified Git.Construct import qualified Git.Config -import Locations.UserConfig +import Config.Files import qualified Utility.Url as Url import Utility.Yesod diff --git a/Assistant/WebApp/RepoList.hs b/Assistant/WebApp/RepoList.hs --- a/Assistant/WebApp/RepoList.hs +++ b/Assistant/WebApp/RepoList.hs @@ -133,7 +133,7 @@ unwanted <- S.fromList <$> filterM inUnwantedGroup (S.toList syncing) rs <- filter selectedrepo . concat . Remote.byCost - <$> Remote.enabledRemoteList + <$> Remote.remoteList let us = map Remote.uuid rs let maker u | u `S.member` unwanted = mkUnwantedRepoActions u @@ -163,19 +163,17 @@ selectedremote (Just (iscloud, _)) | onlyCloud reposelector = iscloud | otherwise = True - findinfo m u = case M.lookup u m of - Nothing -> Nothing - Just c -> case M.lookup "type" c of - Just "rsync" -> val True EnableRsyncR - Just "directory" -> val False EnableDirectoryR + findinfo m u = case M.lookup "type" =<< M.lookup u m of + Just "rsync" -> val True EnableRsyncR + Just "directory" -> val False EnableDirectoryR #ifdef WITH_S3 - Just "S3" -> val True EnableS3R + Just "S3" -> val True EnableS3R #endif - Just "glacier" -> val True EnableGlacierR + Just "glacier" -> val True EnableGlacierR #ifdef WITH_WEBDAV - Just "webdav" -> val True EnableWebDAVR + Just "webdav" -> val True EnableWebDAVR #endif - _ -> Nothing + _ -> Nothing where val iscloud r = Just (iscloud, (u, DisabledRepoActions $ r u)) list l = liftAnnex $ do diff --git a/Assistant/WebApp/SideBar.hs b/Assistant/WebApp/SideBar.hs --- a/Assistant/WebApp/SideBar.hs +++ b/Assistant/WebApp/SideBar.hs @@ -20,6 +20,7 @@ import Yesod import Data.Text (Text) +import qualified Data.Text as T import qualified Data.Map as M import Control.Concurrent @@ -47,6 +48,9 @@ let closable = alertClosable alert let block = alertBlockDisplay alert let divclass = bootstrapclass $ alertClass alert + let message = renderAlertMessage alert + let messagelines = T.lines message + let multiline = length messagelines > 1 $(widgetFile "sidebar/alert") {- Called by client to get a sidebar display. diff --git a/Assistant/WebApp/Utility.hs b/Assistant/WebApp/Utility.hs --- a/Assistant/WebApp/Utility.hs +++ b/Assistant/WebApp/Utility.hs @@ -19,8 +19,8 @@ import qualified Remote.List as Remote import qualified Assistant.Threads.Transferrer as Transferrer import Logs.Transfer -import Locations.UserConfig import qualified Config +import Config.Files import Git.Config import Assistant.Threads.Watcher import Assistant.NamedThread diff --git a/Assistant/WebApp/routes b/Assistant/WebApp/routes --- a/Assistant/WebApp/routes +++ b/Assistant/WebApp/routes @@ -15,7 +15,9 @@ /config ConfigurationR GET /config/preferences PreferencesR GET POST -/config/xmpp XMPPR GET POST +/config/xmpp XMPPConfigR GET POST +/config/xmpp/for/self XMPPConfigForPairSelfR GET POST +/config/xmpp/for/frield XMPPConfigForPairFriendR GET POST /config/xmpp/needcloudrepo/#UUID NeedCloudRepoR GET /config/addrepository AddRepositoryR GET @@ -40,6 +42,7 @@ /config/repository/add/ssh/make/rsync/#SshData MakeSshRsyncR GET /config/repository/add/cloud/rsync.net AddRsyncNetR GET POST /config/repository/add/cloud/S3 AddS3R GET POST +/config/repository/add/cloud/IA AddIAR GET POST /config/repository/add/cloud/glacier AddGlacierR GET POST /config/repository/add/cloud/box.com AddBoxComR GET POST @@ -58,6 +61,7 @@ /config/repository/enable/rsync/#UUID EnableRsyncR GET POST /config/repository/enable/directory/#UUID EnableDirectoryR GET /config/repository/enable/S3/#UUID EnableS3R GET POST +/config/repository/enable/IA/#UUID EnableIAR GET POST /config/repository/enable/glacier/#UUID EnableGlacierR GET POST /config/repository/enable/webdav/#UUID EnableWebDAVR GET POST diff --git a/Assistant/XMPP.hs b/Assistant/XMPP.hs --- a/Assistant/XMPP.hs +++ b/Assistant/XMPP.hs @@ -131,9 +131,12 @@ pushMessage :: PushStage -> JID -> JID -> Message pushMessage = gitAnnexMessage . encode where - encode CanPush = gitAnnexTag canPushAttr T.empty - encode PushRequest = gitAnnexTag pushRequestAttr T.empty - encode StartingPush = gitAnnexTag startingPushAttr T.empty + encode (CanPush u) = + gitAnnexTag canPushAttr $ T.pack $ fromUUID u + encode (PushRequest u) = + gitAnnexTag pushRequestAttr $ T.pack $ fromUUID u + encode (StartingPush u) = + gitAnnexTag startingPushAttr $ T.pack $ fromUUID u encode (ReceivePackOutput n b) = gitAnnexTagContent receivePackAttr (val n) $ encodeTagContent b encode (SendPackOutput n b) = @@ -157,11 +160,11 @@ , receivePackDoneAttr ] [ decodePairingNotification - , pushdecoder $ const $ Just CanPush - , pushdecoder $ const $ Just PushRequest - , pushdecoder $ const $ Just StartingPush - , pushdecoder $ gen ReceivePackOutput - , pushdecoder $ gen SendPackOutput + , pushdecoder $ gen CanPush + , pushdecoder $ gen PushRequest + , pushdecoder $ gen StartingPush + , pushdecoder $ seqgen ReceivePackOutput + , pushdecoder $ seqgen SendPackOutput , pushdecoder $ fmap (ReceivePackDone . decodeExitCode) . readish . T.unpack . tagValue @@ -169,7 +172,8 @@ pushdecoder a m' i = Pushing <$> (formatJID <$> messageFrom m') <*> a i - gen c i = do + gen c = Just . c . toUUID . T.unpack . tagValue + seqgen c i = do packet <- decodeTagContent $ tagElement i let seqnum = fromMaybe 0 $ readish $ T.unpack $ tagValue i return $ c seqnum packet diff --git a/Assistant/XMPP/Git.hs b/Assistant/XMPP/Git.hs --- a/Assistant/XMPP/Git.hs +++ b/Assistant/XMPP/Git.hs @@ -21,11 +21,12 @@ import qualified Command.Sync import qualified Annex.Branch import Annex.UUID +import Logs.UUID import Annex.TaggedPush import Config import Git import qualified Git.Branch -import Locations.UserConfig +import Config.Files import qualified Types.Remote as Remote import qualified Remote as Remote import Remote.List @@ -84,7 +85,8 @@ -} xmppPush :: ClientID -> (Git.Repo -> IO Bool) -> (NetMessage -> Assistant ()) -> Assistant Bool xmppPush cid gitpush handledeferred = runPush SendPack cid handledeferred $ do - sendNetMessage $ Pushing cid StartingPush + u <- liftAnnex getUUID + sendNetMessage $ Pushing cid (StartingPush u) (Fd inf, writepush) <- liftIO createPipe (readpush, Fd outf) <- liftIO createPipe @@ -97,7 +99,7 @@ env <- liftIO getEnvironment path <- liftIO getSearchPath let myenv = M.fromList - [ ("PATH", join [searchPathSeparator] $ tmpdir:path) + [ ("PATH", intercalate [searchPathSeparator] $ tmpdir:path) , (relayIn, show inf) , (relayOut, show outf) , (relayControl, show controlf) @@ -247,26 +249,29 @@ hClose inh killThread =<< myThreadId -xmppRemotes :: ClientID -> Assistant [Remote] -xmppRemotes cid = case baseJID <$> parseJID cid of +xmppRemotes :: ClientID -> UUID -> Assistant [Remote] +xmppRemotes cid theiruuid = case baseJID <$> parseJID cid of Nothing -> return [] Just jid -> do let loc = gitXMPPLocation jid - filter (matching loc . Remote.repo) . syncGitRemotes + um <- liftAnnex uuidMap + filter (matching loc . Remote.repo) . filter (knownuuid um) . syncGitRemotes <$> getDaemonStatus where matching loc r = repoIsUrl r && repoLocation r == loc + knownuuid um r = Remote.uuid r == theiruuid || M.member theiruuid um handlePushInitiation :: (Remote -> Assistant ()) -> NetMessage -> Assistant () -handlePushInitiation _ (Pushing cid CanPush) = - unlessM (null <$> xmppRemotes cid) $ - sendNetMessage $ Pushing cid PushRequest -handlePushInitiation checkcloudrepos (Pushing cid PushRequest) = +handlePushInitiation _ (Pushing cid (CanPush theiruuid)) = + unlessM (null <$> xmppRemotes cid theiruuid) $ do + u <- liftAnnex getUUID + sendNetMessage $ Pushing cid (PushRequest u) +handlePushInitiation checkcloudrepos (Pushing cid (PushRequest theiruuid)) = go =<< liftAnnex (inRepo Git.Branch.current) where go Nothing = noop go (Just branch) = do - rs <- xmppRemotes cid + rs <- xmppRemotes cid theiruuid liftAnnex $ Annex.Branch.commit "update" (g, u) <- liftAnnex $ (,) <$> gitRepo @@ -279,8 +284,8 @@ (taggedPush u selfjid branch r) (handleDeferred checkcloudrepos) checkcloudrepos r -handlePushInitiation checkcloudrepos (Pushing cid StartingPush) = do - rs <- xmppRemotes cid +handlePushInitiation checkcloudrepos (Pushing cid (StartingPush theiruuid)) = do + rs <- xmppRemotes cid theiruuid unless (null rs) $ do void $ alertWhile (syncAlert rs) $ xmppReceivePack cid (handleDeferred checkcloudrepos) diff --git a/Backend/SHA.hs b/Backend/SHA.hs --- a/Backend/SHA.hs +++ b/Backend/SHA.hs @@ -121,7 +121,7 @@ selectExtension :: FilePath -> String selectExtension f | null es = "" - | otherwise = join "." ("":es) + | otherwise = intercalate "." ("":es) where es = filter (not . null) $ reverse $ take 2 $ takeWhile shortenough $ diff --git a/Build/Configure.o b/Build/Configure.o Binary files a/Build/Configure.o and b/Build/Configure.o differ diff --git a/Build/DesktopFile.hs b/Build/DesktopFile.hs --- a/Build/DesktopFile.hs +++ b/Build/DesktopFile.hs @@ -14,9 +14,10 @@ import Utility.FreeDesktop import Utility.Path import Utility.Monad -import Locations.UserConfig +import Config.Files import Utility.OSX import Assistant.Install.AutoStart +import Assistant.Install.Menu import Control.Applicative import System.Directory @@ -26,24 +27,6 @@ import System.FilePath import Data.Maybe -{- The command can be either just "git-annex", or the full path to use - - to run it. -} -desktop :: FilePath -> DesktopEntry -desktop command = genDesktopEntry - "Git Annex" - "Track and sync the files in your Git Annex" - False - (command ++ " webapp") - ["Network", "FileTransfer"] - -autostart :: FilePath -> DesktopEntry -autostart command = genDesktopEntry - "Git Annex Assistant" - "Autostart" - False - (command ++ " assistant --autostart") - [] - systemwideInstall :: IO Bool systemwideInstall = isroot <||> destdirset where @@ -60,7 +43,7 @@ writeFDODesktop :: FilePath -> IO () writeFDODesktop command = do datadir <- ifM systemwideInstall ( return systemDataDir, userDataDir ) - writeDesktopMenuFile (desktop command) + installMenu command =<< inDestDir (desktopMenuFilePath "git-annex" datadir) configdir <- ifM systemwideInstall ( return systemConfigDir, userConfigDir ) diff --git a/Build/DesktopFile.o b/Build/DesktopFile.o new file mode 100644 Binary files /dev/null and b/Build/DesktopFile.o differ diff --git a/Build/EvilSplicer.hs b/Build/EvilSplicer.hs --- a/Build/EvilSplicer.hs +++ b/Build/EvilSplicer.hs @@ -1,5 +1,8 @@ {- Expands template haskell splices - + - You should probably just use http://hackage.haskell.org/package/zeroth + - instead. I wish I had known about it before writing this. + - - First, the code must be built with a ghc that supports TH, - and the splices dumped to a log. For example: - cabal build --ghc-options=-ddump-splices 2>&1 | tee log @@ -290,17 +293,61 @@ {- Tweaks code output by GHC in splices to actually build. Yipes. -} mangleCode :: String -> String -mangleCode = declaration_parens +mangleCode = flip_colon + . lambdaparens + . declaration_parens . case_layout . case_layout_multiline - . remove_declaration_splices . yesod_url_render_hack - . yesod_static_route_render_hack . nested_instances . collapse_multiline_strings . remove_package_version . emptylambda where + {- Lambdas are often output without parens around them. + - This breaks when the lambda is immediately applied to a + - parameter. + - + - For example: + - + - renderRoute (StaticR sub_a1nUH) + - = \ (a_a1nUI, b_a1nUJ) + - -> (((pack "static") : a_a1nUI), + - b_a1nUJ) + - (renderRoute sub_a1nUH) + - + - There are sometimes many lines of lambda code that need to be + - parenthesised. Approach: find the "->" and scan down the + - column to the first non-whitespace. This is assumed + - to be the expression after the lambda. + - + - Runs recursively on the body of the lambda, to handle nested + - lambdas. + -} + lambdaparens = parsecAndReplace $ do + -- skip lambdas inside tuples or parens + prefix <- noneOf "(, \n" + preindent <- many1 $ oneOf " \n" + string "\\ " + lambdaparams <- restofline + indent <- many1 $ char ' ' + string "-> " + firstline <- restofline + lambdalines <- many $ try $ do + string indent + char ' ' + l <- restofline + return $ indent ++ " " ++ l + return $ concat + [ prefix:preindent + , "(\\ " ++ lambdaparams ++ "\n" + , indent ++ "-> " + , lambdaparens $ intercalate "\n" (firstline:lambdalines) + , ")\n" + ] + + restofline = manyTill (noneOf "\n") newline + {- For some reason, GHC sometimes doesn't like the multiline - strings it creates. It seems to get hung up on \{ at the - start of a new line sometimes, wanting it to not be escaped. @@ -357,7 +404,7 @@ case_layout_multiline = parsecAndReplace $ do newline indent <- many1 $ char ' ' - firstline <- manyTill (noneOf "\n") newline + firstline <- restofline string indent indent2 <- many1 $ char ' ' @@ -420,44 +467,10 @@ oken <- many $ satisfy isAlphaNum <|> oneOf "-.'" return $ t:oken -{- This works around a problem in the expanded template haskell for Yesod's - - static site route rendering. - - - - renderRoute (StaticR sub_a1nUH) - - = \ (a_a1nUI, b_a1nUJ) - - -> (((pack "static") : a_a1nUI), b_a1nUJ) - - (renderRoute sub_a1nUH) - - - - That is missing parens around the lambda expression (which - - is supposed to be applied to renderRoute). Add those parens. - -} -yesod_static_route_render_hack :: String -> String -yesod_static_route_render_hack = parsecAndReplace $ do - def <- string "renderRoute (StaticR sub_a1nUH)" - whitespace - string "= \\ (" - t1 <- token - string ", " - t2 <- token - string ")" - whitespace - f <- string "-> (((pack \"static\") : " - string t1 - string "), " - string t2 - string ")" - return $ concat - [ def - , " = (\\ (", t1, ",", t2, ") " - , f, t1, "), ", t2, "))" - ] - where - whitespace :: Parser String - whitespace = many $ oneOf " \t\r\n" - - token :: Parser String - token = many1 $ satisfy isAlphaNum <|> oneOf "_" - + {- This works when it's "GHC.Types.:", but we strip + - that above, so have to fix up after it here. + - The ; is added by case_layout. -} + flip_colon = replace "; : _ " "; _ : " {- This works around a problem in the expanded template haskell for Yesod - type-safe url rendering. @@ -486,13 +499,13 @@ whitespace string "(\\" whitespace - token + wtf <- token whitespace string "->" whitespace renderer <- token whitespace - token + string wtf whitespace return $ "(toHtml (flip " ++ renderer ++ " " where diff --git a/Build/EvilSplicer.o b/Build/EvilSplicer.o Binary files a/Build/EvilSplicer.o and b/Build/EvilSplicer.o differ diff --git a/Build/InstallDesktopFile.hs b/Build/InstallDesktopFile.hs --- a/Build/InstallDesktopFile.hs +++ b/Build/InstallDesktopFile.hs @@ -6,11 +6,11 @@ - Licensed under the GNU GPL version 3 or higher. -} -{-# LANGUAGE CPP #-} - module Main where -import Build.InstallDesktopFile +import Build.DesktopFile + +import System.Environment main :: IO () main = getArgs >>= go diff --git a/Build/InstallDesktopFile.o b/Build/InstallDesktopFile.o Binary files a/Build/InstallDesktopFile.o and b/Build/InstallDesktopFile.o differ diff --git a/Build/OSXMkLibs.hs b/Build/OSXMkLibs.hs --- a/Build/OSXMkLibs.hs +++ b/Build/OSXMkLibs.hs @@ -22,6 +22,7 @@ import Utility.Monad import Utility.SafeCommand import Utility.Path +import Utility.Exception import qualified Data.Map as M import qualified Data.Set as S @@ -29,16 +30,16 @@ type LibMap = M.Map FilePath String {- Recursively find and install libs, until nothing new to install is found. -} -mklibs :: FilePath -> [FilePath] -> LibMap -> IO () -mklibs appbase libdirs libmap = do - (new, libmap') <- installLibs appbase libmap +mklibs :: FilePath -> [FilePath] -> [(FilePath, FilePath)] -> LibMap -> IO () +mklibs appbase libdirs replacement_libs libmap = do + (new, replacement_libs', libmap') <- installLibs appbase replacement_libs libmap unless (null new) $ - mklibs appbase (libdirs++new) libmap' + mklibs appbase (libdirs++new) replacement_libs' libmap' {- Returns directories into which new libs were installed. -} -installLibs :: FilePath -> LibMap -> IO ([FilePath], LibMap) -installLibs appbase libmap = do - (needlibs, libmap') <- otool appbase libmap +installLibs :: FilePath -> [(FilePath, FilePath)] -> LibMap -> IO ([FilePath], [(FilePath, FilePath)], LibMap) +installLibs appbase replacement_libs libmap = do + (needlibs, replacement_libs', libmap') <- otool appbase replacement_libs libmap libs <- forM needlibs $ \lib -> do let shortlib = fromMaybe (error "internal") (M.lookup lib libmap') let fulllib = dropWhile (== '/') lib @@ -54,25 +55,55 @@ _ <- boolSystem "ln" [Param "-s", File fulllib, File symdest] return $ Just appbase ) - return (catMaybes libs, libmap') + return (catMaybes libs, replacement_libs', libmap') {- Returns libraries to install. -} -otool :: FilePath -> LibMap -> IO ([FilePath], LibMap) -otool appbase libmap = do +otool :: FilePath -> [(FilePath, FilePath)] -> LibMap -> IO ([FilePath], [(FilePath, FilePath)], LibMap) +otool appbase replacement_libs libmap = do files <- filterM doesFileExist =<< dirContentsRecursive appbase - process [] files libmap + process [] files replacement_libs libmap where want s = not ("@executable_path" `isInfixOf` s) && not (".framework" `isInfixOf` s) && not ("libSystem.B" `isInfixOf` s) - process c [] m = return (nub $ concat c, m) - process c (file:rest) m = do + process c [] rls m = return (nub $ concat c, rls, m) + process c (file:rest) rls m = do _ <- boolSystem "chmod" [Param "755", File file] libs <- filter want . parseOtool <$> readProcess "otool" ["-L", file] - m' <- install_name_tool file libs m - process (libs:c) rest m' + expanded_libs <- expand_rpath libs replacement_libs file + let rls' = nub $ rls ++ (zip libs expanded_libs) + m' <- install_name_tool file libs expanded_libs m + process (expanded_libs:c) rest rls' m' +{- Expands any @rpath in the list of libraries. + - + - This is done by the nasty method of running the command with a dummy + - option (so it doesn't do anything.. hopefully!) and asking the dynamic + - linker to print expanded rpaths. + -} +expand_rpath :: [String] -> [(FilePath, FilePath)] -> FilePath -> IO [String] +expand_rpath libs replacement_libs cmd + | any ("@rpath" `isInfixOf`) libs = do + installed <- M.fromList . Prelude.read + <$> readFile "tmp/standalone-installed" + let origcmd = case M.lookup cmd installed of + Nothing -> cmd + Just cmd' -> cmd' + s <- catchDefaultIO "" $ readProcess "sh" ["-c", probe origcmd] + let m = if (null s) + then M.fromList replacement_libs + else M.fromList $ mapMaybe parse $ lines s + return $ map (replace m) libs + | otherwise = return libs + where + probe c = "DYLD_PRINT_RPATHS=1 " ++ c ++ " --getting-rpath-dummy-option 2>&1 | grep RPATH" + parse s = case words s of + ("RPATH":"successful":"expansion":"of":old:"to:":new:[]) -> + Just (old, new) + _ -> Nothing + replace m l = fromMaybe l $ M.lookup l m + parseOtool :: String -> [FilePath] parseOtool = catMaybes . map parse . lines where @@ -82,10 +113,10 @@ {- Adjusts binaries to use libraries bundled with it, rather than the - system libraries. -} -install_name_tool :: FilePath -> [FilePath] -> LibMap -> IO LibMap -install_name_tool _ [] libmap = return libmap -install_name_tool binary libs libmap = do - let (libnames, libmap') = getLibNames libs libmap +install_name_tool :: FilePath -> [FilePath] -> [FilePath] -> LibMap -> IO LibMap +install_name_tool _ [] _ libmap = return libmap +install_name_tool binary libs expanded_libs libmap = do + let (libnames, libmap') = getLibNames expanded_libs libmap let params = concatMap change $ zip libs libnames ok <- boolSystem "install_name_tool" $ params ++ [File binary] unless ok $ @@ -123,4 +154,4 @@ main = getArgs >>= go where go [] = error "specify OSXAPP_BASE" - go (appbase:_) = mklibs appbase [] M.empty + go (appbase:_) = mklibs appbase [] [] M.empty diff --git a/Build/Standalone.hs b/Build/Standalone.hs --- a/Build/Standalone.hs +++ b/Build/Standalone.hs @@ -60,12 +60,15 @@ progDir topdir = topdir "bin" #endif -installProg :: FilePath -> FilePath -> IO () +installProg :: FilePath -> FilePath -> IO (FilePath, FilePath) installProg dir prog = searchPath prog >>= go where go Nothing = error $ "cannot find " ++ prog ++ " in PATH" - go (Just f) = unlessM (boolSystem "install" [File f, File dir]) $ - error $ "install failed for " ++ prog + go (Just f) = do + let dest = dir takeFileName f + unlessM (boolSystem "install" [File f, File dest]) $ + error $ "install failed for " ++ prog + return (dest, f) main = getArgs >>= go where @@ -73,5 +76,5 @@ go (topdir:_) = do let dir = progDir topdir createDirectoryIfMissing True dir - forM_ thirdpartyProgs $ installProg dir - + installed <- forM thirdpartyProgs $ installProg dir + writeFile "tmp/standalone-installed" (show installed) diff --git a/Build/Standalone.o b/Build/Standalone.o new file mode 100644 Binary files /dev/null and b/Build/Standalone.o differ diff --git a/Build/SysConfig.o b/Build/SysConfig.o new file mode 100644 Binary files /dev/null and b/Build/SysConfig.o differ diff --git a/Build/TestConfig.o b/Build/TestConfig.o Binary files a/Build/TestConfig.o and b/Build/TestConfig.o differ diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,63 @@ +git-annex (4.20130501) unstable; urgency=low + + * sync, assistant: Behavior changes: Sync with remotes that have + annex-ignore set, so that git remotes on servers without git-annex + installed can be used to keep clients' git repos in sync. + * assistant: Work around misfeature in git 1.8.2 that makes + `git commit --alow-empty -m ""` run an editor. + * sync: Bug fix, avoid adding to the annex the + dummy symlinks used on crippled filesystems. + * Add public repository group. + (And inpreferreddir to preferred content expressions.) + * webapp: Can now set up Internet Archive repositories. + * S3: Dropping content from the Internet Archive doesn't work, but + their API indicates it does. Always refuse to drop from there. + * Automatically register public urls for files uploaded to the + Internet Archive. + * To enable an existing special remote, the new enableremote command + must be used. The initremote command now is used only to create + new special remotes. + * initremote: If two existing remotes have the same name, + prefer the one with a higher trust level. + * assistant: Improved XMPP protocol to better support multiple repositories + using the same XMPP account. Fixes bad behavior when sharing with a friend + when you or the friend have multiple reposotories on an XMPP account. + Note that XMPP pairing with your own devices still pairs with all + repositories using your XMPP account. + * assistant: Fix bug that could cause incoming pushes to not get + merged into the local tree. Particularly affected XMPP pushes. + * webapp: Display some additional information about a repository on + its edit page. + * webapp: Install FDO desktop menu file when started in standalone mode. + * webapp: Don't default to making repository in cwd when started + from within a directory containing a git-annex file (eg, standalone + tarball directory). + * Detect systems that have no user name set in GECOS, and also + don't have user.name set in git config, and put in a workaround + so that commits to the git-annex branch (and the assistant) + will still succeed despite git not liking the system configuration. + * webapp: When told to add a git repository on a remote server, and + the repository already exists as a non-bare repository, use it, + rather than initializing a bare repository in the same directory. + * direct, indirect: Refuse to do anything when the assistant + or git-annex watch daemon is running. + * assistant: When built with git before 1.8.0, use `git remote rm` + to delete a remote. Newer git uses `git remote remove`. + * rmurl: New command, removes one of the recorded urls for a file. + * Detect when the remote is broken like bitbucket is, and exits 0 when + it fails to run git-annex-shell. + * assistant: Several improvements to performance and behavior when + performing bulk adds of a large number of files (tens to hundreds + of thousands). + * assistant: Sanitize XMPP presence information logged for debugging. + * webapp: Now automatically fills in any creds used by an existing remote + when creating a new remote of the same type. Done for Internet Archive, + S3, Glacier, and Box.com remotes. + * Store an annex-uuid file in the bucket when setting up a new S3 remote. + * Support building with DAV 0.4. + + -- Joey Hess Wed, 01 May 2013 01:42:46 -0400 + git-annex (4.20130417) unstable; urgency=low * initremote: Generates encryption keys with high quality entropy. diff --git a/Checks.hs b/Checks.hs --- a/Checks.hs +++ b/Checks.hs @@ -3,7 +3,7 @@ - Common sanity checks for commands, and an interface to selectively - remove them, or add others. - - - Copyright 2011 Joey Hess + - Copyright 2011-2013 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -14,6 +14,7 @@ import Types.Command import Init import Config +import Utility.Daemon import qualified Git commonChecks :: [CommandCheck] @@ -24,11 +25,17 @@ notDirect :: Command -> Command notDirect = addCheck $ whenM isDirect $ - error "You cannot run this subcommand in a direct mode repository." + error "You cannot run this command in a direct mode repository." notBareRepo :: Command -> Command notBareRepo = addCheck $ whenM (fromRepo Git.repoIsLocalBare) $ - error "You cannot run this subcommand in a bare repository." + error "You cannot run this command in a bare repository." + +noDaemonRunning :: Command -> Command +noDaemonRunning = addCheck $ whenM (isJust <$> daemonpid) $ + error "You cannot run this command while git-annex watch or git-annex assistant is running." + where + daemonpid = liftIO . checkDaemon =<< fromRepo gitAnnexPidFile dontCheck :: CommandCheck -> Command -> Command dontCheck check cmd = mutateCheck cmd $ \c -> filter (/= check) c diff --git a/CmdLine.hs b/CmdLine.hs --- a/CmdLine.hs +++ b/CmdLine.hs @@ -24,6 +24,7 @@ import qualified Git.AutoCorrect import Annex.Content import Annex.Ssh +import Annex.Environment import Command type Params = [String] @@ -39,6 +40,7 @@ Right g -> do state <- Annex.new g (actions, state') <- Annex.run state $ do + checkEnvironment checkfuzzy forM_ fields $ uncurry Annex.setField sequence_ flags diff --git a/Command/Add.hs b/Command/Add.hs --- a/Command/Add.hs +++ b/Command/Add.hs @@ -56,12 +56,14 @@ start file = ifAnnexed file addpresent add where add = do - s <- liftIO $ getSymbolicLinkStatus file - if isSymbolicLink s || not (isRegularFile s) - then stop - else do - showStart "add" file - next $ perform file + ms <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus file + case ms of + Nothing -> stop + Just s + | isSymbolicLink s || not (isRegularFile s) -> stop + | otherwise -> do + showStart "add" file + next $ perform file addpresent (key, _) = ifM isDirect ( ifM (goodContent key file) ( stop , add ) , fixup key @@ -120,7 +122,7 @@ case (cache, inodeCache source) of (_, Nothing) -> go k cache (Just newc, Just c) | compareStrong c newc -> go k cache - _ -> failure + _ -> failure "changed while it was being added" where go k cache = ifM isDirect ( godirect k cache , goindirect k cache ) @@ -129,15 +131,16 @@ moveAnnex key $ contentLocation source liftIO $ nukeFile $ keyFilename source return $ Just key - goindirect Nothing _ = failure + goindirect Nothing _ = failure "failed to generate a key" godirect (Just (key, _)) (Just cache) = do addInodeCache key cache finishIngestDirect key source return $ Just key - godirect _ _ = failure + godirect _ _ = failure "failed to generate a key" - failure = do + failure msg = do + warning $ keyFilename source ++ " " ++ msg when (contentLocation source /= keyFilename source) $ liftIO $ nukeFile $ contentLocation source return Nothing diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -156,7 +156,7 @@ | otherwise -> error "bad --pathdepth" where fullurl = uriRegName auth ++ uriPath url ++ uriQuery url - frombits a = join "/" $ a urlbits + frombits a = intercalate "/" $ a urlbits urlbits = map (filesize . escape) $ filter (not . null) $ split "/" fullurl auth = fromMaybe (error $ "bad url " ++ show url) $ uriAuthority url filesize = take 255 diff --git a/Command/Assistant.hs b/Command/Assistant.hs --- a/Command/Assistant.hs +++ b/Command/Assistant.hs @@ -12,7 +12,7 @@ import qualified Option import qualified Command.Watch import Init -import Locations.UserConfig +import Config.Files import System.Environment import System.Posix.Directory diff --git a/Command/Direct.hs b/Command/Direct.hs --- a/Command/Direct.hs +++ b/Command/Direct.hs @@ -17,7 +17,7 @@ import Annex.Version def :: [Command] -def = [notBareRepo $ +def = [notBareRepo $ noDaemonRunning $ command "direct" paramNothing seek SectionSetup "switch repository to direct mode"] diff --git a/Command/EnableRemote.hs b/Command/EnableRemote.hs new file mode 100644 --- /dev/null +++ b/Command/EnableRemote.hs @@ -0,0 +1,56 @@ +{- git-annex command + - + - Copyright 2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.EnableRemote where + +import Common.Annex +import Command +import qualified Logs.Remote +import qualified Types.Remote as R +import qualified Command.InitRemote as InitRemote + +import qualified Data.Map as M + +def :: [Command] +def = [command "enableremote" + (paramPair paramName $ paramOptional $ paramRepeating paramKeyValue) + seek SectionSetup "enables use of an existing special remote"] + +seek :: [CommandSeek] +seek = [withWords start] + +start :: [String] -> CommandStart +start [] = unknownNameError "Specify the name of the special remote to enable." +start (name:ws) = go =<< InitRemote.findExisting name + where + config = Logs.Remote.keyValToConfig ws + + go Nothing = unknownNameError "Unknown special remote name." + go (Just (u, c)) = do + let fullconfig = config `M.union` c + t <- InitRemote.findType fullconfig + + showStart "enableremote" name + next $ perform t u fullconfig + +unknownNameError :: String -> Annex a +unknownNameError prefix = do + names <- InitRemote.remoteNames + error $ prefix ++ + if null names + then "" + else " Known special remotes: " ++ intercalate " " names + +perform :: RemoteType -> UUID -> R.RemoteConfig -> CommandPerform +perform t u c = do + c' <- R.setup t u c + next $ cleanup u c' + +cleanup :: UUID -> R.RemoteConfig -> CommandCleanup +cleanup u c = do + Logs.Remote.configSet u c + return True diff --git a/Command/Help.hs b/Command/Help.hs --- a/Command/Help.hs +++ b/Command/Help.hs @@ -24,7 +24,7 @@ def :: [Command] def = [noCommit $ noRepo showGeneralHelp $ dontCheck repoExists $ - command "help" paramNothing seek SectionUtility "display help"] + command "help" paramNothing seek SectionQuery "display help"] seek :: [CommandSeek] seek = [withWords start] @@ -42,7 +42,7 @@ showGeneralHelp :: IO () showGeneralHelp = putStrLn $ unlines - [ "The most commonly used git-annex commands are:" + [ "The most frequently used git-annex commands are:" , unlines $ map cmdline $ concat [ Command.Init.def , Command.Add.def @@ -54,7 +54,9 @@ , Command.Whereis.def , Command.Fsck.def ] - , "Run git-annex without any options for a complete command list." + , "Run 'git-annex' for a complete command list." + , "Run 'git-annex command --help' for help on a specific command." + , "Run `git annex help options' for a list of common options." ] where cmdline c = "\t" ++ cmdname c ++ "\t" ++ cmddesc c diff --git a/Command/Indirect.hs b/Command/Indirect.hs --- a/Command/Indirect.hs +++ b/Command/Indirect.hs @@ -18,11 +18,13 @@ import Annex.Content import Annex.CatFile import Annex.Version +import Annex.Perms import Init def :: [Command] -def = [notBareRepo $ command "indirect" paramNothing seek - SectionSetup "switch repository to indirect mode"] +def = [notBareRepo $ noDaemonRunning $ + command "indirect" paramNothing seek + SectionSetup "switch repository to indirect mode"] seek :: [CommandSeek] seek = [withNothing start] @@ -79,6 +81,7 @@ fromdirect f k = do showStart "indirect" f + thawContentDir =<< calcRepo (gitAnnexLocation k) cleandirect k -- clean before content directory gets frozen whenM (liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f) $ do moveAnnex k f diff --git a/Command/InitRemote.hs b/Command/InitRemote.hs --- a/Command/InitRemote.hs +++ b/Command/InitRemote.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2011 Joey Hess + - Copyright 2011,2013 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -16,30 +16,30 @@ import qualified Types.Remote as R import Annex.UUID import Logs.UUID +import Logs.Trust +import Data.Ord + def :: [Command] def = [command "initremote" (paramPair paramName $ paramOptional $ paramRepeating paramKeyValue) - seek SectionSetup "sets up a special (non-git) remote"] + seek SectionSetup "creates a special (non-git) remote"] seek :: [CommandSeek] seek = [withWords start] start :: [String] -> CommandStart -start [] = do - names <- remoteNames - error $ "Specify a name for the remote. " ++ - if null names - then "" - else "Either a new name, or one of these existing special remotes: " ++ join " " names -start (name:ws) = do - (u, c) <- findByName name - let fullconfig = config `M.union` c - t <- findType fullconfig - - showStart "initremote" name - next $ perform t u name $ M.union config c +start [] = error "Specify a name for the remote." +start (name:ws) = ifM (isJust <$> findExisting name) + ( error $ "There is already a special remote named \"" ++ name ++ + "\". (Use enableremote to enable an existing special remote.)" + , do + (u, c) <- generateNew name + t <- findType config + showStart "initremote" name + next $ perform t u name $ M.union config c + ) where config = Logs.Remote.keyValToConfig ws @@ -54,18 +54,22 @@ Logs.Remote.configSet u c return True -{- Look up existing remote's UUID and config by name, or generate a new one -} -findByName :: String -> Annex (UUID, R.RemoteConfig) -findByName name = do - m <- Logs.Remote.readRemoteLog - maybe generate return $ findByName' name m - where - generate = do - uuid <- liftIO genUUID - return (uuid, M.insert nameKey name M.empty) +{- See if there's an existing special remote with this name. -} +findExisting :: String -> Annex (Maybe (UUID, R.RemoteConfig)) +findExisting name = do + t <- trustMap + matches <- sortBy (comparing $ \(u, _c) -> M.lookup u t ) + . findByName name + <$> Logs.Remote.readRemoteLog + return $ headMaybe matches -findByName' :: String -> M.Map UUID R.RemoteConfig -> Maybe (UUID, R.RemoteConfig) -findByName' n = headMaybe . filter (matching . snd) . M.toList +generateNew :: String -> Annex (UUID, R.RemoteConfig) +generateNew name = do + uuid <- liftIO genUUID + return (uuid, M.singleton nameKey name) + +findByName :: String -> M.Map UUID R.RemoteConfig -> [(UUID, R.RemoteConfig)] +findByName n = filter (matching . snd) . M.toList where matching c = case M.lookup nameKey c of Nothing -> False diff --git a/Command/RmUrl.hs b/Command/RmUrl.hs new file mode 100644 --- /dev/null +++ b/Command/RmUrl.hs @@ -0,0 +1,30 @@ +{- git-annex command + - + - Copyright 2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.RmUrl where + +import Common.Annex +import Command +import Logs.Web + +def :: [Command] +def = [notBareRepo $ + command "rmurl" (paramPair paramFile paramUrl) seek + SectionCommon "record file is not available at url"] + +seek :: [CommandSeek] +seek = [withPairs start] + +start :: (FilePath, String) -> CommandStart +start (file, url) = flip whenAnnexed file $ \_ (key, _) -> do + showStart "rmurl" file + next $ next $ cleanup url key + +cleanup :: String -> Key -> CommandCleanup +cleanup url key = do + setUrlMissing key url + return True diff --git a/Command/Status.hs b/Command/Status.hs --- a/Command/Status.hs +++ b/Command/Status.hs @@ -57,7 +57,7 @@ type StatState = StateT StatInfo Annex def :: [Command] -def = [command "status" (paramOptional paramPaths) seek +def = [command "status" paramPaths seek SectionQuery "shows status information about the annex"] seek :: [CommandSeek] diff --git a/Command/Sync.hs b/Command/Sync.hs --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -73,15 +73,16 @@ return l available = filter (not . Remote.specialRemote) . filter (remoteAnnexSync . Types.Remote.gitconfig) - <$> Remote.enabledRemoteList + <$> Remote.remoteList good = filterM $ Remote.Git.repoAvail . Types.Remote.repo fastest = fromMaybe [] . headMaybe . Remote.byCost commit :: CommandStart commit = next $ next $ do ifM isDirect - ( ifM stageDirect - ( runcommit [] , return True ) + ( do + void $ stageDirect + runcommit [] , runcommit [Param "-a"] ) where @@ -90,8 +91,9 @@ showOutput Annex.Branch.commit "update" -- Commit will fail when the tree is clean, so ignore failure. - _ <- inRepo $ Git.Command.runBool $ (Param "commit") : ps ++ + let params = (Param "commit") : ps ++ [Param "-m", Param "git-annex automatic sync"] + _ <- inRepo $ tryIO . Git.Command.runQuiet params return True mergeLocal :: Git.Ref -> CommandStart diff --git a/Command/TransferKeys.hs b/Command/TransferKeys.hs --- a/Command/TransferKeys.hs +++ b/Command/TransferKeys.hs @@ -95,7 +95,7 @@ sendRequest :: Transfer -> AssociatedFile -> Handle -> IO () sendRequest t f h = do - hPutStr h $ join fieldSep + hPutStr h $ intercalate fieldSep [ serialize (transferDirection t) , serialize (transferUUID t) , serialize (transferKey t) diff --git a/Command/Version.hs b/Command/Version.hs --- a/Command/Version.hs +++ b/Command/Version.hs @@ -27,12 +27,10 @@ showPackageVersion putStrLn $ "local repository version: " ++ fromMaybe "unknown" v putStrLn $ "default repository version: " ++ defaultVersion - putStrLn $ "supported repository versions: " ++ vs supportedVersions - putStrLn $ "upgrade supported from repository versions: " ++ vs upgradableVersions + putStrLn $ "supported repository versions: " ++ unwords supportedVersions + putStrLn $ "upgrade supported from repository versions: " ++ unwords upgradableVersions putStrLn $ "build flags: " ++ unwords buildFlags stop - where - vs = join " " showPackageVersion :: IO () showPackageVersion = putStrLn $ "git-annex version: " ++ SysConfig.packageversion diff --git a/Command/WebApp.hs b/Command/WebApp.hs --- a/Command/WebApp.hs +++ b/Command/WebApp.hs @@ -15,6 +15,7 @@ import Assistant.Threads.WebApp import Assistant.WebApp import Assistant.Install +import Annex.Environment import Utility.WebApp import Utility.Daemon (checkDaemon) import Init @@ -22,7 +23,7 @@ import qualified Git.Config import qualified Git.CurrentRepo import qualified Annex -import Locations.UserConfig +import Config.Files import qualified Option import System.Posix.Directory @@ -111,6 +112,7 @@ -} firstRun :: Maybe HostName -> IO () firstRun listenhost = do + checkEnvironmentIO {- Without a repository, we cannot have an Annex monad, so cannot - get a ThreadState. Using undefined is only safe because the - webapp checks its noAnnex field before accessing the @@ -135,6 +137,7 @@ mainthread v url htmlshim | isJust listenhost = do putStrLn url + hFlush stdout go | otherwise = do browser <- maybe Nothing webBrowser <$> Git.Config.global @@ -150,8 +153,9 @@ sendurlback v _origout _origerr url _htmlshim = putMVar v url openBrowser :: Maybe FilePath -> FilePath -> Maybe Handle -> Maybe Handle -> IO () -openBrowser cmd htmlshim outh errh = do +openBrowser mcmd htmlshim outh errh = do hPutStrLn (fromMaybe stdout outh) $ "Launching web browser on " ++ url + hFlush stdout environ <- cleanEnvironment (_, _, _, pid) <- createProcess p { env = environ @@ -163,7 +167,9 @@ hPutStrLn (fromMaybe stderr errh) "failed to start web browser" where url = fileUrl htmlshim - p = proc (fromMaybe browserCommand cmd) [htmlshim] + p = case mcmd of + Just cmd -> proc cmd [htmlshim] + Nothing -> browserProc htmlshim {- web.browser is a generic git config setting for a web browser program -} webBrowser :: Git.Repo -> Maybe FilePath diff --git a/Common.hs b/Common.hs --- a/Common.hs +++ b/Common.hs @@ -2,7 +2,7 @@ module Common (module X) where -import Control.Monad as X hiding (join) +import Control.Monad as X import Control.Monad.IfElse as X import Control.Applicative as X import "mtl" Control.Monad.State.Strict as X (liftIO) @@ -10,7 +10,7 @@ import Data.Maybe as X import Data.List as X hiding (head, tail, init, last) -import Data.String.Utils as X +import Data.String.Utils as X hiding (join) import "MissingH" System.Path as X import System.FilePath as X diff --git a/Config/Files.hs b/Config/Files.hs new file mode 100644 --- /dev/null +++ b/Config/Files.hs @@ -0,0 +1,60 @@ +{- git-annex extra config files + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Config.Files where + +import Common +import Utility.TempFile +import Utility.FreeDesktop + +{- ~/.config/git-annex/file -} +userConfigFile :: FilePath -> IO FilePath +userConfigFile file = do + dir <- userConfigDir + return $ dir "git-annex" file + +autoStartFile :: IO FilePath +autoStartFile = userConfigFile "autostart" + +{- Returns anything listed in the autostart file (which may not exist). -} +readAutoStartFile :: IO [FilePath] +readAutoStartFile = do + f <- autoStartFile + nub . map dropTrailingPathSeparator . lines + <$> catchDefaultIO "" (readFile f) + +modifyAutoStartFile :: ([FilePath] -> [FilePath]) -> IO () +modifyAutoStartFile func = do + dirs <- readAutoStartFile + let dirs' = nubBy equalFilePath $ func dirs + when (dirs' /= dirs) $ do + f <- autoStartFile + createDirectoryIfMissing True (parentDir f) + viaTmp writeFile f $ unlines $ dirs' + +{- Adds a directory to the autostart file. -} +addAutoStartFile :: FilePath -> IO () +addAutoStartFile path = modifyAutoStartFile $ (:) path + +{- Removes a directory from the autostart file. -} +removeAutoStartFile :: FilePath -> IO () +removeAutoStartFile path = modifyAutoStartFile $ + filter (not . equalFilePath path) + +{- The path to git-annex is written here; which is useful when cabal + - has installed it to some aweful non-PATH location. -} +programFile :: IO FilePath +programFile = userConfigFile "program" + +{- Returns a command to run for git-annex. -} +readProgramFile :: IO FilePath +readProgramFile = do + programfile <- programFile + catchDefaultIO cmd $ + fromMaybe cmd . headMaybe . lines <$> readFile programfile + where + cmd = "git-annex" diff --git a/Config/Files.o b/Config/Files.o new file mode 100644 Binary files /dev/null and b/Config/Files.o differ diff --git a/Git/Construct.hs b/Git/Construct.hs --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -130,7 +130,8 @@ remoteNamedFromKey :: String -> IO Repo -> IO Repo remoteNamedFromKey k = remoteNamed basename where - basename = join "." $ reverse $ drop 1 $ reverse $ drop 1 $ split "." k + basename = intercalate "." $ + reverse $ drop 1 $ reverse $ drop 1 $ split "." k {- Constructs a new Repo for one of a Repo's remotes using a given - location (ie, an url). -} diff --git a/Git/Queue.hs b/Git/Queue.hs --- a/Git/Queue.hs +++ b/Git/Queue.hs @@ -20,7 +20,6 @@ import qualified Data.Map as M import System.IO import System.Process -import Data.String.Utils import Utility.SafeCommand import Common @@ -151,7 +150,7 @@ runAction repo action@(CommandAction {}) = withHandle StdinHandle createProcessSuccess p $ \h -> do fileEncoding h - hPutStr h $ join "\0" $ getFiles action + hPutStr h $ intercalate "\0" $ getFiles action hClose h where p = (proc "xargs" params) { env = gitEnv repo } diff --git a/GitAnnex.hs b/GitAnnex.hs --- a/GitAnnex.hs +++ b/GitAnnex.hs @@ -30,6 +30,7 @@ import qualified Command.Init import qualified Command.Describe import qualified Command.InitRemote +import qualified Command.EnableRemote import qualified Command.Fsck import qualified Command.Unused import qualified Command.DropUnused @@ -53,6 +54,7 @@ import qualified Command.Vicfg import qualified Command.Sync import qualified Command.AddUrl +import qualified Command.RmUrl import qualified Command.Import import qualified Command.Map import qualified Command.Direct @@ -85,10 +87,12 @@ , Command.Lock.def , Command.Sync.def , Command.AddUrl.def + , Command.RmUrl.def , Command.Import.def , Command.Init.def , Command.Describe.def , Command.InitRemote.def + , Command.EnableRemote.def , Command.Reinject.def , Command.Unannex.def , Command.Uninit.def diff --git a/Limit.hs b/Limit.hs --- a/Limit.hs +++ b/Limit.hs @@ -1,6 +1,6 @@ {- user-specified limits on files to act on - - - Copyright 2011,2012 Joey Hess + - Copyright 2011-2013 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -88,9 +88,9 @@ - once. Also, we use regex-TDFA because it's less buggy in its support - of non-unicode characters. -} matchglob :: String -> Annex.FileInfo -> Bool -matchglob glob (Annex.FileInfo { Annex.matchFile = f }) = +matchglob glob fi = case cregex of - Right r -> case execute r f of + Right r -> case execute r (Annex.matchFile fi) of Right (Just _) -> True _ -> False Left _ -> error $ "failed to compile regex: " ++ regex @@ -137,6 +137,11 @@ check a = lookupFile >=> handle a handle _ Nothing = return False handle a (Just (key, _)) = a key + +{- Limit to content that is in a directory, anywhere in the repository tree -} +limitInDir :: FilePath -> MkLimit +limitInDir dir = const $ Right $ const $ \fi -> return $ + any (== dir) $ splitPath $ takeDirectory $ Annex.matchFile fi {- Adds a limit to skip files not believed to have the specified number - of copies. -} diff --git a/Locations/UserConfig.hs b/Locations/UserConfig.hs deleted file mode 100644 --- a/Locations/UserConfig.hs +++ /dev/null @@ -1,57 +0,0 @@ -{- git-annex user config files - - - - Copyright 2012 Joey Hess - - - - Licensed under the GNU GPL version 3 or higher. - -} - -module Locations.UserConfig where - -import Common -import Utility.TempFile -import Utility.FreeDesktop - -{- ~/.config/git-annex/file -} -userConfigFile :: FilePath -> IO FilePath -userConfigFile file = do - dir <- userConfigDir - return $ dir "git-annex" file - -autoStartFile :: IO FilePath -autoStartFile = userConfigFile "autostart" - -{- Returns anything listed in the autostart file (which may not exist). -} -readAutoStartFile :: IO [FilePath] -readAutoStartFile = do - f <- autoStartFile - nub . lines <$> catchDefaultIO "" (readFile f) - -{- Adds a directory to the autostart file. -} -addAutoStartFile :: FilePath -> IO () -addAutoStartFile path = do - dirs <- readAutoStartFile - when (path `notElem` dirs) $ do - f <- autoStartFile - createDirectoryIfMissing True (parentDir f) - viaTmp writeFile f $ unlines $ dirs ++ [path] - -{- Removes a directory from the autostart file. -} -removeAutoStartFile :: FilePath -> IO () -removeAutoStartFile path = do - dirs <- readAutoStartFile - when (path `elem` dirs) $ do - f <- autoStartFile - createDirectoryIfMissing True (parentDir f) - viaTmp writeFile f $ unlines $ - filter (not . equalFilePath path) dirs - -{- The path to git-annex is written here; which is useful when cabal - - has installed it to some aweful non-PATH location. -} -programFile :: IO FilePath -programFile = userConfigFile "program" - -{- Returns a command to run for git-annex. -} -readProgramFile :: IO FilePath -readProgramFile = do - programfile <- programFile - catchDefaultIO "git-annex" $ readFile programfile diff --git a/Locations/UserConfig.o b/Locations/UserConfig.o deleted file mode 100644 Binary files a/Locations/UserConfig.o and /dev/null differ diff --git a/Logs/PreferredContent.hs b/Logs/PreferredContent.hs --- a/Logs/PreferredContent.hs +++ b/Logs/PreferredContent.hs @@ -30,7 +30,9 @@ import Annex.FileMatcher import Annex.UUID import Types.Group +import Types.Remote (RemoteConfig) import Logs.Group +import Logs.Remote import Types.StandardGroups {- Filename of preferred-content.log. -} @@ -65,8 +67,9 @@ preferredContentMapLoad :: Annex Annex.PreferredContentMap preferredContentMapLoad = do groupmap <- groupMap + configmap <- readRemoteLog m <- simpleMap - . parseLogWithUUID ((Just .) . makeMatcher groupmap) + . parseLogWithUUID ((Just .) . makeMatcher groupmap configmap) <$> Annex.Branch.get preferredContentLog Annex.changeState $ \s -> s { Annex.preferredcontentmap = Just m } return m @@ -79,30 +82,30 @@ - because the configuration is shared amoung repositories and newer - versions of git-annex may add new features. Instead, parse errors - result in a Matcher that will always succeed. -} -makeMatcher :: GroupMap -> UUID -> String -> FileMatcher -makeMatcher groupmap u s - | s == "standard" = standardMatcher groupmap u +makeMatcher :: GroupMap -> M.Map UUID RemoteConfig -> UUID -> String -> FileMatcher +makeMatcher groupmap configmap u expr + | expr == "standard" = standardMatcher groupmap configmap u | null (lefts tokens) = Utility.Matcher.generate $ rights tokens | otherwise = matchAll where - tokens = map (parseToken (limitPresent $ Just u) groupmap) (tokenizeMatcher s) + tokens = exprParser groupmap configmap (Just u) expr {- 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 -> FileMatcher -standardMatcher m u = maybe matchAll (makeMatcher m u . preferredContent) $ - getStandardGroup =<< u `M.lookup` groupsByUUID m +standardMatcher :: GroupMap -> M.Map UUID RemoteConfig -> UUID -> FileMatcher +standardMatcher groupmap configmap u = + maybe matchAll (makeMatcher groupmap configmap u . preferredContent) $ + getStandardGroup =<< u `M.lookup` groupsByUUID groupmap {- Checks if an expression can be parsed, if not returns Just error -} checkPreferredContentExpression :: String -> Maybe String -checkPreferredContentExpression s - | s == "standard" = Nothing - | otherwise = case parsedToMatcher vs of +checkPreferredContentExpression expr + | expr == "standard" = Nothing + | otherwise = case parsedToMatcher tokens of Left e -> Just e Right _ -> Nothing where - vs = map (parseToken (limitPresent Nothing) emptyGroupMap) - (tokenizeMatcher s) + tokens = exprParser emptyGroupMap M.empty Nothing expr {- 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/Trust.hs b/Logs/Trust.hs --- a/Logs/Trust.hs +++ b/Logs/Trust.hs @@ -9,6 +9,7 @@ trustLog, TrustLevel(..), trustGet, + trustMap, trustSet, trustPartition, trustExclude, diff --git a/Logs/Web.hs b/Logs/Web.hs --- a/Logs/Web.hs +++ b/Logs/Web.hs @@ -54,4 +54,7 @@ logChange key webUUID InfoPresent setUrlMissing :: Key -> URLString -> Annex () -setUrlMissing key url = addLog (urlLog key) =<< logNow InfoMissing url +setUrlMissing key url = do + addLog (urlLog key) =<< logNow InfoMissing url + whenM (null <$> getUrls key) $ + logChange key webUUID InfoMissing diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -158,11 +158,12 @@ rm -f tmp/git-annex.dmg.bz2 bzip2 --fast tmp/git-annex.dmg +ANDROID_FLAGS= # Cross compile for Android. # Uses https://github.com/neurocyte/ghc-android android: Build/EvilSplicer echo "Running native build, to get TH splices.." - if [ ! -e dist/setup/setup ]; then $(CABAL) configure -f"-Production" -O0; fi + if [ ! -e dist/setup/setup ]; then $(CABAL) configure -f"-Production $(ANDROID_FLAGS)" -O0; fi mkdir -p tmp if ! $(CABAL) build --ghc-options=-ddump-splices 2> tmp/dump-splices; then tail tmp/dump-splices >&2; exit 1; fi echo "Setting up Android build tree.." @@ -176,13 +177,13 @@ # Some additional dependencies needed by the expanded splices. sed -i 's/^ Build-Depends: / Build-Depends: yesod-routes, yesod-core, shakespeare-css, shakespeare-js, shakespeare, blaze-markup, file-embed, wai-app-static, /' tmp/androidtree/git-annex.cabal # Avoid warnings due to sometimes unused imports added for the splices. - sed -i 's/-Wall/-Wall -fno-warn-unused-imports/' tmp/androidtree/git-annex.cabal + sed -i 's/GHC-Options: \\(.*\\)-Wall/GHC-Options: \\1-Wall -fno-warn-unused-imports /i' tmp/androidtree/git-annex.cabal # Cabal cannot cross compile with custom build type, so workaround. sed -i 's/Build-type: Custom/Build-type: Simple/' tmp/androidtree/git-annex.cabal if [ ! -e tmp/androidtree/dist/setup/setup ]; then \ cd tmp/androidtree; \ cabal configure; \ - $$HOME/.ghc/android-14/arm-linux-androideabi-4.7/arm-linux-androideabi/bin/cabal configure -f'Android Assistant -Pairing'; \ + $$HOME/.ghc/android-14/arm-linux-androideabi-4.7/arm-linux-androideabi/bin/cabal configure -f"Android $(ANDROID_FLAGS)"; \ fi $(MAKE) -C tmp/androidtree git-annex diff --git a/Messages.hs b/Messages.hs --- a/Messages.hs +++ b/Messages.hs @@ -31,7 +31,6 @@ showCustom, showHeader, showRaw, - setupConsole ) where @@ -179,7 +178,7 @@ [ "git-annex:", file, "not found" ] indent :: String -> String -indent = join "\n" . map (\l -> " " ++ l) . lines +indent = intercalate "\n" . map (\l -> " " ++ l) . lines {- Shows a JSON fragment only when in json mode. -} maybeShowJSON :: JSON a => [(String, a)] -> Annex () diff --git a/Remote.hs b/Remote.hs --- a/Remote.hs +++ b/Remote.hs @@ -19,7 +19,6 @@ remoteTypes, remoteList, - enabledRemoteList, specialRemote, remoteMap, uuidDescriptions, @@ -211,7 +210,8 @@ let validtrusteduuids = validuuids `intersect` trusted -- remotes that match uuids that have the key - allremotes <- enabledRemoteList + allremotes <- filter (not . remoteAnnexIgnore . gitconfig) + <$> remoteList let validremotes = remotesWithUUID allremotes validuuids return (sortBy (comparing cost) validremotes, validtrusteduuids) @@ -238,7 +238,7 @@ showTriedRemotes [] = noop showTriedRemotes remotes = showLongNote $ "Unable to access these remotes: " ++ - join ", " (map name remotes) + intercalate ", " (map name remotes) forceTrust :: TrustLevel -> String -> Annex () forceTrust level remotename = do diff --git a/Remote/Bup.hs b/Remote/Bup.hs --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -257,7 +257,7 @@ where bits = split ":" r host = Prelude.head bits - dir = join ":" $ drop 1 bits + dir = intercalate ":" $ drop 1 bits -- "host:~user/dir" is not supported specially by bup; -- "host:dir" is relative to the home directory; -- "host:" goes in ~/.bup diff --git a/Remote/Git.hs b/Remote/Git.hs --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -136,21 +136,14 @@ - returns the updated repo. -} tryGitConfigRead :: Git.Repo -> Annex Git.Repo tryGitConfigRead r - | not $ M.null $ Git.config r = return r -- already read + | haveconfig r = return r -- already read | Git.repoIsSsh r = store $ do v <- onRemote r (pipedsshconfig, Left undefined) "configlist" [] [] - case (v, Git.remoteName r) of - (Right r', _) -> return r' - (Left _, Just n) -> do - {- Is this remote just not available, or does - - it not have git-annex-shell? - - Find out by trying to fetch from the remote. -} - whenM (inRepo $ Git.Command.runBool [Param "fetch", Param "--quiet", Param n]) $ do - let k = "remote." ++ n ++ ".annex-ignore" - warning $ "Remote " ++ n ++ " does not have git-annex installed; setting " ++ k - inRepo $ Git.Command.run [Param "config", Param k, Param "true"] - return r - _ -> return r + case v of + Right r' + | haveconfig r' -> return r' + | otherwise -> configlist_failed + Left _ -> configlist_failed | Git.repoIsHttp r = do headers <- getHttpHeaders store $ safely $ geturlconfig headers @@ -159,6 +152,8 @@ ensureInitialized Annex.getState Annex.repo where + haveconfig = not . M.null . Git.config + -- Reading config can fail due to IO error or -- for other reasons; catch all possible exceptions. safely a = either (const $ return r) return @@ -199,6 +194,18 @@ new : exchange ls new | otherwise = old : exchange ls new + + {- Is this remote just not available, or does + - it not have git-annex-shell? + - Find out by trying to fetch from the remote. -} + configlist_failed = case Git.remoteName r of + Nothing -> return r + Just n -> do + whenM (inRepo $ Git.Command.runBool [Param "fetch", Param "--quiet", Param n]) $ do + let k = "remote." ++ n ++ ".annex-ignore" + warning $ "Remote " ++ n ++ " does not have git-annex installed; setting " ++ k + inRepo $ Git.Command.run [Param "config", Param k, Param "true"] + return r {- Checks if a given remote has the content for a key inAnnex. - If the remote cannot be accessed, or if it cannot determine diff --git a/Remote/Helper/Encryptable.hs b/Remote/Helper/Encryptable.hs --- a/Remote/Helper/Encryptable.hs +++ b/Remote/Helper/Encryptable.hs @@ -123,7 +123,7 @@ storeCipher c (EncryptedCipher t ks) = M.insert "cipher" (toB64 t) $ M.insert "cipherkeys" (showkeys ks) c where - showkeys (KeyIds l) = join "," l + showkeys (KeyIds l) = intercalate "," l {- Extracts an StorableCipher from a remote's configuration. -} extractCipher :: RemoteConfig -> Maybe StorableCipher diff --git a/Remote/List.hs b/Remote/List.hs --- a/Remote/List.hs +++ b/Remote/List.hs @@ -98,10 +98,6 @@ Remote.Git.configRead r | otherwise = return r -{- All remotes that are not ignored. -} -enabledRemoteList :: Annex [Remote] -enabledRemoteList = filter (not . remoteAnnexIgnore . gitconfig) <$> remoteList - {- Checks if a remote is a special remote -} specialRemote :: Remote -> Bool specialRemote r = remotetype r /= Remote.Git.remote diff --git a/Remote/S3.hs b/Remote/S3.hs --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -1,20 +1,21 @@ -{- Amazon S3 remotes. +{- S3 remotes - - - Copyright 2011 Joey Hess + - Copyright 2011-2013 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} -module Remote.S3 (remote) where +module Remote.S3 (remote, iaHost, isIA, isIAHost, iaItemUrl) where import Network.AWS.AWSConnection -import Network.AWS.S3Object +import Network.AWS.S3Object hiding (getStorageClass) import Network.AWS.S3Bucket hiding (size) import Network.AWS.AWSResult import qualified Data.Text as T import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.Map as M import Data.Char +import Network.Socket (HostName) import Common.Annex import Types.Remote @@ -29,7 +30,10 @@ import Creds import Utility.Metered import Annex.Content +import Logs.Web +type Bucket = String + remote :: RemoteType remote = RemoteType { typename = "S3", @@ -53,7 +57,7 @@ storeKey = store this, retrieveKeyFile = retrieve this, retrieveKeyFileCheap = retrieveCheap this, - removeKey = remove this, + removeKey = remove this c, hasKey = checkPresent this, hasKeyCheap = False, whereisKey = Nothing, @@ -67,7 +71,7 @@ } s3Setup :: UUID -> RemoteConfig -> Annex RemoteConfig -s3Setup u c = handlehost $ M.lookup "host" c +s3Setup u c = if isIA c then archiveorg else defaulthost where remotename = fromJust (M.lookup "name" c) defbucket = remotename ++ "-" ++ fromUUID u @@ -79,11 +83,6 @@ , ("bucket", defbucket) ] - handlehost Nothing = defaulthost - handlehost (Just h) - | ".archive.org" `isSuffixOf` map toLower h = archiveorg - | otherwise = defaulthost - use fullconfig = do gitConfigSpecialRemote u fullconfig "s3" "true" setRemoteCredPair fullconfig (AWS.creds u) @@ -97,7 +96,8 @@ archiveorg = do showNote "Internet Archive mode" maybe (error "specify bucket=") (const noop) $ - M.lookup "bucket" archiveconfig + getBucket archiveconfig + writeUUIDFile archiveconfig u use archiveconfig where archiveconfig = @@ -115,42 +115,39 @@ store :: Remote -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool store r k _f p = s3Action r False $ \(conn, bucket) -> - sendAnnex k (void $ remove r k) $ \src -> do - res <- storeHelper (conn, bucket) r k p src - s3Bool res + sendAnnex k (void $ remove' r k) $ \src -> do + ok <- s3Bool =<< storeHelper (conn, bucket) r k p src + -- Store public URL to item in Internet Archive. + when (ok && isIA (config r)) $ + setUrlPresent k (iaKeyUrl r k) + + return ok + storeEncrypted :: Remote -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool storeEncrypted r (cipher, enck) k p = s3Action r False $ \(conn, bucket) -> -- To get file size of the encrypted content, have to use a temp file. -- (An alternative would be chunking to to a constant size.) - withTmp enck $ \tmp -> sendAnnex k (void $ remove r enck) $ \src -> do + withTmp enck $ \tmp -> sendAnnex k (void $ remove' r enck) $ \src -> do liftIO $ encrypt (getGpgOpts r) cipher (feedFile src) $ readBytes $ L.writeFile tmp - res <- storeHelper (conn, bucket) r enck p tmp - s3Bool res + s3Bool =<< storeHelper (conn, bucket) r enck p tmp -storeHelper :: (AWSConnection, String) -> Remote -> Key -> MeterUpdate -> FilePath -> Annex (AWSResult ()) +storeHelper :: (AWSConnection, Bucket) -> Remote -> Key -> MeterUpdate -> FilePath -> Annex (AWSResult ()) storeHelper (conn, bucket) r k p file = do size <- maybe getsize (return . fromIntegral) $ keySize k meteredBytes (Just p) size $ \meterupdate -> liftIO $ withMeteredFile file meterupdate $ \content -> do -- size is provided to S3 so the whole content -- does not need to be buffered to calculate it - let object = setStorageClass storageclass $ S3Object + let object = S3Object bucket (bucketFile r k) "" - (("Content-Length", show size) : xheaders) + (("Content-Length", show size) : getXheaders (config r)) content - sendObject conn object + sendObject conn $ + setStorageClass (getStorageClass $ config r) object where - storageclass = - case fromJust $ M.lookup "storageclass" $ config r of - "REDUCED_REDUNDANCY" -> REDUCED_REDUNDANCY - _ -> STANDARD - getsize = liftIO $ fromIntegral . fileSize <$> getFileStatus file - - xheaders = filter isxheader $ M.assocs $ config r - isxheader (h, _) = "x-amz-" `isPrefixOf` h retrieve :: Remote -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool retrieve r k _f d p = s3Action r False $ \(conn, bucket) -> @@ -177,11 +174,20 @@ return True Left e -> s3Warning e -remove :: Remote -> Key -> Annex Bool -remove r k = s3Action r False $ \(conn, bucket) -> do - res <- liftIO $ deleteObject conn $ bucketKey r bucket k - s3Bool res +{- Internet Archive doesn't easily allow removing content. + - While it may remove the file, there are generally other files + - derived from it that it does not remove. -} +remove :: Remote -> RemoteConfig -> Key -> Annex Bool +remove r c k + | isIA c = do + warning "Cannot remove content from the Internet Archive" + return False + | otherwise = remove' r k +remove' :: Remote -> Key -> Annex Bool +remove' r k = s3Action r False $ \(conn, bucket) -> + s3Bool =<< liftIO (deleteObject conn $ bucketKey r bucket k) + checkPresent :: Remote -> Key -> Annex (Either String Bool) checkPresent r k = s3Action r noconn $ \(conn, bucket) -> do showAction $ "checking " ++ name r @@ -205,7 +211,7 @@ s3Bool (Right _) = return True s3Bool (Left e) = s3Warning e -s3Action :: Remote -> a -> ((AWSConnection, String) -> Annex a) -> Annex a +s3Action :: Remote -> a -> ((AWSConnection, Bucket) -> Annex a) -> Annex a s3Action r noconn action = do let bucket = M.lookup "bucket" $ config r conn <- s3Connection (config r) (uuid r) @@ -217,12 +223,14 @@ bucketFile r = munge . key2file where munge s = case M.lookup "mungekeys" c of - Just "ia" -> iaMunge $ fileprefix ++ s - _ -> fileprefix ++ s - fileprefix = M.findWithDefault "" "fileprefix" c + Just "ia" -> iaMunge $ filePrefix c ++ s + _ -> filePrefix c ++ s c = config r -bucketKey :: Remote -> String -> Key -> S3Object +filePrefix :: RemoteConfig -> String +filePrefix = M.findWithDefault "" "fileprefix" + +bucketKey :: Remote -> Bucket -> Key -> S3Object bucketKey r bucket k = S3Object bucket (bucketFile r k) "" [] L.empty {- Internet Archive limits filenames to a subset of ascii, @@ -243,18 +251,43 @@ showAction "checking bucket" loc <- liftIO $ getBucketLocation conn bucket case loc of - Right _ -> noop + Right _ -> writeUUIDFile c u Left err@(NetworkError _) -> s3Error err Left (AWSError _ _) -> do showAction $ "creating bucket in " ++ datacenter res <- liftIO $ createBucketIn conn bucket datacenter case res of - Right _ -> noop + Right _ -> writeUUIDFile c u Left err -> s3Error err where - bucket = fromJust $ M.lookup "bucket" c + bucket = fromJust $ getBucket c datacenter = fromJust $ M.lookup "datacenter" c +{- Writes the UUID to an annex-uuid file within the bucket. + - + - If the file already exists in the bucket, it must match. + - + - Note that IA items do not get created by createBucketIn. + - Rather, they are created the first time a file is stored in them. + - So this also takes care of that. + -} +writeUUIDFile :: RemoteConfig -> UUID -> Annex () +writeUUIDFile c u = do + conn <- s3ConnectionRequired c u + go conn =<< liftIO (tryNonAsync $ getObject conn $ mkobject L.empty) + where + go _conn (Right (Right o)) = unless (obj_data o == uuidb) $ + error $ "This bucket is already in use by a different S3 special remote, with UUID: " ++ L.unpack (obj_data o) + go conn _ = do + let object = setStorageClass (getStorageClass c) (mkobject uuidb) + either s3Error return =<< liftIO (sendObject conn object) + + file = filePrefix c ++ "annex-uuid" + uuidb = L.pack $ fromUUID u + bucket = fromJust $ getBucket c + + mkobject = S3Object bucket file "" (getXheaders c) + s3ConnectionRequired :: RemoteConfig -> UUID -> Annex AWSConnection s3ConnectionRequired c u = maybe (error "Cannot connect to S3") return =<< s3Connection c u @@ -270,3 +303,34 @@ case reads s of [(p, _)] -> p _ -> error $ "bad S3 port value: " ++ s + +getBucket :: RemoteConfig -> Maybe Bucket +getBucket = M.lookup "bucket" + +getStorageClass :: RemoteConfig -> StorageClass +getStorageClass c = case fromJust $ M.lookup "storageclass" c of + "REDUCED_REDUNDANCY" -> REDUCED_REDUNDANCY + _ -> STANDARD + +getXheaders :: RemoteConfig -> [(String, String)] +getXheaders = filter isxheader . M.assocs + where + isxheader (h, _) = "x-amz-" `isPrefixOf` h + +{- Hostname to use for archive.org S3. -} +iaHost :: HostName +iaHost = "s3.us.archive.org" + +isIA :: RemoteConfig -> Bool +isIA c = maybe False isIAHost (M.lookup "host" c) + +isIAHost :: HostName -> Bool +isIAHost h = ".archive.org" `isSuffixOf` map toLower h + +iaItemUrl :: Bucket -> URLString +iaItemUrl bucket = "http://archive.org/details/" ++ bucket + +iaKeyUrl :: Remote -> Key -> URLString +iaKeyUrl r k = "http://archive.org/download/" ++ bucket ++ "/" ++ bucketFile r k + where + bucket = fromMaybe "" $ getBucket $ config r diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs --- a/Remote/WebDAV.hs +++ b/Remote/WebDAV.hs @@ -7,7 +7,7 @@ {-# LANGUAGE ScopedTypeVariables, CPP #-} -module Remote.WebDAV (remote, davCreds, setCredsEnv) where +module Remote.WebDAV (remote, davCreds, setCredsEnv, configUrl) where import Network.Protocol.HTTP.DAV import qualified Data.Map as M @@ -203,11 +203,14 @@ davAction :: Remote -> a -> ((DavUrl, DavUser, DavPass) -> Annex a) -> Annex a davAction r unconfigured action = do mcreds <- getCreds (config r) (uuid r) - case (mcreds, M.lookup "url" $ config r) of + case (mcreds, configUrl r) of (Just (user, pass), Just url) -> action (url, toDavUser user, toDavPass pass) _ -> return unconfigured +configUrl :: Remote -> Maybe DavUrl +configUrl r = M.lookup "url" $ config r + toDavUser :: String -> DavUser toDavUser = B8.fromString @@ -228,7 +231,7 @@ davUrl baseurl file = baseurl file davUrlExists :: DavUrl -> DavUser -> DavPass -> IO (Either String Bool) -davUrlExists url user pass = decode <$> catchHttp (getProps url user pass) +davUrlExists url user pass = decode <$> catchHttp get where decode (Right _) = Right True #if ! MIN_VERSION_http_conduit(1,9,0) @@ -238,6 +241,11 @@ #endif | statusCode status == statusCode notFound404 = Right False decode (Left e) = Left $ showEitherException e +#if ! MIN_VERSION_DAV(0,4,0) + get = getProps url user pass +#else + get = getProps url user pass Nothing +#endif davGetUrlContent :: DavUrl -> DavUser -> DavPass -> IO (Maybe L.ByteString) davGetUrlContent url user pass = fmap (snd . snd) <$> diff --git a/Setup.o b/Setup.o Binary files a/Setup.o and b/Setup.o differ diff --git a/Test.hs b/Test.hs --- a/Test.hs +++ b/Test.hs @@ -730,15 +730,17 @@ Utility.Gpg.testTestHarness @? "test harness self-test failed" Utility.Gpg.testHarness $ do createDirectory "dir" - let initremote = git_annex "initremote" + let a cmd = git_annex cmd [ "foo" , "type=directory" , "encryption=" ++ Utility.Gpg.testKeyId , "directory=dir" , "highRandomQuality=false" ] - initremote @? "initremote failed" - initremote @? "initremote failed when run twice in a row" + a "initremote" @? "initremote failed" + not <$> a "initremote" @? "initremote failed to fail when run twice in a row" + a "enableremote" @? "enableremote failed" + a "enableremote" @? "enableremote failed when run twice in a row" git_annex "get" [annexedfile] @? "get of file failed" annexed_present annexedfile git_annex "copy" [annexedfile, "--to", "foo"] @? "copy --to encrypted remote failed" diff --git a/Types/StandardGroups.hs b/Types/StandardGroups.hs --- a/Types/StandardGroups.hs +++ b/Types/StandardGroups.hs @@ -7,6 +7,11 @@ module Types.StandardGroups where +import Types.Remote (RemoteConfig) + +import qualified Data.Map as M +import Data.Maybe + data StandardGroup = ClientGroup | TransferGroup @@ -16,6 +21,7 @@ | FullArchiveGroup | SourceGroup | ManualGroup + | PublicGroup | UnwantedGroup deriving (Eq, Ord, Enum, Bounded, Show) @@ -28,6 +34,7 @@ fromStandardGroup FullArchiveGroup = "archive" fromStandardGroup SourceGroup = "source" fromStandardGroup ManualGroup = "manual" +fromStandardGroup PublicGroup = "public" fromStandardGroup UnwantedGroup = "unwanted" toStandardGroup :: String -> Maybe StandardGroup @@ -39,6 +46,7 @@ toStandardGroup "archive" = Just FullArchiveGroup toStandardGroup "source" = Just SourceGroup toStandardGroup "manual" = Just ManualGroup +toStandardGroup "public" = Just PublicGroup toStandardGroup "unwanted" = Just UnwantedGroup toStandardGroup _ = Nothing @@ -52,7 +60,16 @@ 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" +descStandardGroup PublicGroup = "public: publishes files located in an associated directory" +associatedDirectory :: Maybe RemoteConfig -> StandardGroup -> Maybe FilePath +associatedDirectory _ SmallArchiveGroup = Just "archive" +associatedDirectory _ FullArchiveGroup = Just "archive" +associatedDirectory (Just c) PublicGroup = Just $ + fromMaybe "public" $ M.lookup "preferreddir" c +associatedDirectory Nothing PublicGroup = Just "public" +associatedDirectory _ _ = Nothing + {- See doc/preferred_content.mdwn for explanations of these expressions. -} preferredContent :: StandardGroup -> String preferredContent ClientGroup = lastResort $ @@ -67,6 +84,7 @@ preferredContent FullArchiveGroup = lastResort notArchived preferredContent SourceGroup = "not (copies=1)" preferredContent ManualGroup = "present and (" ++ preferredContent ClientGroup ++ ")" +preferredContent PublicGroup = "inpreferreddir" preferredContent UnwantedGroup = "exclude=*" notArchived :: String diff --git a/Upgrade/V1.hs b/Upgrade/V1.hs --- a/Upgrade/V1.hs +++ b/Upgrade/V1.hs @@ -143,7 +143,7 @@ -- as the v2 key that it is. readKey1 :: String -> Key readKey1 v - | mixup = fromJust $ file2key $ join ":" $ Prelude.tail bits + | mixup = fromJust $ file2key $ intercalate ":" $ Prelude.tail bits | otherwise = Key { keyName = n , keyBackendName = b @@ -153,7 +153,7 @@ where bits = split ":" v b = Prelude.head bits - n = join ":" $ drop (if wormy then 3 else 1) bits + n = intercalate ":" $ drop (if wormy then 3 else 1) bits t = if wormy then Just (Prelude.read (bits !! 1) :: EpochTime) else Nothing @@ -165,7 +165,7 @@ showKey1 :: Key -> String showKey1 Key { keyName = n , keyBackendName = b, keySize = s, keyMtime = t } = - join ":" $ filter (not . null) [b, showifhere t, showifhere s, n] + intercalate ":" $ filter (not . null) [b, showifhere t, showifhere s, n] where showifhere Nothing = "" showifhere (Just v) = show v diff --git a/Utility/Directory.o b/Utility/Directory.o Binary files a/Utility/Directory.o and b/Utility/Directory.o differ diff --git a/Utility/Lsof.hs b/Utility/Lsof.hs --- a/Utility/Lsof.hs +++ b/Utility/Lsof.hs @@ -32,7 +32,7 @@ when (isAbsolute cmd) $ do path <- getSearchPath let path' = takeDirectory cmd : path - setEnv "PATH" (join [searchPathSeparator] path') True + setEnv "PATH" (intercalate [searchPathSeparator] path') True {- Checks each of the files in a directory to find open files. - Note that this will find hard links to files elsewhere that are open. -} diff --git a/Utility/Rsync.hs b/Utility/Rsync.hs --- a/Utility/Rsync.hs +++ b/Utility/Rsync.hs @@ -22,7 +22,7 @@ {- rsync requires some weird, non-shell like quoting in - here. A doubled single quote inside the single quoted - string is a single quote. -} - escape s = "'" ++ join "''" (split "'" s) ++ "'" + escape s = "'" ++ intercalate "''" (split "'" s) ++ "'" {- Runs rsync in server mode to send a file. -} rsyncServerSend :: [CommandParam] -> FilePath -> IO Bool diff --git a/Utility/SafeCommand.o b/Utility/SafeCommand.o Binary files a/Utility/SafeCommand.o and b/Utility/SafeCommand.o differ diff --git a/Utility/TList.hs b/Utility/TList.hs new file mode 100644 --- /dev/null +++ b/Utility/TList.hs @@ -0,0 +1,59 @@ +{- Transactional lists + - + - Based on DLists, a transactional list can quickly and efficiently + - have items inserted at either end, or a whole list appended to it. + - + - Copyright 2013 Joey Hess + -} + +{-# LANGUAGE BangPatterns #-} + +module Utility.TList where + +import Common + +import Control.Concurrent.STM +import qualified Data.DList as D + +type TList a = TMVar (D.DList a) + +newTList :: STM (TList a) +newTList = newEmptyTMVar + +{- Gets the contents of the TList. Blocks when empty. + - TList is left empty. -} +getTList :: TList a -> STM [a] +getTList tlist = D.toList <$> takeTMVar tlist + +{- Takes anything currently in the TList, without blocking. + - TList is left empty. -} +takeTList :: TList a -> STM [a] +takeTList tlist = maybe [] D.toList <$> tryTakeTMVar tlist + +{- Reads anything in the list, without modifying it, or blocking. -} +readTList :: TList a -> STM [a] +readTList tlist = maybe [] D.toList <$> tryReadTMVar tlist + +{- Mutates a TList. -} +modifyTList :: TList a -> (D.DList a -> D.DList a) -> STM () +modifyTList tlist a = do + dl <- fromMaybe D.empty <$> tryTakeTMVar tlist + let !dl' = a dl + {- The TMVar is left empty when the list is empty. + - Thus attempts to read it automatically block. -} + unless (emptyDList dl') $ + putTMVar tlist dl' + where + emptyDList = D.list True (\_ _ -> False) + +consTList :: TList a -> a -> STM () +consTList tlist v = modifyTList tlist $ \dl -> D.cons v dl + +snocTList :: TList a -> a -> STM () +snocTList tlist v = modifyTList tlist $ \dl -> D.snoc dl v + +appendTList :: TList a -> [a] -> STM () +appendTList tlist l = modifyTList tlist $ \dl -> D.append dl (D.fromList l) + +setTList :: TList a -> [a] -> STM () +setTList tlist l = modifyTList tlist $ const $ D.fromList l diff --git a/Utility/TSet.hs b/Utility/TSet.hs deleted file mode 100644 --- a/Utility/TSet.hs +++ /dev/null @@ -1,41 +0,0 @@ -{- Transactional sets - - - - Copyright 2012, 2013 Joey Hess - -} - -module Utility.TSet where - -import Common - -import Control.Concurrent.STM - -type TSet = TChan - -newTSet :: STM (TSet a) -newTSet = newTChan - -{- Gets the contents of the TSet. Blocks until at least one item is - - present. -} -getTSet :: TSet a -> STM [a] -getTSet tset = do - c <- readTChan tset - l <- readTSet tset - return $ c:l - -{- Gets anything currently in the TSet, without blocking. -} -readTSet :: TSet a -> STM [a] -readTSet tset = go [] - where - go l = do - v <- tryReadTChan tset - case v of - Nothing -> return l - Just c -> go (c:l) - -{- Puts items into a TSet. -} -putTSet :: TSet a -> [a] -> STM () -putTSet tset vs = mapM_ (writeTChan tset) vs - -{- Put a single item into a TSet. -} -putTSet1 :: TSet a -> a -> STM () -putTSet1 tset v = void $ writeTChan tset v diff --git a/Utility/TempFile.o b/Utility/TempFile.o Binary files a/Utility/TempFile.o and b/Utility/TempFile.o differ diff --git a/Utility/WebApp.hs b/Utility/WebApp.hs --- a/Utility/WebApp.hs +++ b/Utility/WebApp.hs @@ -40,12 +40,17 @@ localhost :: HostName localhost = "localhost" -{- Command to use to run a web browser. -} -browserCommand :: FilePath +{- Builds a command to use to start or open a web browser showing an url. -} +browserProc :: String -> CreateProcess #ifdef darwin_HOST_OS -browserCommand = "open" +browserProc url = proc "open" [url] #else -browserCommand = "xdg-open" +#ifdef __ANDROID__ +browserProc url = proc "am" + ["start", "-a", "android.intent.action.VIEW", "-d", url] +#else +browserProc url = proc "xdg-open" [url] +#endif #endif {- Binds to a socket on localhost, or possibly a different specified diff --git a/Utility/libkqueue.c b/Utility/libkqueue.c --- a/Utility/libkqueue.c +++ b/Utility/libkqueue.c @@ -10,6 +10,7 @@ #include #include #include +#include #include #include #include diff --git a/debian/changelog b/debian/changelog --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,63 @@ +git-annex (4.20130501) unstable; urgency=low + + * sync, assistant: Behavior changes: Sync with remotes that have + annex-ignore set, so that git remotes on servers without git-annex + installed can be used to keep clients' git repos in sync. + * assistant: Work around misfeature in git 1.8.2 that makes + `git commit --alow-empty -m ""` run an editor. + * sync: Bug fix, avoid adding to the annex the + dummy symlinks used on crippled filesystems. + * Add public repository group. + (And inpreferreddir to preferred content expressions.) + * webapp: Can now set up Internet Archive repositories. + * S3: Dropping content from the Internet Archive doesn't work, but + their API indicates it does. Always refuse to drop from there. + * Automatically register public urls for files uploaded to the + Internet Archive. + * To enable an existing special remote, the new enableremote command + must be used. The initremote command now is used only to create + new special remotes. + * initremote: If two existing remotes have the same name, + prefer the one with a higher trust level. + * assistant: Improved XMPP protocol to better support multiple repositories + using the same XMPP account. Fixes bad behavior when sharing with a friend + when you or the friend have multiple reposotories on an XMPP account. + Note that XMPP pairing with your own devices still pairs with all + repositories using your XMPP account. + * assistant: Fix bug that could cause incoming pushes to not get + merged into the local tree. Particularly affected XMPP pushes. + * webapp: Display some additional information about a repository on + its edit page. + * webapp: Install FDO desktop menu file when started in standalone mode. + * webapp: Don't default to making repository in cwd when started + from within a directory containing a git-annex file (eg, standalone + tarball directory). + * Detect systems that have no user name set in GECOS, and also + don't have user.name set in git config, and put in a workaround + so that commits to the git-annex branch (and the assistant) + will still succeed despite git not liking the system configuration. + * webapp: When told to add a git repository on a remote server, and + the repository already exists as a non-bare repository, use it, + rather than initializing a bare repository in the same directory. + * direct, indirect: Refuse to do anything when the assistant + or git-annex watch daemon is running. + * assistant: When built with git before 1.8.0, use `git remote rm` + to delete a remote. Newer git uses `git remote remove`. + * rmurl: New command, removes one of the recorded urls for a file. + * Detect when the remote is broken like bitbucket is, and exits 0 when + it fails to run git-annex-shell. + * assistant: Several improvements to performance and behavior when + performing bulk adds of a large number of files (tens to hundreds + of thousands). + * assistant: Sanitize XMPP presence information logged for debugging. + * webapp: Now automatically fills in any creds used by an existing remote + when creating a new remote of the same type. Done for Internet Archive, + S3, Glacier, and Box.com remotes. + * Store an annex-uuid file in the bucket when setting up a new S3 remote. + * Support building with DAV 0.4. + + -- Joey Hess Wed, 01 May 2013 01:42:46 -0400 + git-annex (4.20130417) unstable; urgency=low * initremote: Generates encryption keys with high quality entropy. diff --git a/debian/control b/debian/control --- a/debian/control +++ b/debian/control @@ -17,6 +17,7 @@ libghc-quickcheck2-dev, libghc-monad-control-dev (>= 0.3), libghc-lifted-base-dev, + libghc-dlist-dev, libghc-uuid-dev, libghc-json-dev, libghc-ifelse-dev, diff --git a/doc/assistant/iaitem.png b/doc/assistant/iaitem.png new file mode 100644 Binary files /dev/null and b/doc/assistant/iaitem.png differ diff --git a/doc/assistant/inotify_max_limit_alert.png b/doc/assistant/inotify_max_limit_alert.png new file mode 100644 Binary files /dev/null and b/doc/assistant/inotify_max_limit_alert.png differ diff --git a/doc/assistant/release_notes.mdwn b/doc/assistant/release_notes.mdwn --- a/doc/assistant/release_notes.mdwn +++ b/doc/assistant/release_notes.mdwn @@ -1,3 +1,23 @@ +## version 4.20130501 + +This version contains numerous bug fixes, and improvements. + +## version 4.20130417 + +This version contains numerous bug fixes, and improvements. + +One bug that was fixed can affect users of gnome-keyring who +have set up remote repositories on ssh servers using the webapp. +The gnome-keyring may load the restricted key that is set up +for that, and make it be used for regular logins to the server; +with the result that you'll get an error message about "git-annex-shell" +when sshing to the server. + +If you experience this problem you can fix it by +moving `.ssh/key.git-annex*` to `.ssh/git-annex/` (creating +that directory first), and edit `.ssh/config` to reflect the new +location of the key. You will also need to restart gnome-keyring. + ## version 4.20130323, 4.20130405 These versions continue fixing bugs and adding features. diff --git a/doc/bugs.mdwn b/doc/bugs.mdwn --- a/doc/bugs.mdwn +++ b/doc/bugs.mdwn @@ -1,6 +1,18 @@ -This is git-annex's bug list. Link bugs to [[bugs/done]] when done. +This is git-annex's bug list. +[[!sidebar content=""" +[[!inline feeds=no template=bare pages=sidebar]] + +Bugs not show here: + +* [[Bugs_affecting_the_assistant|design/assistant/todo]] +* [[Bugs_needing_more_info|moreinfo]] +* [[Closed_bugs|bugs/done]] +""" +]] + [[!inline pages="./bugs/* and !./bugs/*/* and !./bugs/done and !link(done) +and !./bugs/moreinfo and !link(moreinfo) and !*/Discussion" actions=yes postform=yes show=0 archive=yes]] [[!edittemplate template=templates/bugtemplate match="bugs/*" silent=yes]] diff --git a/doc/bugs/Adding_second_remote_repository_over_ssh_fails.mdwn b/doc/bugs/Adding_second_remote_repository_over_ssh_fails.mdwn --- a/doc/bugs/Adding_second_remote_repository_over_ssh_fails.mdwn +++ b/doc/bugs/Adding_second_remote_repository_over_ssh_fails.mdwn @@ -35,3 +35,7 @@ > So, I'm going to repurpose this bug to track that problem. --[[Joey]] [[!meta title="assistant can fail to make git repository if remote server is lacking GECOS"]] + +>> [[done]]; git-annex always checks for missing gecos and enables +>> a workaround. This does mean the server needs to be upgraded in order +>> for the fix to work. --[[Joey]] diff --git a/doc/bugs/Files_disappear_from_locally_paired_annexes_when_edited.mdwn b/doc/bugs/Files_disappear_from_locally_paired_annexes_when_edited.mdwn --- a/doc/bugs/Files_disappear_from_locally_paired_annexes_when_edited.mdwn +++ b/doc/bugs/Files_disappear_from_locally_paired_annexes_when_edited.mdwn @@ -32,3 +32,5 @@ **Please provide any additional information below.** I have observed this problem setting up the repos through the webapp as well, so I don't think it is related to setting up the repos manually. I think the way vim is writing the files seems to be tickling a race condition (both command-line vim and MacVim produce the behavior). I started trying to work around it by switching to emacs to edit those files, and the files haven't disappeared from the edited repo (so far at least). + +[[!tag /design/assistant moreinfo]] diff --git a/doc/bugs/Issue_on_OSX_with_some_system_limits.mdwn b/doc/bugs/Issue_on_OSX_with_some_system_limits.mdwn --- a/doc/bugs/Issue_on_OSX_with_some_system_limits.mdwn +++ b/doc/bugs/Issue_on_OSX_with_some_system_limits.mdwn @@ -22,3 +22,5 @@ > This affects BSD systems that use Kqueue. It no longer affects OSX, > since we use FSEvents there instead. --[[Joey]] + +[[!tag /design/assistant]] diff --git a/doc/bugs/It_is_very_easy_to_turn_git-annex_into_a_zombie.mdwn b/doc/bugs/It_is_very_easy_to_turn_git-annex_into_a_zombie.mdwn --- a/doc/bugs/It_is_very_easy_to_turn_git-annex_into_a_zombie.mdwn +++ b/doc/bugs/It_is_very_easy_to_turn_git-annex_into_a_zombie.mdwn @@ -22,4 +22,4 @@ Please provide any additional information below. [[!meta title="strange OSX behavior when killed"]] -[[!tag /design/assistant/OSX unreproducible]] +[[!tag /design/assistant/OSX moreinfo]] diff --git a/doc/bugs/OSX_app_issues/comment_12_62170597c7f441d84d48986857998858._comment b/doc/bugs/OSX_app_issues/comment_12_62170597c7f441d84d48986857998858._comment new file mode 100644 --- /dev/null +++ b/doc/bugs/OSX_app_issues/comment_12_62170597c7f441d84d48986857998858._comment @@ -0,0 +1,10 @@ +[[!comment format=mdwn + username="https://www.google.com/accounts/o8/id?id=AItOawkCw26IdxXXPBoLcZsQFslM67OJSJynb1w" + nickname="Alexander" + subject="standalone app dmg won't open in OSX 10.8.3" + date="2013-04-29T18:05:54Z" + content=""" +I downloaded the app build from [http://downloads.kitenet.net/git-annex/OSX/current/10.8.2_Mountain_Lion/](http://downloads.kitenet.net/git-annex/OSX/current/10.8.2_Mountain_Lion/) and unpacked it, but the .dmg won't open. I can run other dmg's successfully. + +Trying to install git-annex via cabal on the same machine led to this issue: [http://git-annex.branchable.com/tips/Building_git-annex_on_Debian_OR___37____164____35____34____164____37____38____34____35___Haskell__33__/#comment-7cc94df1bf9a75a6d03369f3897d6816](http://git-annex.branchable.com/tips/Building_git-annex_on_Debian_OR___37____164____35____34____164____37____38____34____35___Haskell__33__/#comment-7cc94df1bf9a75a6d03369f3897d6816) +"""]] diff --git a/doc/bugs/Out_of_memory_error_in_fsck_whereis_find_and_status_cmds.mdwn b/doc/bugs/Out_of_memory_error_in_fsck_whereis_find_and_status_cmds.mdwn --- a/doc/bugs/Out_of_memory_error_in_fsck_whereis_find_and_status_cmds.mdwn +++ b/doc/bugs/Out_of_memory_error_in_fsck_whereis_find_and_status_cmds.mdwn @@ -76,3 +76,5 @@ Thanks Giovanni + +[[!tag moreinfo]] diff --git a/doc/bugs/Repository_deletion_error.mdwn b/doc/bugs/Repository_deletion_error.mdwn new file mode 100644 --- /dev/null +++ b/doc/bugs/Repository_deletion_error.mdwn @@ -0,0 +1,46 @@ +**What steps will reproduce the problem?** + +On the dashboard, click settings > Delete on the repo you want to remove. +Wait for the dropping to finish. +Start final deletion when the message "The repository "repo" has been emptied, and can now be removed." pops up. + +**What is the expected output? What do you see instead?** + +The repository should be deleted, but I only see "Internal Server Error: git [Param "remote",Param "remove",Param "repo"] failed". + +**What version of git-annex are you using? On what operating system?** + +Standalone build, git-annex version 4.20130417-g4bb97d5 + +**Please provide any additional information below.** + +The log shows: + + [2013-04-22 22:17:22 CEST] TransferScanner: The repository "repo" has been emptied, and can now be removed. + error: Unknown subcommand: remove + usage: git remote [-v | --verbose] + or: git remote add [-t ] [-m ] [-f] [--mirror=] + or: git remote rename + or: git remote rm + or: git remote set-head (-a | -d | ) + or: git remote [-v | --verbose] show [-n] + or: git remote prune [-n | --dry-run] + or: git remote [-v | --verbose] update [-p | --prune] [( | )...] + or: git remote set-branches [--add] ... + or: git remote set-url [] + or: git remote set-url --add + or: git remote set-url --delete + + -v, --verbose be verbose; must be placed before a subcommand + + + +> Seems that `git remote remove` is new as of git 1.8.0 or so. +> Older gits only support `git remote rm`. Which newer gits +> support as well. but it seems to be in the process +> of being deprecated so I'd rather not use it. +> +> So, I've made the version of git it's +> built for determine which subcommand it uses. [[done]] --[[Joey]] +> +> (You can run `git remote rm repo` by hand to clean up from this BTW.) diff --git a/doc/bugs/Resource_exhausted.mdwn b/doc/bugs/Resource_exhausted.mdwn new file mode 100644 --- /dev/null +++ b/doc/bugs/Resource_exhausted.mdwn @@ -0,0 +1,45 @@ +What steps will reproduce the problem? +My annex dir has 23459 files and uses 749MB disk space. +Just create a repository put this dir inside, and git-annex will crash. + +What is the expected output? What do you see instead? +I expect git-annex handles large number of files, and does not watch every single file of it. + +What version of git-annex are you using? On what operating system? +I'm using git-annex linux build, version 2013.04.17. + +Please provide any additional information below. + + [2013-04-17 23:52:35 CEST] Transferrer: Downloaded pappas_hu..di_44.jpg + git-annex: runInteractiveProcess: pipe: Too many open files + Committer crashed: lsof: createProcess: resource exhausted (Too many open files) + [2013-04-17 23:53:52 CEST] Committer: warning Committer crashed: lsof: createProcess: resource exhausted (Too many open files) + git-annex: runInteractiveProcess: pipe: Too many open files + git: createProcess: resource exhausted (Too many open files) + DaemonStatus crashed: /home/user/Desktop/down/annex_test/.git/annex/daemon.status.tmp21215: openFile: resource exhausted (Too many open files) + [2013-04-17 23:57:24 CEST] DaemonStatus: warning DaemonStatus crashed: /home/user/Desktop/down/annex_test/.git/annex/daemon.status.tmp21215: openFile: resource exhausted (Too many open files) + git-annex: runInteractiveProcess: pipe: Too many open files + git: createProcess: resource exhausted (Too many open files) + git-annex: runInteractiveProcess: pipe: Too many open files + NetWatcherFallback crashed: git: createProcess: resource exhausted (Too many open files) + [2013-04-18 00:27:17 CEST] NetWatcherFallback: warning NetWatcherFallback crashed: git: createProcess: resource exhausted (Too many open files) + git-annex: runInteractiveProcess: pipe: Too many open files + git-annex: git: createProcess: resource exhausted (Too many open files) + git-annex: accept: resource exhausted (Too many open files) + +Instead of raising system's limit (which is a neverending story), can we make git-annex only watch a directory and not every file of it? + +Or could the user specify some directory which he knows it is rarely change, to not be watched only check it once a day? + +The best would be if git annex could automatically adapt itself. +Ie. it watches eg. 200 files, and if some of it does not change for three days, then it drops from the watching basket, and those who changed (noticed while sanity checked) it adds to the basket. + +I don't really want to raise the ulimit, because my ultimate goal is to have git-annex on multiple raspberry pi with external harddrive (one at my home, one at my mom's home, one at my friends home, etc, etc). And raspberry is fairly low on resource. + +I'm interested in your thoughts. + +Best, + Laszlo + +[[!tag /design/assistant moreinfo]] +[[!meta title="assistant can try to add too many files at once in batch add mode"]] diff --git a/doc/bugs/Stress_test.mdwn b/doc/bugs/Stress_test.mdwn new file mode 100644 --- /dev/null +++ b/doc/bugs/Stress_test.mdwn @@ -0,0 +1,45 @@ +What steps will reproduce the problem? + +mkdir annex_stress; cd annex_stress, +then execute the following script: + + #! /bin/sh + + # creating a directory, in which we dump all the files. + mkdir probes; cd probes + + for i in `seq -w 1 25769`; do + mkdir probe$i + echo "This is an important file, which saved also in backup ('back') directory too.\n Content changes: $i" > probe$i/probe$i.txt + echo "This is just an identical content file. Saved in each subdir." > probe$i/defaults.txt + echo "This is a variable ($i) content file, which is not backed up in 'back' directory." > probe$i/probe-nb$i.txt + mkdir probe$i/back + cp probe$i/probe$i.txt probe$i/back/probe$i.txt + done + + +It creates about 25000 directory and 3 files in each, two of them are identical. + +What is the expected output? What do you see instead? + +I expect git annex could import the directory within 12 hours. +Yet, it just crashes the gui (starting webapp, uses the cpu 100% and it does not finish after 28hours.) + + +What version of git-annex are you using? On what operating system? + +version 2013.04.17 + +Please provide any additional information below. + +I do hope git-annex can be fixed to handle large number of files. +This stress test models well enough my own directory structure, +relatively high number of files relatively low disk space usage +(my own directory structure: 750MB, this test creates 605MB). + + +Best, + Laszlo + +[[!meta title="assistant Stress test"]] +[[!tag /design/assistant]] diff --git a/doc/bugs/Stress_test/comment_1_c4c764488ac082f5c48d3a6b4b5fba42._comment b/doc/bugs/Stress_test/comment_1_c4c764488ac082f5c48d3a6b4b5fba42._comment new file mode 100644 --- /dev/null +++ b/doc/bugs/Stress_test/comment_1_c4c764488ac082f5c48d3a6b4b5fba42._comment @@ -0,0 +1,17 @@ +[[!comment format=mdwn + username="http://joeyh.name/" + nickname="joey" + subject="comment 1" + date="2013-04-23T20:00:31Z" + content=""" +Is this related or unrelated to the bug you filed at [[Resource_exhausted]]? + +I tried this test, and noticed that it was taking the assistant rather a long time to get to the 10 thousand file threshhold where it makes a batch commit. A small change to a better data structure for its queue reduced that time from probably 10 minutes to 2.5. + +I was unable to reproduce any problem with the webapp. Please provide lots of details to back up \"it just crashes the GUI\". + +The main problem with this directory tree is that it has more directories than inotify can watch, in the default configuration. +So after it adds the first 8192 directories, it begins failing to watch any more, and printing a message about you needing to increase the inotify limits for each additional directory. I don't think that 51 thousand directories is a particularly realistic amount for any real-world usage of git-annex. (It will also break file manager, dropbox, etc, which all use inotify in the same way.) + +The other main time sink is that git-annex needs to run `git hash-object` once per file to stage its symlink. That is a lot of processes to run, and perhaps it could be sped up by using `git fast-import`. +"""]] diff --git a/doc/bugs/Stress_test/comment_2_42125bba09a0ea9821cda7183e458100._comment b/doc/bugs/Stress_test/comment_2_42125bba09a0ea9821cda7183e458100._comment new file mode 100644 --- /dev/null +++ b/doc/bugs/Stress_test/comment_2_42125bba09a0ea9821cda7183e458100._comment @@ -0,0 +1,47 @@ +[[!comment format=mdwn + username="https://www.google.com/accounts/o8/id?id=AItOawm5iosFbL2By7UFeViqkc6v-hoAtqILeDA" + nickname="Laszlo" + subject="comment 2" + date="2013-04-24T06:30:16Z" + content=""" +Hi, + +First of all thank you for your time looking into my bug. I try to research more from my side. + +The 'Resource exhausted' bugreport +(which lost its title, and could not click on it to add this testcase as a comment) +was tested on real data, my own working directory (a copy of it). +This bugreport is tested on the output of this small shell script. + +None of them succeeded to import, and I quickly assumed it is the exact same. + +So I will test again, raising the ulimit to 81920, and report. + + The main problem with this directory tree is that it has more directories than inotify can watch, in the default configuration + +I would be perfectly fine if I could configure git-annex to sync those directory only once a month or once a week +(ie. check for update once a week). So no need to watch it real time, those are my archived work files. + + I don't think that 51 thousand directories is a particularly realistic amount for any real-world usage of git-annex. + +Well, it is not 25000 dir in a single a folder, but rather something like this: + + work_done/2009/workname/back9/back8/back7/back6/back5 + +Where each 'backX' contains a whole backup the work until it. +So the directory structure is a bit more deep, and no 25000 subdirectory in a single dir. +But the overall numbers are right. + +If I could somehow mark this **work_done** dir to not sync real time (or work_done/2008,work_done/2009,work_done/2010,work_done/2011,work_done/2012 subdir in them), +then my whole issue would vanish. + +I only want to use git-annex to have a backup of this directory. +In case of laptop theft, or misfunction I could have a backup. +I dont need live sync anywhere, I have directories which I know I will not touch for months. + +Best, + Laszlo + + + +"""]] diff --git a/doc/bugs/Stress_test/comment_3_8240e61106b494d3600ad91f16eb5b1c._comment b/doc/bugs/Stress_test/comment_3_8240e61106b494d3600ad91f16eb5b1c._comment new file mode 100644 --- /dev/null +++ b/doc/bugs/Stress_test/comment_3_8240e61106b494d3600ad91f16eb5b1c._comment @@ -0,0 +1,20 @@ +[[!comment format=mdwn + username="https://www.google.com/accounts/o8/id?id=AItOawm5iosFbL2By7UFeViqkc6v-hoAtqILeDA" + nickname="Laszlo" + subject="comment 3" + date="2013-04-24T09:10:20Z" + content=""" + (It will also break file manager, dropbox, etc, which all use inotify in the same way.) + +I beg to differ: with dropbox I handle my scrapbook(1) folder, +which means 130 thousand files for over 2 years now without problem between three computers. + + ~/Dropbox/scrapbook$ ls -R -1 |wc -l + 130263 + +Don't get me wrong. I'm not complaining, I only give you a completely unrelated usecase, +which requires also high number of files handling. And in that case the 81 thousand ulimit would not help either. + +(1): https://addons.mozilla.org/hu/firefox/addon/scrapbook/ + +"""]] diff --git a/doc/bugs/Stress_test/comment_4_c38d84e0dcc834931804c44bce7f7b7a._comment b/doc/bugs/Stress_test/comment_4_c38d84e0dcc834931804c44bce7f7b7a._comment new file mode 100644 --- /dev/null +++ b/doc/bugs/Stress_test/comment_4_c38d84e0dcc834931804c44bce7f7b7a._comment @@ -0,0 +1,11 @@ +[[!comment format=mdwn + username="http://joeyh.name/" + nickname="joey" + subject="comment 4" + date="2013-04-24T15:05:33Z" + content=""" +You're confusing number of files (inotify doesn't care) with number of directories (inotify does care). + +Dropbox is on record about being limited in the number of directories it can watch without adjusting the inotify limit. + +"""]] diff --git a/doc/bugs/Stress_test/comment_5_60ce20ee255451c4ea809ba475561adb._comment b/doc/bugs/Stress_test/comment_5_60ce20ee255451c4ea809ba475561adb._comment new file mode 100644 --- /dev/null +++ b/doc/bugs/Stress_test/comment_5_60ce20ee255451c4ea809ba475561adb._comment @@ -0,0 +1,15 @@ +[[!comment format=mdwn + username="http://joeyh.name/" + nickname="joey" + subject="comment 5" + date="2013-04-24T15:30:04Z" + content=""" +I found a bug in the webapp thanks to this stress test. When inotify goes over limit, it displays a message about how to fix it.. +But it displays that message over and over for each file. The result is a constantly updating very large web page. + +Unless you tell me differently, I'm going to assume that's what the GUI crash you referred to was, since it can make a web browser very slow. + +I've fixed this problem. Now when it goes over limit, the webapp will just display this: + +[[/assistant/inotify_max_limit_alert.png]] +"""]] diff --git a/doc/bugs/Stress_test/comment_6_1371562e201393986cd41597f6f288cb._comment b/doc/bugs/Stress_test/comment_6_1371562e201393986cd41597f6f288cb._comment new file mode 100644 --- /dev/null +++ b/doc/bugs/Stress_test/comment_6_1371562e201393986cd41597f6f288cb._comment @@ -0,0 +1,14 @@ +[[!comment format=mdwn + username="http://joeyh.name/" + nickname="joey" + subject="comment 6" + date="2013-04-24T17:26:39Z" + content=""" +I put in a further change to reduce the number of alerts shown in the webapp when bulk adding files. This probably quadrupled the speed or more, even when the webapp was not running, as updating an alert every time a file was added was a lot of unnecessary work. + +After these changes, it adds the first 10 thousand files in 35 minutes, on my five year old netbook. It should scale linear +(aside from git's own scalability issues with a lot of files, which I don't think are very bad under 1 million files), +so adding all 100 thousand files should take 6 hours or so. + +I'm interested to see what results you get, compared with before.. +"""]] diff --git a/doc/bugs/Stress_test/comment_7_a14be7699da224a8f6c9b34f1b911219._comment b/doc/bugs/Stress_test/comment_7_a14be7699da224a8f6c9b34f1b911219._comment new file mode 100644 --- /dev/null +++ b/doc/bugs/Stress_test/comment_7_a14be7699da224a8f6c9b34f1b911219._comment @@ -0,0 +1,8 @@ +[[!comment format=mdwn + username="http://joeyh.name/" + nickname="joey" + subject="comment 7" + date="2013-04-24T21:02:55Z" + content=""" +A few more changes got the rate down to 21 minutes per 10 thousand files. Estimate 3.5 hours for all. +"""]] diff --git a/doc/bugs/Tries_to_upload_to_remote_although_remote_is_dead.mdwn b/doc/bugs/Tries_to_upload_to_remote_although_remote_is_dead.mdwn --- a/doc/bugs/Tries_to_upload_to_remote_although_remote_is_dead.mdwn +++ b/doc/bugs/Tries_to_upload_to_remote_although_remote_is_dead.mdwn @@ -48,4 +48,4 @@ Please provide any additional information below. -[[!tag /design/assistant unreproducible]] +[[!tag /design/assistant moreinfo]] diff --git a/doc/bugs/True_backup_support.mdwn b/doc/bugs/True_backup_support.mdwn new file mode 100644 --- /dev/null +++ b/doc/bugs/True_backup_support.mdwn @@ -0,0 +1,5 @@ +I'd like to be able to restore my data from S3/Glacier following a catastrophic loss of information. + +As I understand it, git-annex doesn't solve this problem for me because it only stores file *contents* in S3/Glacier. A restore-from-nothing requires both the file contents and also the file names and metadata, which git-annex doesn't store in S3. + +I'm still feeling my way around git-annex, but I think it will probably be sufficient for my purposes to set up a cron job to push my annex to github. But I think it would be helpful if git-annex could take care of this automatically. diff --git a/doc/bugs/Unable_to_switch_back_to_direct_mode.mdwn b/doc/bugs/Unable_to_switch_back_to_direct_mode.mdwn new file mode 100644 --- /dev/null +++ b/doc/bugs/Unable_to_switch_back_to_direct_mode.mdwn @@ -0,0 +1,54 @@ +### Please describe the problem. + +I seem to be unable to switch back and forth between git annex direct and git annex indirect mode in one of my repositories. I can in others just fine. + +### What steps will reproduce the problem? + +In the broken repository I can do: + + cwebber@earlgrey:~/gfx-proj/mediagoblin_vid$ git annex direct + commit + add audio/part2.aup (checksum...) ok + ok + add images/campaign.png (checksum...) ok + ok + add images/transifex.png (checksum...) ok + ok + add script-lines.txt (checksum...) ok + ok + add vid_pitch.blend (checksum...) ok + ok + (Recording state in git...) + [master 9f13dc0] commit before switching to direct mode + 1 file changed, 145 insertions(+), 1 deletion(-) + rewrite audio/part2.aup (100%) + mode change 120000 => 100644 + ok + direct gavroche-vid-shot.blend + git-annex: /home/cwebber/gfx-proj/mediagoblin_vid/.git/annex/objects/3M/mx/SHA256E-s2935980--3a1c838333a4a0ee1eaa837c3f08a910d3f29fc60baf41affd936fbefe11111f/SHA256E-s2935980--3a1c838333a4a0ee1eaa837c3f08a910d3f29fc60baf41affd936fbefe11111f: rename: permission denied (Permission denied) + failed + git-annex: direct: 1 failed + +looking at the files: + + cwebber@earlgrey:~/gfx-proj/mediagoblin_vid$ ls -l gavroche-vid-shot.blend + lrwxrwxrwx 1 cwebber cwebber 190 Apr 28 18:27 gavroche-vid-shot.blend -> .git/annex/objects/3M/mx/SHA256E-s2935980--3a1c838333a4a0ee1eaa837c3f08a910d3f29fc60baf41affd936fbefe11111f/SHA256E-s2935980--3a1c838333a4a0ee1eaa837c3f08a910d3f29fc60baf41affd936fbefe11111f + cwebber@earlgrey:~/gfx-proj/mediagoblin_vid$ ls -l .git/annex/objects/3M/mx/SHA256E-s2935980--3a1c838333a4a0ee1eaa837c3f08a910d3f29fc60baf41affd936fbefe11111f/SHA256E-s2935980--3a1c838333a4a0ee1eaa837c3f08a910d3f29fc60baf41affd936fbefe11111f + -rw-r--r-- 1 cwebber cwebber 2935980 Apr 28 18:27 .git/annex/objects/3M/mx/SHA256E-s2935980--3a1c838333a4a0ee1eaa837c3f08a910d3f29fc60baf41affd936fbefe11111f/SHA256E-s2935980--3a1c838333a4a0ee1eaa837c3f08a910d3f29fc60baf41affd936fbefe11111f + cwebber@earlgrey:~/gfx-proj/mediagoblin_vid$ + +... it looks like these permissions should be fine! + +Some notable things: + +* I believe Blender wrote directly to a file that was in "locked" somehow, despite it being in that state. It may have actually followed the symlink and overwritten that file, I'm not sure. +* However, the file that git-annex is now reporting with "permission denied" is not the one it did previously... I did git checkout -- on all the files, switched them over, and it's a different set of broken things now! +* It's actually easy enough to fix... in fact, I did fix it! I just did a fresh clone of the git repository and a git annex get and everything is fine now. However, it seemed like possibly a bug that might hit other people, hence my reporting it. + +### What version of git-annex are you using? On what operating system? + +git annex version 4.20130417 on debian wheezy + +### Please provide any additional information below. + + diff --git a/doc/bugs/Unable_to_sync_a_second_machine_through_Box.mdwn b/doc/bugs/Unable_to_sync_a_second_machine_through_Box.mdwn new file mode 100644 --- /dev/null +++ b/doc/bugs/Unable_to_sync_a_second_machine_through_Box.mdwn @@ -0,0 +1,39 @@ +What steps will reproduce the problem? + +Install 4.20130417 as packaged in Debian unstable. +Using "git annex webapp", setup on first machine adding repository ~/annex. Add a Box.com repository in directory "annex", encrypted. Add a jabber account (apparently successful). +Add test file to ~/annex. Login via website to box.com, notice that the "annex" directory is created and contains encrypted file. +On second (remote machine), follow the same steps (add repository in ~/annex, Add a Box.com repository in directory "annex", encrypted, Add same jabber account). + +What is the expected output? What do you see instead? + +Expected the file to appear in the second machine's ~/annex. The webapp indicates: Synced with box.com +Log file says: + +[2013-04-23 06:50:16 EDT] main: starting assistant version 4.20130417 +(scanning...) [2013-04-23 06:50:16 EDT] Watcher: Performing startup scan +(started...) +(encryption setup shared cipher) (testing WebDAV server...) +(gpg) [2013-04-23 06:50:50 EDT] main: Syncing with box.com +[2013-04-23 06:50:50 EDT] main: Share with friends, and keep your devices in sync across the cloud. +[2013-04-23 06:51:03 EDT] main: Share with friends, and keep your devices in sync across the cloud. +warning: Not updating non-default fetch respec + + Please update the configuration manually if necessary. +Initializing nautilus-gdu extension +Shutting down nautilus-gdu extension +git-annex: Daemon is already running. + +What version of git-annex are you using? On what operating system? + +4.20130417, debian testing with apt-pinning to unstable on both systems. + +Please provide any additional information below. + +When editing the Box.com repository, the option to select a directory no longer appears (and the configuration doesn't show the one selected at creation). +There's no indication if the jabber communication is working successfully. It could be that signalling isn't working for some reason, but the user has no information to determine that. +It would be helpful if there were some indication in the Dashboard as to the number of files/directories/objects that git annex believes exists in each location. It could be that it's not accessing the Box.com server successfully, but again, this is difficult to determine. + +It's great to see that git annex might make a box.com account useful for automatic upload and sync... looking forward to getting it to work on both sides! Thanks for making this! + +[[!tag /design/assistant moreinfo]] diff --git a/doc/bugs/Unfortunate_interaction_with_Calibre.mdwn b/doc/bugs/Unfortunate_interaction_with_Calibre.mdwn --- a/doc/bugs/Unfortunate_interaction_with_Calibre.mdwn +++ b/doc/bugs/Unfortunate_interaction_with_Calibre.mdwn @@ -19,3 +19,6 @@ However, I think it's: * Unfortunate, as fitting Calibre together with git-annex seems like a neat idea. * Useful to make sure that this kind of "doesn't play well together" condition is documented, even if only as a bug report. + +> [[done]]; the assistant uses direct mode by default now to avoid +> this kind of thing. --[[Joey]] diff --git a/doc/bugs/Weird_behaviour_of_direct_and_indirect_annexes.mdwn b/doc/bugs/Weird_behaviour_of_direct_and_indirect_annexes.mdwn --- a/doc/bugs/Weird_behaviour_of_direct_and_indirect_annexes.mdwn +++ b/doc/bugs/Weird_behaviour_of_direct_and_indirect_annexes.mdwn @@ -50,3 +50,8 @@ **Edit: Doing a git annex sync in ~/Indirect results in the continuing behaviour to be correct, so there's some issue telling Direct that Indirect is no longer in direct-mode?** This appears to fix it, but I guess shouldn't be necessary. + +> AFAICS, the entire problem is that the assistant does not notice when the +> repository it's running in is changed from direct to indirect mode. Since this +> has also been reported to cause problems with the assistant, I have added +> a check to prevent it from being done. [[done]] --[[Joey]] diff --git a/doc/bugs/assistant_does_not_warn_on_files_it_failed_to_add.mdwn b/doc/bugs/assistant_does_not_warn_on_files_it_failed_to_add.mdwn --- a/doc/bugs/assistant_does_not_warn_on_files_it_failed_to_add.mdwn +++ b/doc/bugs/assistant_does_not_warn_on_files_it_failed_to_add.mdwn @@ -22,3 +22,25 @@ Please provide any additional information below. The assistant in this case is being used as nothing more than a way for me to see which files have been added (--verbose, --foreground and --debug with 'watch' outputs nothing..). No remotes or anything like that. + +> I have made the assistant re-queue any file that it fails to add, +> so it will retry it later. Typically within a few seconds. [[done]] +> +> I have only been able to think of one scenario in which this could +> happen. It's pretty unusual: +> +> * Something writes to a file, and closes it. +> * Assistant sees file has no writers, and locks it down in preparation +> to add it. +> * Something then re-opens the file to write to it some more. +> Note that it would seem to need to bypass permissions that prevent +> the file from being written to in order to do this. It makes a change +> to the file. +> * Assistant is checksumming file, reaches end, and detects it has been +> tampered with and gives up. +> +> I would still like more information about circumstances that +> cause this to happen, because while a possible scenario, the +> above is too weird to believe anyone could run into it. +> +> --[[Joey]] diff --git a/doc/bugs/assistant_hangs_during_commit.mdwn b/doc/bugs/assistant_hangs_during_commit.mdwn --- a/doc/bugs/assistant_hangs_during_commit.mdwn +++ b/doc/bugs/assistant_hangs_during_commit.mdwn @@ -1,5 +1,3 @@ -[[!meta title="on Arch Linux, git commit -m tries to run an editor on the commit message"]] - What steps will reproduce the problem? Use git-annex and add file to repo. @@ -25,3 +23,5 @@ Please provide any additional information below. I'm not sure if the git interface has changed, but I do see that --allow-empty-message does still exist. If I run the git commit command (with a '' after the -m), it does indeed start up vim for me. Would we benefit from just making a custom commit message ("Commit from date YYYYMMDDTHHMMSSZ")? + +> [[fixed|done]] --[[Joey]] diff --git a/doc/bugs/error_on_only_repository_copy_deletion.mdwn b/doc/bugs/error_on_only_repository_copy_deletion.mdwn new file mode 100644 --- /dev/null +++ b/doc/bugs/error_on_only_repository_copy_deletion.mdwn @@ -0,0 +1,16 @@ +**What steps will reproduce the problem?**
+Delete the last repository in the current repository (where it says: warning type in "yes please do as i say"). +Then try running git annex webapp +

+**What is the expected output? What do you see instead?**
+Webapp starts. git-annex: Not in a git repository. +

+**What version of git-annex are you using? On what operating system?**
+4.20130417. Debian wheezy/testing +

+**Please provide any additional information below.**
+See also +[[bugs/git-annex:_Not_in_a_git_repository._/]] +where the same error message occurs + +[[!tag /design/assistant moreinfo]] diff --git a/doc/bugs/git-annex_get:_requested_key_is_not_present.mdwn b/doc/bugs/git-annex_get:_requested_key_is_not_present.mdwn new file mode 100644 --- /dev/null +++ b/doc/bugs/git-annex_get:_requested_key_is_not_present.mdwn @@ -0,0 +1,32 @@ +### Please describe the problem. + +I setup 3 repositories on my laptop and 3 on my server using the webapp, see the following scheme: + +Laptop <- sync with -> Server + + /home/fabian/Dokumente (Client) <-> /mnt/raid/Dokumente (Full-Backup) + /home/fabian/Bilder (Client) <-> /mnt/raid/Bilder (Full-Backup) + /mnt/data-common/Audio (Manual) <-> /mnt/raid/Audio (Full-Backup) + +As you can see, the Audio folder is in manual mode on the laptop, so it does not get any files automatically. +If I now want to get a folder with 'git-annex get' I get the following error: + + fabian@fabian-thinkpad /mnt/data-common/Audio $ git-annex get Musik + get Musik/+⁄-/2003 - You Are Here (Bonus Disc)/01 - I've Been Lost.ogg (from eifel.fritz.box__mnt_raid_Audio...) + requested key is not present + rsync: connection unexpectedly closed (0 bytes received so far) [Receiver] + rsync error: error in rsync protocol data stream (code 12) at io.c(605) [Receiver=3.0.9] + + Unable to access these remotes: eifel.fritz.box__mnt_raid_Audio + + Try making some of these repositories available: + efe13d8c-2b02-455f-9874-b7043caa332f -- eifel.fritz.box__mnt_raid_Audio (fabian@eifel:/mnt/raid/Audio) + failed + +### What steps will reproduce the problem? + +I do not really know the minimal setup to reproduce this problem. + +### What version of git-annex are you using? On what operating system? + +git-annex 4.20130417 on Gentoo Linux using Ebuilds from Haskell overlay diff --git a/doc/bugs/git_annex_assistant_--autostart_failed.mdwn b/doc/bugs/git_annex_assistant_--autostart_failed.mdwn new file mode 100644 --- /dev/null +++ b/doc/bugs/git_annex_assistant_--autostart_failed.mdwn @@ -0,0 +1,39 @@ +**What steps will reproduce the problem?** + +Run *git annex assistant --autostart* + + git-annex autostart in /home/tobru/annex/repo1 + failed + git-annex autostart in /home/tobru/annex/repo2 + failed + git-annex autostart in /home/tobru/annex/repo3 + failed + git-annex autostart in /home/tobru/annex/repo4 + failed + git-annex autostart in /home/tobru/annex/repo5 + failed + +Running *git annex assistant* in each directory starts the assistant without errors. + +What could cause autostart to fail? Is there any log? Or a --debug parameter? + + +**What is the expected output? What do you see instead?** + +The assistant should start on all known repositories + +**What version of git-annex are you using? On what operating system?** + +4.20130417-g4bb97d5 on Ubuntu + +**Please provide any additional information below.** + +The ~/.config/git-annex/autostart file looks like this: + + /home/tobru/annex/repo1 + /home/tobru/annex/repo2 + /home/tobru/annex/repo3 + /home/tobru/annex/repo4 + /home/tobru/annex/repo5 + +> Closing, seems local misconfiguration. --[[Joey]] [[done]] diff --git a/doc/bugs/git_annex_does_nothing_useful.mdwn b/doc/bugs/git_annex_does_nothing_useful.mdwn --- a/doc/bugs/git_annex_does_nothing_useful.mdwn +++ b/doc/bugs/git_annex_does_nothing_useful.mdwn @@ -60,3 +60,8 @@ Alright, it didn't fail with an error, that's very strange. What is going on here? [[!meta title="v1 file is ignored"]] + +> I don't think I want to make git-annex deal with v1 files, and +> I doubt there are many repos left using them. This seems to be a case +> of an upgrade not being done, for whatever reason. Closing [[done]] +> --[[Joey]] diff --git a/doc/bugs/make_SHA512E_the_default.mdwn b/doc/bugs/make_SHA512E_the_default.mdwn new file mode 100644 --- /dev/null +++ b/doc/bugs/make_SHA512E_the_default.mdwn @@ -0,0 +1,29 @@ +What steps will reproduce the problem? + +As described in +http://git-annex.branchable.com/backends/#comment-3c1cd45d2a015b4fc412dd813293ad7d +, sha512 is faster. On my 64-bit system, the speed difference is about +1.5times. + +What is the expected output? What do you see instead? + + +What version of git-annex are you using? On what operating system? + + +Please provide any additional information below. + +> You are free to change the default in your own annexes. This is very easy +> to do: `echo '* annex.backend=SHA512E' > .gitattributes` +> +> I don't anticipate moving to SHA512, because +> +> 1. It makes `ls -l` really ugly. Each symlink takes like 4 lines +> on an 80 column terminal. +> 2. There are better hashes coming. Particularly SHA3. That should be +> faster and/or more secure. And without adding so much length to the +> hash. +> +> --[[Joey]] + +[[done]] diff --git a/doc/bugs/moreinfo.mdwn b/doc/bugs/moreinfo.mdwn new file mode 100644 --- /dev/null +++ b/doc/bugs/moreinfo.mdwn @@ -0,0 +1,6 @@ +If your bug report is listed here, it has been flagged as needing more +information. Please respond to the bug and provide the requested +information. + +[[!inline pages="./* and link(./moreinfo) and !link(./done) and !*/Discussion" sort=mtime show=10 +archive=yes]] diff --git a/doc/bugs/random_files_vanishing_when_assistant_gets_restarted.mdwn b/doc/bugs/random_files_vanishing_when_assistant_gets_restarted.mdwn --- a/doc/bugs/random_files_vanishing_when_assistant_gets_restarted.mdwn +++ b/doc/bugs/random_files_vanishing_when_assistant_gets_restarted.mdwn @@ -31,4 +31,4 @@ 3.20130102 on Arch Linux x64 -[!tag /design/assistant]] +[!tag /design/assistant moreinfo]] diff --git a/doc/bugs/three_character_directories_created.mdwn b/doc/bugs/three_character_directories_created.mdwn --- a/doc/bugs/three_character_directories_created.mdwn +++ b/doc/bugs/three_character_directories_created.mdwn @@ -49,3 +49,8 @@ I use a symlink to the repository to change into it. +> Closing this bug as user error. If the `git-annex` branch +> gets merged into master by the user, then that adds all its log files +> to master, and so they're visible as regular files. Solution: Don't do +> that, or if you do that, use `git log --stat` to find the commit that +> adds all those files, and `git revery` the commit. [[done]] --[[Joey]] diff --git a/doc/bugs/xmpp_needs_one_account_per_distinct_repository.mdwn b/doc/bugs/xmpp_needs_one_account_per_distinct_repository.mdwn new file mode 100644 --- /dev/null +++ b/doc/bugs/xmpp_needs_one_account_per_distinct_repository.mdwn @@ -0,0 +1,107 @@ +The way [[XMPP pairing|design/assistant/XMPP]] currently works, each +separate repository needs to use a different XMPP account. If two +repositories use the same XMPP account, then they will be combined together +when XMPP pairing takes place. + +There are two different UIs for XMPP pairing. While the same protocol +is running behind the scenes, these UIs should be considered separately. + +## Share with your other devices + +Here, I think it makes sense to require the user to use the same XMPP +account on all their devices (otherwise it's pairing with a friend), and +automatically combine repositories of devices that use the same XMPP +account. + +The UI is pretty clear about this: + + If you have multiple devices, all running git-annex, and using # + your Jabber account #{account}, you can configure them to share # + your files between themselves. + +Doing it this way avoids needing to confirm pair requests coming from the same +XMPP account. Which means that, for example, you can have a device at home, +and one at work, and pair them by simply initiating a pair request from one +to the other. You don't have to travel between home and work to confirm +the request. + +(Also, when you have a lot of devices, this avoids a combinatorial explosion +of pair request confirmations.) + +The only problem with this is that users who want multiple repositories +need to find multiple XMPP accounts. However, I'm inclined to think this is +a reasonable requirement. + +## Share with a friend + +Suppose that Alice wants to share with Bob. Bob is using the same XMPP +account for two separate repositories (B1 and B2), that are not +themselves paired. + +When Alice chooses to share with Bob, a XMPP pair request is sent. +Both of Bob's repositories see it, and both ask him to confirm. +Bob can choose to only confirm the request in B1, and +not in B2. This should work ok. + +* The UI for this only says "Pair request received from #{name}", + it does not indicate which repository of Alice's is being paired + with. This could be improved. If Alice has two repositories as well, + she and Bob will want to coordinate pairing the right ones together. + Could be fixed by just displaying the description of Alice's repository + to Bob. + +----- + +Now, suppose that Alice makes a second, distinct repository (A2), +and chooses to share it with Bob (intending to share with B2). This +sends an XMPP pair request to both of Bob's repositories. + +B1 has already paired with Alice, so it assumes this +new pair request is from a different device belonging to Alice, and it +automatically ACKs the pair request. + +The result is that Alice's new A2 repository combines with B1, +which is already combined with A1. Effectively combining all of A1, A2, B1, +and B2, unexpectedly. **This is a bug**. + +Some possible fixes: + +1. Stop auto-accepting pair requests + from friends we're already paired with. Require another confirmation. +2. Or, only auto-accept pair requests from friends we're already paired with + when they come from a repository whose UUID we already know. This + enhancment to fix #1 makes it easier to build more robust networks of + repositories. **done** + +Hmm, I don't think those fixes are sufficient. Suppose they're in place. +Then when Alice shares A2 with Bob, both his repositories will ask him to +confirm the pair request. He confirms in B2, and pairing proceeds. + +But, XMPP git push is broadcast to all clients of an XMPP account. +So when B2 sends a push, A1 sees it, and happily merges away. The +repositories still combine! + +So, we need another fix: + +* Send UUID in XMPP git push protocol messages. Only respond to git push + messages from a known UUID, and ignore all others. (XMPP pairing + already sends the UUID, so it will be known.) **done** + +---- + +* Alternatively, we could say that the problem is that Bob has two + distinct repositories using the same XMPP account, and try to prevent + him from doing that in the first place. + + One way to do this would be, when configuring the + XMPP account, scan for other repositories using the same account, and + don't let it be used unless the user confirms they want to pair them. + But, this doesn't seem viable because if the other repository is on + another device, which is turned off, this check wouldn't see it. + + Or there could be a warning about account reuse. Doesn't seem likely to + be effective. + +----- + +> [[done]]. I've put in the fixes around pairing with friends. --[[Joey]] diff --git a/doc/design/assistant.mdwn b/doc/design/assistant.mdwn --- a/doc/design/assistant.mdwn +++ b/doc/design/assistant.mdwn @@ -18,7 +18,8 @@ We are, approximately, here: -* Months 10-11: more user-driven features and polishing +* Month 10: bugfixing, Android webapp +* Month 11: more user-driven features and polishing * Month 12: "Windows purgatory" [[Windows]] ## porting diff --git a/doc/design/assistant/android.mdwn b/doc/design/assistant/android.mdwn --- a/doc/design/assistant/android.mdwn +++ b/doc/design/assistant/android.mdwn @@ -18,15 +18,8 @@ The app should be aware of network status, and avoid expensive data transfers when not on wifi. This may need to be configurable. -## Template Haskell for android? - -Best lead I have on getting cross compilation of TH working is that GHCJS -does it, and that it involves compiling each file twice, once natively for -TH and once for cross. - ## TODO -* webapp * autostart any configured assistants. Best on boot, but may need to only do it when app is opened for the first time. * Don't make app initially open terminal, but go to a page that @@ -39,9 +32,6 @@ allow git to link to it. * getEnvironment is broken on Android and a few places use it. -* 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 diff --git a/doc/design/assistant/blog/day_240__it_builds.mdwn b/doc/design/assistant/blog/day_240__it_builds.mdwn new file mode 100644 --- /dev/null +++ b/doc/design/assistant/blog/day_240__it_builds.mdwn @@ -0,0 +1,37 @@ +Late last night, I successfully built the full webapp for Android! + +That was with several manual modifications to the generated code, which I +still need to automate. And I need to set up the autobuilder properly +still. And I need to find a way to make the webapp open Android's web browser +to URL. So it'll be a while yet until a package is available +to try. But what a milestone! + +The point I was stuck on all day yesterday was generated code that +looked like this: + +[[!format haskell """ +(toHtml + (\ u_a2ehE -> urender_a2ehD u_a2ehE [] + (CloseAlert aid))))); +"""]] + +That just couldn't type check at all. Most puzzling. My best guess is that +`u_a2ehE` is the dictionary GHC passes internally to make a typeclass work, +which somehow leaked out and became visible. Although +I can't rule out that I may have messed something up in my build environment. +The EvilSplicer has a hack in it that finds such code and converts it to +something like this: + +[[!format haskell """ +(toHtml + (flip urender_a2ehD [] + (CloseAlert aid))))); +"""]] + +I wrote some more about the process of the Android port in my personal blog: +[Template Haskell on impossible architectures](http://joeyh.name/blog/entry/Template_Haskell_on_impossible_architectures/) + +---- + +Release day today. The OSX builds are both not available yet for this +release, hopefully will come out soon. diff --git a/doc/design/assistant/blog/day_241__cleanup.mdwn b/doc/design/assistant/blog/day_241__cleanup.mdwn new file mode 100644 --- /dev/null +++ b/doc/design/assistant/blog/day_241__cleanup.mdwn @@ -0,0 +1,14 @@ +Finished the last EvilSplicer tweak and other fixes to make the +Android webapp build without any hand-holding. + +Currently setting up the Android autobuilder to include the webapp in its +builds. To make this work I had to set up a new chroot with all the right +stuff installed. + +Investigated how to make the Android webapp open a web browser when run. +As far as I can tell (without access to an Android device right now), +`am start -a android.intent.action.VIEW -d http://localhost/etc` should do +it. + +Seems that git 1.8.2 broke the assistant. I've put in a fix but have not +yet tested it. diff --git a/doc/design/assistant/blog/day_242__more_porting.mdwn b/doc/design/assistant/blog/day_242__more_porting.mdwn new file mode 100644 --- /dev/null +++ b/doc/design/assistant/blog/day_242__more_porting.mdwn @@ -0,0 +1,4 @@ +Got WebDAV enabled in the Android build. Had to deal with some system calls +not available in Android's libc. + +New poll: [[polls/Android_default_directory]] diff --git a/doc/design/assistant/blog/day_243__in_the_field.mdwn b/doc/design/assistant/blog/day_243__in_the_field.mdwn new file mode 100644 --- /dev/null +++ b/doc/design/assistant/blog/day_243__in_the_field.mdwn @@ -0,0 +1,21 @@ +Today was not a work day for me, but I did get a chance to install +git-annex in real life while visiting. Was happy to download the standalone +Linux tarball and see that it could be unpacked, and git-annex webapp +started just by clicking around in the GUI. And in very short order got it +set up. + +I was especially pleased to see my laptop noticed this new repository +had appeared on the network via XMPP push, and started immediately +uploading files to my rsync.net transfer repository so the new +repository could get them. + +Did notice that the standalone tarball neglected to install a +FDO menu file. Fixed that, and some other minor issues I noticed. + + +I also got a brief chance to try the Android webapp. It fails to start; +apparently `getaddrinfo` doesn't like the flags passed to it and is +failing. As failure modes go, this isn't at all bad. I can certainly work +around it with some hardcoded port numbers, but I want to fix it the right +way. Have ordered a replacement battery for my dead phone so I can use it +for Android testing. diff --git a/doc/design/assistant/blog/day_244__android_porting.mdwn b/doc/design/assistant/blog/day_244__android_porting.mdwn new file mode 100644 --- /dev/null +++ b/doc/design/assistant/blog/day_244__android_porting.mdwn @@ -0,0 +1,6 @@ +Ported all the C libraries needed for XMPP to Android. (gnutls, +libgcrypt, libgpg-error, nettle, xml2, gsasl, etc). Finally +got it all to link. What a pain. + +Bonus: Local pairing support builds for Android now, seems recent changes to +the network library for WebDAV also fixed it. diff --git a/doc/design/assistant/blog/day_245__misc.mdwn b/doc/design/assistant/blog/day_245__misc.mdwn new file mode 100644 --- /dev/null +++ b/doc/design/assistant/blog/day_245__misc.mdwn @@ -0,0 +1,15 @@ +Got the OSX autobuilder back running, and finally got a OSX build up for +the 4.20130417 release. Also fixed the OSX app build machinery to handle +rpath. + +Made the assistant (and `git annex sync`) sync with git remotes that have +`annex-ignore` set. So, `annex-ignore` is only used to prevent using +the annex of a remote, not syncing with it. The benefit of this change +is that it'll make the assistant sync the local git repository with +a git remote that is on a server that does not have git-annex installed. +It can even sync to github. + +Worked around more breakage on misconfigured systems that don't have GECOS +information. + +... And other bug fixes and bug triage. diff --git a/doc/design/assistant/blog/day_246__bug_treadmill.mdwn b/doc/design/assistant/blog/day_246__bug_treadmill.mdwn new file mode 100644 --- /dev/null +++ b/doc/design/assistant/blog/day_246__bug_treadmill.mdwn @@ -0,0 +1,18 @@ +There seem to be a steady state of enough bug reports coming in that I can +work on them whenever I'm not working on anything else. As I did all day +today. + +This doesn't bother me if the bug reports are of real bugs that I can +reproduce and fix, but I'm spending a lot of time currently following up to +messages and asking simple questions like "what version number" and "can I +please see the whole log file". And just trying to guess what a vague +problem report means and read people's minds to get to a definite bug +with a test case that I can then fix. + +I've noticed the overall quality of bug reports nosedive over the past +several months. My guess is this means that git-annex has found a less +technical audience. I need to find something to do about this. + +With that whining out of the way ... +I fixed a pretty ugly bug on FAT/Android today, and +I am 100% caught up on messages right now! diff --git a/doc/design/assistant/blog/day_247__performance_tuning.mdwn b/doc/design/assistant/blog/day_247__performance_tuning.mdwn new file mode 100644 --- /dev/null +++ b/doc/design/assistant/blog/day_247__performance_tuning.mdwn @@ -0,0 +1,16 @@ +Working on assistant's performance when it has to add a whole lot of files +(10k to 100k). + +Improved behavior in several ways, including fixing display +of the alert in the webapp when the default inotify limit of 8192 +directories is exceeded. + +Created a new TList data type, a transactional DList. Much nicer +implementation than the TChan based thing it was using to keep track of the +changes, although it only improved runtime and memory usage a little bit. +The way that this is internally storing a function in STM and modifying +that function to add items to the list is way cool. + +Other tuning seems to have decreased the time it would take to import 100k +files from somewhere in the range of a full day (too long to wait to see), +to around 3.5 hours. I don't know if that's good, but it's certainly better. diff --git a/doc/design/assistant/blog/day_248__Internet_Archive.mdwn b/doc/design/assistant/blog/day_248__Internet_Archive.mdwn new file mode 100644 --- /dev/null +++ b/doc/design/assistant/blog/day_248__Internet_Archive.mdwn @@ -0,0 +1,28 @@ +Very productive & long day today, spent adding a new feature to the +webapp: Internet Archive support! + +[[!img /assistant/iaitem.png]] + +git-annex already supported using archive.org via its S3 special remotes, +so this is just a nice UI around that. + +How does it decide which files to publish on archive.org? Well, +the item has a unique name, which is based on the description +field. Any files located in a directory with that name will be uploaded +to that item. (This is done via a new preferred content expression I added.) + +So, you can have one repository with multiple IA items attached, and +sort files between them however you like. +I plan to make a screencast eventually demoing that. + +Another interesting use case, once the Android webapp is done, would be add +a repository on the DCIM directory, set the archive.org repository to +prefer all content, and *bam*, you have a phone or tablet that +auto-publishes and archives every picture it takes. + +Another nice little feature added today is that whenever a file is uploaded +to the Internet Archive, its public url is automatically recorded, same +as if you'd ran `git annex addurl`. So any users who can clone your +repository can download the files from archive.org, without needing any +login or password info. This makes the Internet Archive a nice way to +publish the large files associated with a public git repository. diff --git a/doc/design/assistant/blog/day_249__quiet_day.mdwn b/doc/design/assistant/blog/day_249__quiet_day.mdwn new file mode 100644 --- /dev/null +++ b/doc/design/assistant/blog/day_249__quiet_day.mdwn @@ -0,0 +1,7 @@ +Quiet day. Only did minor things, like adding webapp UI for changing the +directory used by Internet Archive remotes, and splitting out an +`enableremote` command from `initremote`. + +My Android development environment is set up and ready to go on my Motorola +Droid. The current Android build of git-annex fails to link at run time, so +my work is cut out for me. Probably broke something while enabling XMPP? diff --git a/doc/design/assistant/blog/day_250__stymied.mdwn b/doc/design/assistant/blog/day_250__stymied.mdwn new file mode 100644 --- /dev/null +++ b/doc/design/assistant/blog/day_250__stymied.mdwn @@ -0,0 +1,23 @@ +Turns out my old Droid has such an old version of Android (2.2) that +it doesn't work with any binaries produced by my haskell cross-compiler. I +think it's using a symbol not in its version of libc. Since upgrading this +particular phone is a ugly process and the hardware is dying anyway (bad +USB power connecter), I have given up on using it, and ordered an Android +tablet instead to use for testing. Until that arrives, no Android. Bah. +Wanted to get the Android app working in April. + +Instead, today I worked on making the webapp require less redundant +password entry when adding multiple repositories using the same cloud +provider. This is especially needed for the Internet Archive, since users +will often want to have quite a few repositories, for different IA items. +Implemented it for box.com, and Amazon too. + +Francois Marier has built an Ubuntu PPA for git-annex, containing the +current version, with the assistant and webapp. It's targeted at Precise, +but I think will probably also work with newer releases. + + +Probably while I'm waiting to work on Android again, I will try to +improve the situation with using a single XMPP account for multiple +repositories. Spent a while today thinking through ways to improve the +design, and have some ideas. diff --git a/doc/design/assistant/blog/day_251__xmpp_improvements.mdwn b/doc/design/assistant/blog/day_251__xmpp_improvements.mdwn new file mode 100644 --- /dev/null +++ b/doc/design/assistant/blog/day_251__xmpp_improvements.mdwn @@ -0,0 +1,34 @@ +Took 2 days in a row off, because I noticed I have forgotten to do that +since February, or possibly earlier, not counting trips. Whoops! + +Also, I was feeling overwhelmed with the complexity of fixing XMPP to not +be buggy when there are multiple separate repos using the same XMPP +account. Let my subconcious work on that, and last night it served up the +solution, in detail. Built it today. + +It's only a partial solution, really. If you want to use the same XMPP +account for multiple separate repositories, you cannot use the "Share with +your other devices" option to pair your devices. That's because XMPP +pairing assumes all your devices are using the same XMPP account, in order +to avoid needing to confirm on every device each time you add a new device. +The UI is clear about that, and it avoids complexity, so I'm ok with that. + +But, if you want to instead use "Share with a friend", you now can use the +same XMPP account for as many separate repositories as you like. The +assistant now ignores pushes from repositories it doesn't know about. +Before, it would merge them all together without warning. + +---- + +While I was testing that, I think I found out the real reason why XMPP +pushes have seemed a little unrelaible. It turns out to not be an XMPP +issue at all! Instead, the merger was simply not always +noticing when `git receive-pack` updated a ref, and not merging it into +master. That was easily fixed. + +---- + +Adam Spiers has been getting a `.gitignore` query interface suitable for +the assistant to use into `git`, and he tells me it's landed in `next`. +I should soon check that out and get the assistant using it. But first, +Android app! diff --git a/doc/design/assistant/more_cloud_providers.mdwn b/doc/design/assistant/more_cloud_providers.mdwn --- a/doc/design/assistant/more_cloud_providers.mdwn +++ b/doc/design/assistant/more_cloud_providers.mdwn @@ -10,6 +10,7 @@ shakey; a better method would be to use its API) **done** * Dropbox? That would be ironic.. Via its API, presumably. * [[Amazon Glacier|todo/special_remote_for_amazon_glacier]] **done** +* Internet Archive **done** * [nimbus.io](https://nimbus.io/) Fairly low prices ($0.06/GB); REST API; free software * Mediafire provides 50gb free and has a REST API. diff --git a/doc/design/assistant/polls/Android_default_directory.mdwn b/doc/design/assistant/polls/Android_default_directory.mdwn new file mode 100644 --- /dev/null +++ b/doc/design/assistant/polls/Android_default_directory.mdwn @@ -0,0 +1,7 @@ +What directory should the Android webapp default to creating an annex in? + +Same as the desktop webapp, users will be able to enter a directory they +want the first time they run it, but to save typing on android, anything +that gets enough votes will be included in a list of choices as well. + +[[!poll open=yes expandable=yes 42 "/sdcard/annex" 3 "Whole /sdcard" 4 "DCIM directory (photos and videos only)" 1 "Same as for regular git-annex. ~/annex/"]] diff --git a/doc/design/assistant/todo.mdwn b/doc/design/assistant/todo.mdwn --- a/doc/design/assistant/todo.mdwn +++ b/doc/design/assistant/todo.mdwn @@ -1,4 +1,4 @@ -This is a subset of [[/todo]] for items tagged for the assistant. -Link items to [[todo/done]] when done. +This is a subset of [[/todo]] and [[/bugs]] +for items tagged for the assistant. -[[!inline pages="tagged(design/assistant) and !link(bugs/done)" show=0 archive=yes]] +[[!inline pages="tagged(design/assistant) and !link(bugs/done) and !link(bugs/moreinfo)" show=0 archive=yes]] diff --git a/doc/design/assistant/xmpp.mdwn b/doc/design/assistant/xmpp.mdwn --- a/doc/design/assistant/xmpp.mdwn +++ b/doc/design/assistant/xmpp.mdwn @@ -9,11 +9,6 @@ * Do git-annex clients sharing an account with regular clients cause confusing things to happen? See -* Support use of a single XMPP account with several separate and - independant git-annex repos. This probably works for the simple - push notification use of XMPP, since unknown UUIDs will just be ignored. - But XMPP pairing and the pushes over XMPP assume that anyone you're - paired with is intending to sync to your repository. ## design goals @@ -64,18 +59,18 @@ For pairing, a chat message is sent to every known git-annex client, containing: - + ### git push over XMPP To indicate that we could push over XMPP, a chat message is sent, to each known client of each XMPP remote. - + To request that a remote push to us, a chat message can be sent. - + When replying to an canpush message, this is directed at the specific client that indicated it could push. To solicit pushes from all clients, @@ -83,7 +78,7 @@ When a peer is ready to send a git push, it sends: - + The receiver runs `git receive-pack`, and sends back its output in one or more chat messages, directed to the client that is pushing: diff --git a/doc/encryption.mdwn b/doc/encryption.mdwn --- a/doc/encryption.mdwn +++ b/doc/encryption.mdwn @@ -31,10 +31,10 @@ 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. -To add a new key, just run `git annex initremote` again, specifying the +To add a new key, just run `git annex enableremote` specifying the new encryption key: - git annex initremote myremote encryption=788A3F4C + git annex enableremote myremote encryption=788A3F4C Note that once a key has been given access to a remote, it's not possible to revoke that access, short of deleting the remote. See diff --git a/doc/forum/Automatically_syncronise_centralised_repository.mdwn b/doc/forum/Automatically_syncronise_centralised_repository.mdwn new file mode 100644 --- /dev/null +++ b/doc/forum/Automatically_syncronise_centralised_repository.mdwn @@ -0,0 +1,14 @@ +I would like to use git annex between two locations (work and home) where essentially the two computers are never on at the same time. + +I have set up a special remote (S3) to cater for file transfer between the sites, but still need some way of syncronising the git repositories between them. +I have access to a git server, but which doesn't have git-annex on it. So, I think that is all the components I need to get this working. + +However, I don't want to have to manually sync my computers with the central server, so I would like the assistant to do it for me, in what is essentially the complement of the special remote. + +What is the best way to accomplish this? I guess that this is a general git question, not specific to git annex. +I see some solutions [[http://stackoverflow.com/questions/3583061/automatically-mirror-a-git-repository]], but my git isn't really up to evaluating the options properly. + +So, what do other people do in this situation? + + +--Walter diff --git a/doc/forum/Cannot_launch_webapp_on_ubuntu_12.04_using_ppa.mdwn b/doc/forum/Cannot_launch_webapp_on_ubuntu_12.04_using_ppa.mdwn new file mode 100644 --- /dev/null +++ b/doc/forum/Cannot_launch_webapp_on_ubuntu_12.04_using_ppa.mdwn @@ -0,0 +1,6 @@ +Hi, I have installed latest version from https://launchpad.net/~rubiojr/+archive/git-annex, that is git-annex version: 3.20121017-ubuntu1ppa1~precise +When running git annex webapp I get + +git-annex: unknown command webapp + +I only installed git-annex. Are there more packages to be installed to make it work? diff --git a/doc/forum/Need_some_help_to_fix_my_repository.mdwn b/doc/forum/Need_some_help_to_fix_my_repository.mdwn new file mode 100644 --- /dev/null +++ b/doc/forum/Need_some_help_to_fix_my_repository.mdwn @@ -0,0 +1,31 @@ +Hi, +first sorry for my poor english it's not my native language. + +I have one repository on my laptop and two repository on usb disk. Made with following walkthrough (creating a repository and adding a remote). + +Yesterday I have a backup of my repository on usb disk before add some file with + +cd /media/usb/annex;git fetch laptop; git merge laptop/master&&git annex get .&&git annex sync + +Now the repository on my usb disk is a mess. +Every file before the commit are lost. +For example : + After the sync : file Z.7z +Z.7z: broken symbolic link to `../../../../.git/annex/objects/2K/49/SHA256-s0--e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855/SHA256-s0--e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855' + +The file ../../../../.git/annex/objects/2K/49/SHA256-s0--e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855/SHA256-s0--e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855 doesn't exist. + +On the repository before the sync (inside the Backup) : +file Z.7z +Z.7z: symbolic link to `../../../../.git/annex/objects/J1/f4/SHA256-s696365035--d2dcc67bf2f05fcfc7f42723b2d415d4f057a2eeadc282b40f5bc3724534f2f4/SHA256-s696365035--d2dcc67bf2f05fcfc7f42723b2d415d4f057a2eeadc282b40f5bc3724534f2f4' + +The file ../../../../.git/annex/objects/J1/f4/SHA256-s696365035--d2dcc67bf2f05fcfc7f42723b2d415d4f057a2eeadc282b40f5bc3724534f2f4/SHA256-s696365035--d2dcc67bf2f05fcfc7f42723b2d415d4f057a2eeadc282b40f5bc3724534f2f4 still exist in the repository after the sync. + +3 questions, if somebody could help me : + + - what I do wrong ? + - why the- symlink for every file had change after "cd /media/usb/annex;git fetch laptop; git merge laptop/master&&git annex get .&&git annex sync" + - how could I fix my repository ? recover file from the backup ? how ? Copy every file to start my repository from a new clean state ? + + + diff --git a/doc/forum/Not_sure_how_to_get_my_s3_remote_back.mdwn b/doc/forum/Not_sure_how_to_get_my_s3_remote_back.mdwn new file mode 100644 --- /dev/null +++ b/doc/forum/Not_sure_how_to_get_my_s3_remote_back.mdwn @@ -0,0 +1,31 @@ +My situation goes something like this: + +I have a machine with an annex and a number of special remotes (s3, box, and an rsync'd nas). I also have a git remote that's doesn't have git annex on it, so it's just got the git branches. That machine has some problems so I start getting the annex set up on a different machine. These are the steps that I went through: + +* clone from the git remote +* git annex doesn't think this is an actual annex at this point, so `git annex init` it +* Now I can start the webapp `git annex webapp` +* My rsync'd remote works and the assistant starts downloading the files from there (which is great, it's the local network one) but the box and s3 remotes are disabled (sure, not a huge deal). +* Click enable on the box remote, I have to specify that it's a full backup remote +* Things start copying from box as well, so I disable it until everything from the local network is done +* Click enable on the s3 remote and it wants my AWS creds +* Download those and add it +* Set the remote up the same way, as a full backup. + +At this point, all my files have copied from the rsync remote, so I enable the other remotes. + +Now I want to make sure that all the remotes are set up and working properly. + +I turn off the webapp, turn off direct mode (I think it was indirect mode by default, but I'd been playing with things before then), and `git annex drop ` a file that I don't particularly care about. Everything drops successfully. + +I'm able to `git annex get -f ` and from `` successfully, but when I try to get from the s3 remote, it doesn't give me any output and doesn't download the file. + +Having used regular git annex without the assistant before, I try re-initing the remote `git annex initremote `. It complains that there's no type, so I `git annex initremote type=S3`, then it complains about encryption. `git annex initremote type=S3 encryption=shared`. It says it worked, but I `git annex get -f ` still doesn't do anything. + +After more looking around, it turns out that I may have created a second remote with the same name as the original s3 remote... (figure that out). I use the webapp to rename the remotes so they're different, but neither of them will `get -f` successfully. + +At this point, I turn to you and ask what the heck I did wrong. I tried editing the remote.log and uuid.log files to remove the new s3 remote (and I figured out which one was which) from the git-annex branch. I also marked the new s3 remote as dead, but I still can't get access to s3. + +`git annex fsck -f ` doesn't actually seem to hit s3 (I seem to recall that it used to, it calculated checksums), it just checks some git local information. + +I don't mind deleting my current checkout and starting from the clone step again if you think I've made too much of a mess. At least I know I can get my files off my rsync remote and box :) diff --git a/doc/forum/Ubuntu_PPA/comment_3_fc9cd51558c47718f243437202a11803._comment b/doc/forum/Ubuntu_PPA/comment_3_fc9cd51558c47718f243437202a11803._comment new file mode 100644 --- /dev/null +++ b/doc/forum/Ubuntu_PPA/comment_3_fc9cd51558c47718f243437202a11803._comment @@ -0,0 +1,8 @@ +[[!comment format=mdwn + username="fmarier" + ip="121.98.93.240" + subject="My PPA (Ubuntu Precise) has git-annex 4.20130417" + date="2013-04-27T11:12:26Z" + content=""" +I just went through the pain of backporting 90+ Haskell packages from Debian unstable: https://launchpad.net/~fmarier/+archive/ppa +"""]] diff --git a/doc/forum/Using_for_Music_repo.mdwn b/doc/forum/Using_for_Music_repo.mdwn new file mode 100644 --- /dev/null +++ b/doc/forum/Using_for_Music_repo.mdwn @@ -0,0 +1,13 @@ +Hi, + +I am looking into using git-annex to sync my Music between 3 sources: desktop, laptop, backup, but I'm not sure if this will work ok. + +I notice on the wiki that: "Normally, the content of files in the annex is prevented from being modified. That's a good thing, because it might be the only copy, you wouldn't want to lose it in a fumblefingered mistake." + +But most music players will download artwork, and some of course will dynamically modify/rename files according to meta data. And I may be downloading and/or playing music on both the desktop and laptop. So obviously I wouldn't want to be manually unlocking individual files here. It would kinda interrupt the music listening experience. So how would this work? + +I am assuming that I would always have to do a git annex add *.mp3 *.flac *.jpg before doing a git annex sync. But can I just keep everything unlocked? Any side effects here? Will this work or should I just use rsync? + +Regards, + +bk diff --git a/doc/forum/git-annex_across_two_filesystems.mdwn b/doc/forum/git-annex_across_two_filesystems.mdwn new file mode 100644 --- /dev/null +++ b/doc/forum/git-annex_across_two_filesystems.mdwn @@ -0,0 +1,30 @@ +Hi everyone, + +I need some suggestions on how to operate git-annex best in my setup. + +I need git-annex mainly for its ability to have directories of all my data on all my nodes but not for the data redundancy it can provide. +I have one node that contains 2 filesystems that I want to merge in one git-annex repository. One filesystem (lets call it SAFE) is on top of a RAID1 between two 1TB hds. The other (BIG) is on top of a 3TB hd. SAFE holds data I do not want to loose (like digital pictures). BIG holds data that I can loose. + +I do not have enough disk space on other nodes to get rid of the RAID1. + +This is how I mount my filesystems: + +SAFE at ~/AllData/ + +BIG at ~/AllData/bigfiles/ + +The root of the git repository is at ~/AllData/ however when I do: + +git-annex add ~/AllData/bigfiles/file1 +It says: +add bigfiles/file1 failed + +I assume that is because of file1 being on a different filesystem. + +Do I have to create two repositories: one for each filesystem or do you have any ideas on how to use git-annex best in this scenario? +Having two repositories also has the disadvantage that I need two repositories on all other nodes am I right? + +Thanks for you suggestions + + + diff --git a/doc/forum/managing_multiple_repositories.mdwn b/doc/forum/managing_multiple_repositories.mdwn new file mode 100644 --- /dev/null +++ b/doc/forum/managing_multiple_repositories.mdwn @@ -0,0 +1,3 @@ +I tried about 2 weeks ago using the assistant to create on my netbook and my home laptop 3 repositores, for music, pictures and documents. Since I was also going to be away from home, I set up jabber pairing and box.com for a transfer repository, and then watched everything crash as I didn't know yet about jabber only really working for 1 repository at a time. + +So my new idea is this: one repository at ~/annex, and changing documents, music and pictures to be symlinks to actual documents, music and pictures folders inside ~/annex, allowing me to have just 1 annex to manage. Is this the best way to put everything together if I want to just jabber pairing (and just 1 jabber account)? diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn --- a/doc/git-annex.mdwn +++ b/doc/git-annex.mdwn @@ -168,6 +168,10 @@ alternate locations from which the file can be downloaded. In this mode, addurl can be used both to add new files, or to add urls to existing files. +* rmurl file url + + Record that the file is no longer available at the url. + * import [path ...] Moves files from somewhere outside the git working copy, and adds them to @@ -232,16 +236,41 @@ * initremote name [param=value ...] - Sets up a special remote. The remote's - configuration is specified by the parameters. If a remote - with the specified name has already been configured, its configuration - is modified by any values specified. In either case, the remote will be - added to `.git/config`. + Creates a new special remote, and adds it to `.git/config`. + + The remote's configuration is specified by the parameters. Different + types of special remotes need different configuration values. The + command will prompt for parameters as needed. + All special remotes support encryption. You must either specify + encryption=none to disable encryption, or use encryption=keyid + (or encryption=emailaddress) to specify a gpg key that can access + the encrypted special remote. + Example Amazon S3 remote: - initremote mys3 type=S3 encryption=none datacenter=EU + git annex initremote mys3 type=S3 encryption=me@example.com datacenter=EU +* enableremote name [param=value ...] + + Enables use of an existing special remote in the current repository, + which may be a different repository than the one in which it was + originally created with the initremote command. + + The name of the remote is the same name used when origianlly + creating that remote with "initremote". Run "git annex enableremote" + with no parameters to get a list of special remote names. + + Some special remotes may need parameters to be specified every time. + For example, the directory special remote requires a directory= parameter. + + This command can also be used to modify the configuration of an existing + special remote, by specifying new values for parameters that were originally + set when using initremote. For example, to add a new gpg key to the keys + that can access an encrypted remote: + + git annex initremote mys3 encryption=friend@example.com + * trust [repository ...] Records that a repository is trusted to not unexpectedly lose @@ -904,13 +933,16 @@ * `remote..annex-ignore` If set to `true`, prevents git-annex - from using this remote by default. (You can still request it be used - by the --from and --to options.) + from storing file contents on this remote by default. + (You can still request it be used by the --from and --to options.) This is, for example, useful if the remote is located somewhere without git-annex-shell. (For example, if it's on GitHub). Or, it could be used if the network connection between two repositories is too slow to be used normally. + + This does not prevent git-annex sync (or the git-annex assistant) from + syncing the git repository to the remote. * `remote..annex-sync` diff --git a/doc/install/Debian.mdwn b/doc/install/Debian.mdwn --- a/doc/install/Debian.mdwn +++ b/doc/install/Debian.mdwn @@ -1,8 +1,16 @@ -If using Debian testing or unstable: +## Debian testing or unstable -* `sudo apt-get install git-annex` + sudo apt-get install git-annex -If using Debian 6.0 stable: +## Debian 7.0 "wheezy": -* Follow the instructions to [enable backports](http://backports.debian.org/Instructions/). -* `sudo apt-get -t squeeze-backports install git-annex` + sudo apt-get install git-annex + +Note: This version does not include support for the [[assistant]]. +The version of git-annex in unstable can be easily installed in wheezy. + +## Debian 6.0 "squeeze" + +Follow the instructions to [enable backports](http://backports.debian.org/Instructions/). + + sudo apt-get -t squeeze-backports install git-annex diff --git a/doc/install/OSX/comment_18_537fad5d8854e765499d47602d1ab398._comment b/doc/install/OSX/comment_18_537fad5d8854e765499d47602d1ab398._comment new file mode 100644 --- /dev/null +++ b/doc/install/OSX/comment_18_537fad5d8854e765499d47602d1ab398._comment @@ -0,0 +1,8 @@ +[[!comment format=mdwn + username="https://www.google.com/accounts/o8/id?id=AItOawkurjhi0CRJvgm7QNaZDWS9hitBtavqIpc" + nickname="Bret" + subject="Can't update" + date="2013-04-18T00:58:19Z" + content=""" +The laptop is one of the first macbook pro's with a 32 bit chip, which apple dropped support for in 10.7, so the furthest it can update to is 10.6.x. :( +"""]] diff --git a/doc/install/OSX/comment_19_18d4377f4ded5604d395d73783ba82c9._comment b/doc/install/OSX/comment_19_18d4377f4ded5604d395d73783ba82c9._comment new file mode 100644 --- /dev/null +++ b/doc/install/OSX/comment_19_18d4377f4ded5604d395d73783ba82c9._comment @@ -0,0 +1,8 @@ +[[!comment format=mdwn + username="http://edheil.wordpress.com/" + ip="99.54.57.201" + subject="comment 19" + date="2013-04-18T02:05:34Z" + content=""" +sounds like a prime candidate for a nice lightweight linux distro ;) +"""]] diff --git a/doc/install/Ubuntu.mdwn b/doc/install/Ubuntu.mdwn --- a/doc/install/Ubuntu.mdwn +++ b/doc/install/Ubuntu.mdwn @@ -1,14 +1,29 @@ -If using Ubuntu Oneiric or newer: +## Raring sudo apt-get install git-annex -Otherwise, see [[manual_installation_instructions|install]]. +## Precise -There is a PPA with a newer version of git-annex in it, maintained by -Sergio Rubio. + sudo apt-get install git-annex ---- +Note: This version is too old to include the [[assistant]], but is otherwise +usable. +## Precise PPA + + + +A newer version of git-annex, including the [[assistant]]. +(Maintained by François Marier) + + sudo add-apt-repository ppa:fmarier/ppa + sudo apt-get update + sudo apt-get install git-annex + +## Oneiric + + sudo apt-get install git-annex + Warning: The version of git-annex shipped in Ubuntu Oneiric -has [a bug that prevents upgrades from v1 git-annex repositories](https://bugs.launchpad.net/ubuntu/+source/git-annex/+bug/875958). +had [a bug that prevents upgrades from v1 git-annex repositories](https://bugs.launchpad.net/ubuntu/+source/git-annex/+bug/875958). If you need to upgrade such a repository, get a newer version of git-annex. diff --git a/doc/install/fromscratch.mdwn b/doc/install/fromscratch.mdwn --- a/doc/install/fromscratch.mdwn +++ b/doc/install/fromscratch.mdwn @@ -13,6 +13,7 @@ * [QuickCheck 2](http://hackage.haskell.org/package/QuickCheck) * [json](http://hackage.haskell.org/package/json) * [IfElse](http://hackage.haskell.org/package/IfElse) + * [dlist](http://hackage.haskell.org/package/dlist) * [bloomfilter](http://hackage.haskell.org/package/bloomfilter) * [edit-distance](http://hackage.haskell.org/package/edit-distance) * [hS3](http://hackage.haskell.org/package/hS3) (optional) diff --git a/doc/news/version_4.20130227.mdwn b/doc/news/version_4.20130227.mdwn deleted file mode 100644 --- a/doc/news/version_4.20130227.mdwn +++ /dev/null @@ -1,29 +0,0 @@ -git-annex 4.20130227 released with [[!toggle text="these changes"]] -[[!toggleable text=""" - * annex.version is now set to 4 for direct mode repositories. - * Should now fully support git repositories with core.symlinks=false; - always using git's pseudosymlink files in such repositories. - * webapp: Allow creating repositories on filesystems that lack support for - symlinks. - * webapp: Can now add a new local repository, and make it sync with - the main local repository. - * Android: Bundle now includes openssh. - * Android: Support ssh connection caching. - * Android: Assistant is fully working. (But no webapp yet.) - * Direct mode: Support filesystems like FAT which can change their inodes - each time they are mounted. - * Direct mode: Fix support for adding a modified file. - * Avoid passing -p to rsync, to interoperate with crippled filesystems. - Closes: #[700282](http://bugs.debian.org/700282) - * Additional GIT\_DIR support bugfixes. May actually work now. - * webapp: Display any error message from git init if it fails to create - a repository. - * Fix a reversion in matching globs introduced in the last release, - where "*" did not match files inside subdirectories. No longer uses - the Glob library. - * copy: Update location log when no copy was performed, if the location - log was out of date. - * Makefile now builds using cabal, taking advantage of cabal's automatic - detection of appropriate build flags. - * test: The test suite is now built into the git-annex binary, and can - be run at any time."""]] diff --git a/doc/news/version_4.20130501.mdwn b/doc/news/version_4.20130501.mdwn new file mode 100644 --- /dev/null +++ b/doc/news/version_4.20130501.mdwn @@ -0,0 +1,57 @@ +git-annex 4.20130501 released with [[!toggle text="these changes"]] +[[!toggleable text=""" + * sync, assistant: Behavior changes: Sync with remotes that have + annex-ignore set, so that git remotes on servers without git-annex + installed can be used to keep clients' git repos in sync. + * assistant: Work around misfeature in git 1.8.2 that makes + `git commit --alow-empty -m ""` run an editor. + * sync: Bug fix, avoid adding to the annex the + dummy symlinks used on crippled filesystems. + * Add public repository group. + (And inpreferreddir to preferred content expressions.) + * webapp: Can now set up Internet Archive repositories. + * S3: Dropping content from the Internet Archive doesn't work, but + their API indicates it does. Always refuse to drop from there. + * Automatically register public urls for files uploaded to the + Internet Archive. + * To enable an existing special remote, the new enableremote command + must be used. The initremote command now is used only to create + new special remotes. + * initremote: If two existing remotes have the same name, + prefer the one with a higher trust level. + * assistant: Improved XMPP protocol to better support multiple repositories + using the same XMPP account. Fixes bad behavior when sharing with a friend + when you or the friend have multiple reposotories on an XMPP account. + Note that XMPP pairing with your own devices still pairs with all + repositories using your XMPP account. + * assistant: Fix bug that could cause incoming pushes to not get + merged into the local tree. Particularly affected XMPP pushes. + * webapp: Display some additional information about a repository on + its edit page. + * webapp: Install FDO desktop menu file when started in standalone mode. + * webapp: Don't default to making repository in cwd when started + from within a directory containing a git-annex file (eg, standalone + tarball directory). + * Detect systems that have no user name set in GECOS, and also + don't have user.name set in git config, and put in a workaround + so that commits to the git-annex branch (and the assistant) + will still succeed despite git not liking the system configuration. + * webapp: When told to add a git repository on a remote server, and + the repository already exists as a non-bare repository, use it, + rather than initializing a bare repository in the same directory. + * direct, indirect: Refuse to do anything when the assistant + or git-annex watch daemon is running. + * assistant: When built with git before 1.8.0, use `git remote rm` + to delete a remote. Newer git uses `git remote remove`. + * rmurl: New command, removes one of the recorded urls for a file. + * Detect when the remote is broken like bitbucket is, and exits 0 when + it fails to run git-annex-shell. + * assistant: Several improvements to performance and behavior when + performing bulk adds of a large number of files (tens to hundreds + of thousands). + * assistant: Sanitize XMPP presence information logged for debugging. + * webapp: Now automatically fills in any creds used by an existing remote + when creating a new remote of the same type. Done for Internet Archive, + S3, Glacier, and Box.com remotes. + * Store an annex-uuid file in the bucket when setting up a new S3 remote. + * Support building with DAV 0.4."""]] diff --git a/doc/preferred_content.mdwn b/doc/preferred_content.mdwn --- a/doc/preferred_content.mdwn +++ b/doc/preferred_content.mdwn @@ -72,6 +72,18 @@ expression. It'll make it prefer to get content that's not present, and drop content that is present! Don't go there.. +### difference: "inpreferreddir" + +There's a special "inpreferreddir" keyword you can use in a +preferred content expression of a special remote. This means that the +content is preferred if it's in a directory (located anywhere in the tree) +with a special name. + +The name of the directory can be configured using +`git annex initremote $remote preferreddir=$dirname` + +(If no directory name is configured, it uses "public" by default.) + ## standard expressions git-annex comes with some standard preferred content expressions, that can @@ -165,6 +177,18 @@ reached an archive repository. `present and ($client)` + +### public + +This is used for publishing information to a repository that can be +publically accessed. Only files in a directory with a particular name +will be published. (The directory can be located anywhere in the +repository.) + +The name of the directory can be configured using +`git annex initremote $remote preferreddir=$dirname` + +`inpreferreddir` ### unwanted diff --git a/doc/special_remotes/S3.mdwn b/doc/special_remotes/S3.mdwn --- a/doc/special_remotes/S3.mdwn +++ b/doc/special_remotes/S3.mdwn @@ -21,7 +21,7 @@ every clone of the repository to access the encrypted data (use with caution). Note that additional gpg keys can be given access to a remote by - rerunning initremote with the new key id. See [[encryption]]. + running enableremote with the new key id. See [[encryption]]. * `embedcreds` - Optional. Set to "yes" embed the login credentials inside the git repository, which allows other clones to also access them. This is diff --git a/doc/special_remotes/bup.mdwn b/doc/special_remotes/bup.mdwn --- a/doc/special_remotes/bup.mdwn +++ b/doc/special_remotes/bup.mdwn @@ -26,7 +26,7 @@ every clone of the repository to access the encrypted data (use with caution). Note that additional gpg keys can be given access to a remote by - rerunning initremote with the new key id. See [[encryption]]. + running enableremote with the new key id. See [[encryption]]. * `buprepo` - Required. This is passed to `bup` as the `--remote` to use to store data. To create the repository,`bup init` will be run. diff --git a/doc/special_remotes/directory.mdwn b/doc/special_remotes/directory.mdwn --- a/doc/special_remotes/directory.mdwn +++ b/doc/special_remotes/directory.mdwn @@ -16,7 +16,7 @@ every clone of the repository to decrypt the encrypted data. Note that additional gpg keys can be given access to a remote by - rerunning initremote with the new key id. See [[encryption]]. + running enableremote with the new key id. See [[encryption]]. * `chunksize` - Avoid storing files larger than the specified size in the directory. For use on directories on mount points that have file size diff --git a/doc/special_remotes/glacier.mdwn b/doc/special_remotes/glacier.mdwn --- a/doc/special_remotes/glacier.mdwn +++ b/doc/special_remotes/glacier.mdwn @@ -27,7 +27,7 @@ every clone of the repository to access the encrypted data (use with caution). Note that additional gpg keys can be given access to a remote by - rerunning initremote with the new key id. See [[encryption]]. + running enableremote with the new key id. See [[encryption]]. * `embedcreds` - Optional. Set to "yes" embed the login credentials inside the git repository, which allows other clones to also access them. This is diff --git a/doc/special_remotes/hook.mdwn b/doc/special_remotes/hook.mdwn --- a/doc/special_remotes/hook.mdwn +++ b/doc/special_remotes/hook.mdwn @@ -31,7 +31,7 @@ every clone of the repository to access the encrypted data. Note that additional gpg keys can be given access to a remote by - rerunning initremote with the new key id. See [[encryption]]. + running enableremote with the new key id. See [[encryption]]. * `hooktype` - Required. This specifies a collection of hooks to use for this remote. diff --git a/doc/special_remotes/rsync.mdwn b/doc/special_remotes/rsync.mdwn --- a/doc/special_remotes/rsync.mdwn +++ b/doc/special_remotes/rsync.mdwn @@ -21,7 +21,7 @@ every clone of the repository to decrypt the encrypted data. Note that additional gpg keys can be given access to a remote by - rerunning initremote with the new key id. See [[encryption]]. + running enableremote with the new key id. See [[encryption]]. * `rsyncurl` - Required. This is the url or `hostname:/directory` to pass to rsync to tell it where to store content. @@ -31,7 +31,7 @@ setups, but not with some hosting providers that do not expose rsynced filenames to the shell. You'll know you need this option if `git annex get` from the special remote fails with an error message containing a single - quote (`'`) character. If that happens, you can re-run initremote + quote (`'`) character. If that happens, you can run enableremote setting shellescape=no. The `annex-rsync-options` git configuration setting can be used to pass diff --git a/doc/special_remotes/webdav.mdwn b/doc/special_remotes/webdav.mdwn --- a/doc/special_remotes/webdav.mdwn +++ b/doc/special_remotes/webdav.mdwn @@ -16,7 +16,7 @@ every clone of the repository to access the encrypted data (use with caution). Note that additional gpg keys can be given access to a remote by - rerunning initremote with the new key id. See [[encryption]]. + running enableremote with the new key id. See [[encryption]]. * `embedcreds` - Optional. Set to "yes" embed the login credentials inside the git repository, which allows other clones to also access them. This is diff --git a/doc/special_remotes/xmpp/comment_2_9fc3f512020b7eb2591d6b7b2e8de2d7._comment b/doc/special_remotes/xmpp/comment_2_9fc3f512020b7eb2591d6b7b2e8de2d7._comment new file mode 100644 --- /dev/null +++ b/doc/special_remotes/xmpp/comment_2_9fc3f512020b7eb2591d6b7b2e8de2d7._comment @@ -0,0 +1,10 @@ +[[!comment format=mdwn + username="https://www.google.com/accounts/o8/id?id=AItOawmRFKwny4rArBaz-36xTcsJYqKIgdDaw5Q" + nickname="Andrew" + subject="comment 2" + date="2013-04-17T22:28:39Z" + content=""" +Yeah, I agree, this would be nice. + +For your own domain, you can configure DNS like this: [[http://support.google.com/a/bin/answer.py?hl=en&answer=34143]] to make XMPP find the right server. But for some that's not an option and the \"advanced\" mode would be useful in that case. +"""]] diff --git a/doc/templates/bugtemplate.mdwn b/doc/templates/bugtemplate.mdwn --- a/doc/templates/bugtemplate.mdwn +++ b/doc/templates/bugtemplate.mdwn @@ -1,12 +1,18 @@ -What steps will reproduce the problem? +### Please describe the problem. -What is the expected output? What do you see instead? +### What steps will reproduce the problem? -What version of git-annex are you using? On what operating system? +### What version of git-annex are you using? On what operating system? -Please provide any additional information below. +### Please provide any additional information below. +[[!format sh """ +# If you can, paste a complete transcript of the problem occurring here. +# If the problem is with the git-annex assistant, paste in .git/annex/debug.log + +# End of transcript or log. +"""]] diff --git a/doc/tips/Internet_Archive_via_S3.mdwn b/doc/tips/Internet_Archive_via_S3.mdwn --- a/doc/tips/Internet_Archive_via_S3.mdwn +++ b/doc/tips/Internet_Archive_via_S3.mdwn @@ -8,6 +8,15 @@ your files to there. Of course, your use of the Internet Archive must comply with their [terms of service](http://www.archive.org/about/terms.php). +A nice added feature is that whenever git-annex sends a file to the +Internet Archive, it records its url, the same as if you'd run `git annex +addurl`. So any users who can clone your repository can download the files +from archive.org, without needing any login or password info. This makes +the Internet Archive a nice way to publish the large files associated with +a public git repository. + +---- + Sign up for an account, and get your access keys here: diff --git a/doc/todo/wishlist:_history_of_operations.mdwn b/doc/todo/wishlist:_history_of_operations.mdwn new file mode 100644 --- /dev/null +++ b/doc/todo/wishlist:_history_of_operations.mdwn @@ -0,0 +1,8 @@ +Hi, + +I would love to have a page of "history" or "events" in the webapp. Similar to how Dropbox or Box show it. +I've been using git-annex for my personal files for a few months now, and I feel like this is the only feature missing to start using it in a production multi-user environment. + +Thanks + +[[!tag design/assistant]] diff --git a/doc/users/fmarier.mdwn b/doc/users/fmarier.mdwn --- a/doc/users/fmarier.mdwn +++ b/doc/users/fmarier.mdwn @@ -1,6 +1,6 @@ # François Marier -Free Software and Debian Developer. Lead developer of [Libravatar](http://www.libravatar.org) +Free Software and Debian Developer. Lead developer of [Libravatar](https://www.libravatar.org) -* [Blog](http://feeding.cloud.geek.nz) -* [Identica](http://identi.ca/fmarier) / [Twitter](http://twitter.com/fmarier) +* [Blog](http://feeding.cloud.geek.nz) and [homepage](http://fmarier.org) +* [Identica](http://identi.ca/fmarier) / [Twitter](https://twitter.com/fmarier) diff --git a/doc/walkthrough/modifying_annexed_files.mdwn b/doc/walkthrough/modifying_annexed_files.mdwn --- a/doc/walkthrough/modifying_annexed_files.mdwn +++ b/doc/walkthrough/modifying_annexed_files.mdwn @@ -1,4 +1,6 @@ Normally, the content of files in the annex is prevented from being modified. +(Unless your repository is using [[direct_mode]].) + That's a good thing, because it might be the only copy, you wouldn't want to lose it in a fumblefingered mistake. diff --git a/git-annex.1 b/git-annex.1 --- a/git-annex.1 +++ b/git-annex.1 @@ -154,6 +154,9 @@ alternate locations from which the file can be downloaded. In this mode, addurl can be used both to add new files, or to add urls to existing files. .IP +.IP "rmurl file url" +Record that the file is no longer available at the url. +.IP .IP "import [path ...]" Moves files from somewhere outside the git working copy, and adds them to the annex. Individual files to import can be specified. @@ -211,16 +214,40 @@ "here". .IP .IP "initremote name [param=value ...]" -Sets up a special remote. The remote's -configuration is specified by the parameters. If a remote -with the specified name has already been configured, its configuration -is modified by any values specified. In either case, the remote will be -added to .git/config. +Creates a new special remote, and adds it to .git/config. .IP +The remote's configuration is specified by the parameters. Different +types of special remotes need different configuration values. The +command will prompt for parameters as needed. +.IP +All special remotes support encryption. You must either specify +encryption=none to disable encryption, or use encryption=keyid +(or encryption=emailaddress) to specify a gpg key that can access +the encrypted special remote. +.IP Example Amazon S3 remote: .IP - initremote mys3 type=S3 encryption=none datacenter=EU + git annex initremote mys3 type=S3 encryption=me@example.com datacenter=EU .IP +.IP "enableremote name [param=value ...]" +Enables use of an existing special remote in the current repository, +which may be a different repository than the one in which it was +originally created with the initremote command. +.IP +The name of the remote is the same name used when origianlly +creating that remote with "initremote". Run "git annex enableremote" +with no parameters to get a list of special remote names. +.IP +Some special remotes may need parameters to be specified every time. +For example, the directory special remote requires a directory= parameter. +.IP +This command can also be used to modify the configuration of an existing +special remote, by specifying new values for parameters that were originally +set when using initremote. For example, to add a new gpg key to the keys +that can access an encrypted remote: +.IP + git annex initremote mys3 encryption=friend@example.com +.IP .IP "trust [repository ...]" Records that a repository is trusted to not unexpectedly lose content. Use with care. @@ -797,13 +824,16 @@ .IP .IP "remote..annex\-ignore" If set to true, prevents git\-annex -from using this remote by default. (You can still request it be used -by the \-\-from and \-\-to options.) +from storing file contents on this remote by default. +(You can still request it be used by the \-\-from and \-\-to options.) .IP This is, for example, useful if the remote is located somewhere without git\-annex\-shell. (For example, if it's on GitHub). Or, it could be used if the network connection between two repositories is too slow to be used normally. +.IP +This does not prevent git\-annex sync (or the git\-annex assistant) from +syncing the git repository to the remote. .IP .IP "remote..annex\-sync" If set to false, prevents git\-annex sync (and the git\-annex assistant) diff --git a/git-annex.cabal b/git-annex.cabal --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1,5 +1,5 @@ Name: git-annex -Version: 4.20130417 +Version: 4.20130501 Cabal-Version: >= 1.8 License: GPL Maintainer: Joey Hess @@ -70,7 +70,7 @@ extensible-exceptions, dataenc, SHA, process, json, base (>= 4.5 && < 4.8), monad-control, transformers-base, lifted-base, IfElse, text, QuickCheck >= 2.1, bloomfilter, edit-distance, process, - SafeSemaphore, uuid, random, regex-tdfa + SafeSemaphore, uuid, random, regex-tdfa, dlist -- Need to list these because they're generated from .hsc files. Other-Modules: Utility.Touch Utility.Mounts Include-Dirs: Utility @@ -113,7 +113,6 @@ if (! os(windows) && ! os(solaris) && ! os(linux)) CPP-Options: -DWITH_KQUEUE C-Sources: Utility/libkqueue.c - Includes: sys/event.h if os(linux) && flag(Dbus) Build-Depends: dbus (>= 0.10.3) diff --git a/standalone/android/Makefile b/standalone/android/Makefile --- a/standalone/android/Makefile +++ b/standalone/android/Makefile @@ -18,13 +18,13 @@ GITTREE=$(GIT_ANNEX_ANDROID_SOURCETREE)/git/installed-tree build: start - $(MAKE) $(GIT_ANNEX_ANDROID_SOURCETREE)/openssl - $(MAKE) $(GIT_ANNEX_ANDROID_SOURCETREE)/openssh - $(MAKE) $(GIT_ANNEX_ANDROID_SOURCETREE)/busybox - $(MAKE) $(GIT_ANNEX_ANDROID_SOURCETREE)/rsync - $(MAKE) $(GIT_ANNEX_ANDROID_SOURCETREE)/gnupg - $(MAKE) $(GIT_ANNEX_ANDROID_SOURCETREE)/git - $(MAKE) $(GIT_ANNEX_ANDROID_SOURCETREE)/term + $(MAKE) $(GIT_ANNEX_ANDROID_SOURCETREE)/openssl/build-stamp + $(MAKE) $(GIT_ANNEX_ANDROID_SOURCETREE)/openssh/build-stamp + $(MAKE) $(GIT_ANNEX_ANDROID_SOURCETREE)/busybox/build-stamp + $(MAKE) $(GIT_ANNEX_ANDROID_SOURCETREE)/rsync/build-stamp + $(MAKE) $(GIT_ANNEX_ANDROID_SOURCETREE)/gnupg/build-stamp + $(MAKE) $(GIT_ANNEX_ANDROID_SOURCETREE)/git/build-stamp + $(MAKE) $(GIT_ANNEX_ANDROID_SOURCETREE)/term/build-stamp # Debug build because it does not need signing keys. cd $(GIT_ANNEX_ANDROID_SOURCETREE)/term && tools/build-debug @@ -79,12 +79,12 @@ mkdir -p ../../tmp cp $(GIT_ANNEX_ANDROID_SOURCETREE)/term/bin/Term-debug.apk ../../tmp/git-annex.apk -$(GIT_ANNEX_ANDROID_SOURCETREE)/openssl: +$(GIT_ANNEX_ANDROID_SOURCETREE)/openssl/build-stamp: cd $(GIT_ANNEX_ANDROID_SOURCETREE)/openssl && CC=$$(which cc) ./Configure android cd $(GIT_ANNEX_ANDROID_SOURCETREE)/openssl && $(MAKE) touch $@ -$(GIT_ANNEX_ANDROID_SOURCETREE)/openssh: openssh.patch openssh.config.h +$(GIT_ANNEX_ANDROID_SOURCETREE)/openssh/build-stamp: openssh.patch openssh.config.h cd $(GIT_ANNEX_ANDROID_SOURCETREE)/openssh && git reset --hard cd $(GIT_ANNEX_ANDROID_SOURCETREE)/openssh && ./configure --host=arm-linux-androideabi --with-ssl-dir=../openssl --without-openssl-header-check cat openssh.patch | (cd $(GIT_ANNEX_ANDROID_SOURCETREE)/openssh && patch -p1) @@ -94,31 +94,31 @@ cd $(GIT_ANNEX_ANDROID_SOURCETREE)/openssh && $(MAKE) ssh ssh-keygen touch $@ -$(GIT_ANNEX_ANDROID_SOURCETREE)/busybox: busybox_config +$(GIT_ANNEX_ANDROID_SOURCETREE)/busybox/build-stamp: busybox_config cp busybox_config $(GIT_ANNEX_ANDROID_SOURCETREE)/busybox/.config cd $(GIT_ANNEX_ANDROID_SOURCETREE)/busybox && yes '' | $(MAKE) oldconfig cd $(GIT_ANNEX_ANDROID_SOURCETREE)/busybox && $(MAKE) touch $@ -$(GIT_ANNEX_ANDROID_SOURCETREE)/git: +$(GIT_ANNEX_ANDROID_SOURCETREE)/git/build-stamp: cd $(GIT_ANNEX_ANDROID_SOURCETREE)/git && $(MAKE) install NO_OPENSSL=1 NO_GETTEXT=1 NO_GECOS_IN_PWENT=1 NO_GETPASS=1 NO_NSEC=1 NO_MKDTEMP=1 NO_PTHREADS=1 NO_PERL=1 NO_CURL=1 NO_EXPAT=1 NO_TCLTK=1 NO_ICONV=1 prefix= DESTDIR=installed-tree touch $@ -$(GIT_ANNEX_ANDROID_SOURCETREE)/rsync: rsync.patch +$(GIT_ANNEX_ANDROID_SOURCETREE)/rsync/build-stamp: rsync.patch cat rsync.patch | (cd $(GIT_ANNEX_ANDROID_SOURCETREE)/rsync && git reset --hard origin/master && git am) cp $(GIT_ANNEX_ANDROID_SOURCETREE)/automake/lib/config.sub $(GIT_ANNEX_ANDROID_SOURCETREE)/automake/lib/config.guess $(GIT_ANNEX_ANDROID_SOURCETREE)/rsync/ cd $(GIT_ANNEX_ANDROID_SOURCETREE)/rsync && ./configure --host=arm-linux-androideabi --disable-locale --disable-iconv-open --disable-iconv --disable-acl-support --disable-xattr-support cd $(GIT_ANNEX_ANDROID_SOURCETREE)/rsync && $(MAKE) touch $@ -$(GIT_ANNEX_ANDROID_SOURCETREE)/gnupg: +$(GIT_ANNEX_ANDROID_SOURCETREE)/gnupg/build-stamp: cd $(GIT_ANNEX_ANDROID_SOURCETREE)/gnupg && git checkout gnupg-1.4.13 cd $(GIT_ANNEX_ANDROID_SOURCETREE)/gnupg && ./autogen.sh cd $(GIT_ANNEX_ANDROID_SOURCETREE)/gnupg && ./configure --host=arm-linux-androideabi --disable-gnupg-iconv --enable-minimal --disable-card-support --disable-agent-support --disable-photo-viewers --disable-keyserver-helpers --disable-nls cd $(GIT_ANNEX_ANDROID_SOURCETREE)/gnupg; $(MAKE) || true # expected failure in doc build touch $@ -$(GIT_ANNEX_ANDROID_SOURCETREE)/term: term.patch icons +$(GIT_ANNEX_ANDROID_SOURCETREE)/term/build-stamp: term.patch icons cd $(GIT_ANNEX_ANDROID_SOURCETREE)/term && git reset --hard cat term.patch | (cd $(GIT_ANNEX_ANDROID_SOURCETREE)/term && patch -p1) (cd icons && tar c .) | (cd $(GIT_ANNEX_ANDROID_SOURCETREE)/term/res && tar x) diff --git a/standalone/android/evilsplicer-headers.hs b/standalone/android/evilsplicer-headers.hs --- a/standalone/android/evilsplicer-headers.hs +++ b/standalone/android/evilsplicer-headers.hs @@ -20,6 +20,7 @@ import qualified Yesod.Routes.Dispatch import qualified WaiAppStatic.Storage.Embedded import qualified Data.FileEmbed +import qualified Data.ByteString.Internal {- End EvilSplicer headers. -} diff --git a/standalone/android/haskell-patches/DAV-0.3-0001-build-without-TH.patch b/standalone/android/haskell-patches/DAV-0.3-0001-build-without-TH.patch new file mode 100644 --- /dev/null +++ b/standalone/android/haskell-patches/DAV-0.3-0001-build-without-TH.patch @@ -0,0 +1,306 @@ +From d195f807dac2351d29aeff00d2aee3e151eb82e3 Mon Sep 17 00:00:00 2001 +From: Joey Hess +Date: Thu, 18 Apr 2013 19:37:28 -0400 +Subject: [PATCH] build without TH + +Used the EvilSplicer to expand the TH + +Left off CmdArgs to save time. +--- + DAV.cabal | 20 +---- + Network/Protocol/HTTP/DAV.hs | 53 ++++++++++--- + Network/Protocol/HTTP/DAV/TH.hs | 167 ++++++++++++++++++++++++++++++++++++++- + 3 files changed, 207 insertions(+), 33 deletions(-) + +diff --git a/DAV.cabal b/DAV.cabal +index 774d4e5..8b85133 100644 +--- a/DAV.cabal ++++ b/DAV.cabal +@@ -38,25 +38,7 @@ library + , transformers >= 0.3 + , xml-conduit >= 1.0 && <= 1.1 + , xml-hamlet >= 0.4 && <= 0.5 +-executable hdav +- main-is: hdav.hs +- ghc-options: -Wall +- build-depends: base >= 4.5 && <= 5 +- , bytestring +- , bytestring +- , case-insensitive >= 0.4 +- , cmdargs >= 0.9 +- , containers +- , http-conduit >= 1.4 +- , http-types >= 0.7 +- , lens >= 3.0 +- , lifted-base >= 0.1 +- , mtl >= 2.1 +- , network >= 2.3 +- , resourcet >= 0.3 +- , transformers >= 0.3 +- , xml-conduit >= 1.0 && <= 1.1 +- , xml-hamlet >= 0.4 && <= 0.5 ++ , text + + source-repository head + type: git +diff --git a/Network/Protocol/HTTP/DAV.hs b/Network/Protocol/HTTP/DAV.hs +index 02e5d15..c0be362 100644 +--- a/Network/Protocol/HTTP/DAV.hs ++++ b/Network/Protocol/HTTP/DAV.hs +@@ -52,7 +52,8 @@ import Network.HTTP.Types (hContentType, Method, Status, RequestHeaders, unautho + + import qualified Text.XML as XML + import Text.XML.Cursor (($/), (&/), element, node, fromDocument, checkName) +-import Text.Hamlet.XML (xml) ++import Text.Hamlet.XML ++import qualified Data.Text + + import Data.CaseInsensitive (mk) + +@@ -246,18 +247,48 @@ makeCollection url username password = withDS url username password $ + propname :: XML.Document + propname = XML.Document (XML.Prologue [] Nothing []) root [] + where +- root = XML.Element "D:propfind" (Map.fromList [("xmlns:D", "DAV:")]) [xml| +- +-|] ++ root = XML.Element "D:propfind" (Map.fromList [("xmlns:D", "DAV:")]) $ concat ++ [[XML.NodeElement ++ (XML.Element ++ (XML.Name ++ (Data.Text.pack "D:allprop") Nothing Nothing) ++ Map.empty ++ (concat []))]] ++ + + locky :: XML.Document + locky = XML.Document (XML.Prologue [] Nothing []) root [] + where +- root = XML.Element "D:lockinfo" (Map.fromList [("xmlns:D", "DAV:")]) [xml| +- +- +- +- +-Haskell DAV user +-|] ++ root = XML.Element "D:lockinfo" (Map.fromList [("xmlns:D", "DAV:")]) $ concat ++ [[XML.NodeElement ++ (XML.Element ++ (XML.Name ++ (Data.Text.pack "D:lockscope") Nothing Nothing) ++ Map.empty ++ (concat ++ [[XML.NodeElement ++ (XML.Element ++ (XML.Name ++ (Data.Text.pack "D:exclusive") Nothing Nothing) ++ Map.empty ++ (concat []))]]))], ++ [XML.NodeElement ++ (XML.Element ++ (XML.Name ++ (Data.Text.pack "D:locktype") Nothing Nothing) ++ Map.empty ++ (concat ++ [[XML.NodeElement ++ (XML.Element ++ (XML.Name (Data.Text.pack "D:write") Nothing Nothing) ++ Map.empty ++ (concat []))]]))], ++ [XML.NodeElement ++ (XML.Element ++ (XML.Name (Data.Text.pack "D:owner") Nothing Nothing) ++ Map.empty ++ (concat ++ [[XML.NodeContent ++ (Data.Text.pack "Haskell DAV user")]]))]] ++ + +diff --git a/Network/Protocol/HTTP/DAV/TH.hs b/Network/Protocol/HTTP/DAV/TH.hs +index 036a2bc..4d3c0f4 100644 +--- a/Network/Protocol/HTTP/DAV/TH.hs ++++ b/Network/Protocol/HTTP/DAV/TH.hs +@@ -16,11 +16,13 @@ + -- You should have received a copy of the GNU General Public License + -- along with this program. If not, see . + +-{-# LANGUAGE TemplateHaskell #-} ++{-# LANGUAGE RankNTypes #-} + + module Network.Protocol.HTTP.DAV.TH where + +-import Control.Lens (makeLenses) ++import Control.Lens ++import qualified Control.Lens.Type ++import qualified Data.Functor + import qualified Data.ByteString as B + import Network.HTTP.Conduit (Manager, Request) + +@@ -33,4 +35,163 @@ data DAVContext a = DAVContext { + , _basicusername :: B.ByteString + , _basicpassword :: B.ByteString + } +-makeLenses ''DAVContext ++allowedMethods :: ++ forall a_a4Oo. ++ Control.Lens.Type.Lens' (DAVContext a_a4Oo) [B.ByteString] ++allowedMethods ++ _f_a5tt ++ (DAVContext __allowedMethods'_a5tu ++ __baseRequest_a5tw ++ __complianceClasses_a5tx ++ __httpManager_a5ty ++ __lockToken_a5tz ++ __basicusername_a5tA ++ __basicpassword_a5tB) ++ = ((\ __allowedMethods_a5tv ++ -> DAVContext ++ __allowedMethods_a5tv ++ __baseRequest_a5tw ++ __complianceClasses_a5tx ++ __httpManager_a5ty ++ __lockToken_a5tz ++ __basicusername_a5tA ++ __basicpassword_a5tB) ++ Data.Functor.<$> (_f_a5tt __allowedMethods'_a5tu)) ++{-# INLINE allowedMethods #-} ++baseRequest :: ++ forall a_a4Oo a_a5tC. ++ Control.Lens.Type.Lens (DAVContext a_a4Oo) (DAVContext a_a5tC) (Request a_a4Oo) (Request a_a5tC) ++baseRequest ++ _f_a5tD ++ (DAVContext __allowedMethods_a5tE ++ __baseRequest'_a5tF ++ __complianceClasses_a5tH ++ __httpManager_a5tI ++ __lockToken_a5tJ ++ __basicusername_a5tK ++ __basicpassword_a5tL) ++ = ((\ __baseRequest_a5tG ++ -> DAVContext ++ __allowedMethods_a5tE ++ __baseRequest_a5tG ++ __complianceClasses_a5tH ++ __httpManager_a5tI ++ __lockToken_a5tJ ++ __basicusername_a5tK ++ __basicpassword_a5tL) ++ Data.Functor.<$> (_f_a5tD __baseRequest'_a5tF)) ++{-# INLINE baseRequest #-} ++basicpassword :: ++ forall a_a4Oo. ++ Control.Lens.Type.Lens' (DAVContext a_a4Oo) B.ByteString ++basicpassword ++ _f_a5tM ++ (DAVContext __allowedMethods_a5tN ++ __baseRequest_a5tO ++ __complianceClasses_a5tP ++ __httpManager_a5tQ ++ __lockToken_a5tR ++ __basicusername_a5tS ++ __basicpassword'_a5tT) ++ = ((\ __basicpassword_a5tU ++ -> DAVContext ++ __allowedMethods_a5tN ++ __baseRequest_a5tO ++ __complianceClasses_a5tP ++ __httpManager_a5tQ ++ __lockToken_a5tR ++ __basicusername_a5tS ++ __basicpassword_a5tU) ++ Data.Functor.<$> (_f_a5tM __basicpassword'_a5tT)) ++{-# INLINE basicpassword #-} ++basicusername :: ++ forall a_a4Oo. ++ Control.Lens.Type.Lens' (DAVContext a_a4Oo) B.ByteString ++basicusername ++ _f_a5tV ++ (DAVContext __allowedMethods_a5tW ++ __baseRequest_a5tX ++ __complianceClasses_a5tY ++ __httpManager_a5tZ ++ __lockToken_a5u0 ++ __basicusername'_a5u1 ++ __basicpassword_a5u3) ++ = ((\ __basicusername_a5u2 ++ -> DAVContext ++ __allowedMethods_a5tW ++ __baseRequest_a5tX ++ __complianceClasses_a5tY ++ __httpManager_a5tZ ++ __lockToken_a5u0 ++ __basicusername_a5u2 ++ __basicpassword_a5u3) ++ Data.Functor.<$> (_f_a5tV __basicusername'_a5u1)) ++{-# INLINE basicusername #-} ++complianceClasses :: ++ forall a_a4Oo. ++ Control.Lens.Type.Lens' (DAVContext a_a4Oo) [B.ByteString] ++complianceClasses ++ _f_a5u4 ++ (DAVContext __allowedMethods_a5u5 ++ __baseRequest_a5u6 ++ __complianceClasses'_a5u7 ++ __httpManager_a5u9 ++ __lockToken_a5ua ++ __basicusername_a5ub ++ __basicpassword_a5uc) ++ = ((\ __complianceClasses_a5u8 ++ -> DAVContext ++ __allowedMethods_a5u5 ++ __baseRequest_a5u6 ++ __complianceClasses_a5u8 ++ __httpManager_a5u9 ++ __lockToken_a5ua ++ __basicusername_a5ub ++ __basicpassword_a5uc) ++ Data.Functor.<$> (_f_a5u4 __complianceClasses'_a5u7)) ++{-# INLINE complianceClasses #-} ++httpManager :: ++ forall a_a4Oo. Control.Lens.Type.Lens' (DAVContext a_a4Oo) Manager ++httpManager ++ _f_a5ud ++ (DAVContext __allowedMethods_a5ue ++ __baseRequest_a5uf ++ __complianceClasses_a5ug ++ __httpManager'_a5uh ++ __lockToken_a5uj ++ __basicusername_a5uk ++ __basicpassword_a5ul) ++ = ((\ __httpManager_a5ui ++ -> DAVContext ++ __allowedMethods_a5ue ++ __baseRequest_a5uf ++ __complianceClasses_a5ug ++ __httpManager_a5ui ++ __lockToken_a5uj ++ __basicusername_a5uk ++ __basicpassword_a5ul) ++ Data.Functor.<$> (_f_a5ud __httpManager'_a5uh)) ++{-# INLINE httpManager #-} ++lockToken :: ++ forall a_a4Oo. ++ Control.Lens.Type.Lens' (DAVContext a_a4Oo) (Maybe B.ByteString) ++lockToken ++ _f_a5um ++ (DAVContext __allowedMethods_a5un ++ __baseRequest_a5uo ++ __complianceClasses_a5up ++ __httpManager_a5uq ++ __lockToken'_a5ur ++ __basicusername_a5ut ++ __basicpassword_a5uu) ++ = ((\ __lockToken_a5us ++ -> DAVContext ++ __allowedMethods_a5un ++ __baseRequest_a5uo ++ __complianceClasses_a5up ++ __httpManager_a5uq ++ __lockToken_a5us ++ __basicusername_a5ut ++ __basicpassword_a5uu) ++ Data.Functor.<$> (_f_a5um __lockToken'_a5ur)) ++{-# INLINE lockToken #-} +-- +1.7.10.4 + diff --git a/standalone/android/haskell-patches/gsasl-0.3.5-0001-link-with-libgsasl.patch b/standalone/android/haskell-patches/gsasl-0.3.5-0001-link-with-libgsasl.patch new file mode 100644 --- /dev/null +++ b/standalone/android/haskell-patches/gsasl-0.3.5-0001-link-with-libgsasl.patch @@ -0,0 +1,27 @@ +From c7d39a8f91af93203194313195a79b04d80a16a3 Mon Sep 17 00:00:00 2001 +From: Joey Hess +Date: Sun, 21 Apr 2013 15:22:00 -0400 +Subject: [PATCH] link with libgsasl + +This requires libgsasl.a (and no .so) be installed in the ugly hardcoded +lib dir. When built this way, the haskell gsasl library will link the +library into executables with no further options. +--- + gsasl.cabal | 1 + + 1 file changed, 1 insertion(+) + +diff --git a/gsasl.cabal b/gsasl.cabal +index c5c2b19..a31cc71 100644 +--- a/gsasl.cabal ++++ b/gsasl.cabal +@@ -27,6 +27,7 @@ library + ghc-options: -Wall -O2 + hs-source-dirs: lib + c-sources: cbits/hsgsasl-shim.c ++ LD-Options: -L /home/joey/.ghc/android-14/arm-linux-androideabi-4.7/arm-linux-androideabi/sysroot/usr/lib/ + + build-depends: + base >= 4.0 && < 5.0 +-- +1.7.10.4 + diff --git a/standalone/android/haskell-patches/lens-3.8.5-0001-build-without-TH.patch b/standalone/android/haskell-patches/lens-3.8.5-0001-build-without-TH.patch new file mode 100644 --- /dev/null +++ b/standalone/android/haskell-patches/lens-3.8.5-0001-build-without-TH.patch @@ -0,0 +1,293 @@ +From bbb49942123f06a36b170966e445692297f71d26 Mon Sep 17 00:00:00 2001 +From: Joey Hess +Date: Thu, 18 Apr 2013 19:14:30 -0400 +Subject: [PATCH] build without TH + +--- + lens.cabal | 13 +------------ + src/Control/Exception/Lens.hs | 2 +- + src/Control/Lens.hs | 6 +++--- + src/Control/Lens/Equality.hs | 4 ++-- + src/Control/Lens/Fold.hs | 6 +++--- + src/Control/Lens/Internal.hs | 2 +- + src/Control/Lens/Internal/Zipper.hs | 2 +- + src/Control/Lens/Iso.hs | 2 -- + src/Control/Lens/Lens.hs | 2 +- + src/Control/Lens/Operators.hs | 2 +- + src/Control/Lens/Plated.hs | 2 +- + src/Control/Lens/Setter.hs | 2 -- + src/Control/Lens/TH.hs | 2 +- + src/Data/Data/Lens.hs | 6 +++--- + 14 files changed, 19 insertions(+), 34 deletions(-) + +diff --git a/lens.cabal b/lens.cabal +index a06b3ce..a654b3d 100644 +--- a/lens.cabal ++++ b/lens.cabal +@@ -10,7 +10,7 @@ stability: provisional + homepage: http://github.com/ekmett/lens/ + bug-reports: http://github.com/ekmett/lens/issues + copyright: Copyright (C) 2012-2013 Edward A. Kmett +-build-type: Custom ++build-type: Simple + tested-with: GHC == 7.0.4, GHC == 7.4.1, GHC == 7.4.2, GHC == 7.6.1, GHC == 7.7.20121213, GHC == 7.7.20130117 + synopsis: Lenses, Folds and Traversals + description: +@@ -171,7 +171,6 @@ library + containers >= 0.4.0 && < 0.6, + distributive >= 0.3 && < 1, + filepath >= 1.2.0.0 && < 1.4, +- generic-deriving == 1.4.*, + ghc-prim, + hashable >= 1.1.2.3 && < 1.3, + MonadCatchIO-transformers >= 0.3 && < 0.4, +@@ -233,14 +232,12 @@ library + Control.Lens.Review + Control.Lens.Setter + Control.Lens.Simple +- Control.Lens.TH + Control.Lens.Traversal + Control.Lens.Tuple + Control.Lens.Type + Control.Lens.Wrapped + Control.Lens.Zipper + Control.Lens.Zoom +- Control.Monad.Error.Lens + Control.Parallel.Strategies.Lens + Control.Seq.Lens + Data.Array.Lens +@@ -264,12 +261,8 @@ library + Data.Typeable.Lens + Data.Vector.Lens + Data.Vector.Generic.Lens +- Generics.Deriving.Lens +- GHC.Generics.Lens + System.Exit.Lens + System.FilePath.Lens +- System.IO.Error.Lens +- Language.Haskell.TH.Lens + Numeric.Lens + + if flag(safe) +@@ -368,7 +361,6 @@ test-suite doctests + deepseq, + doctest >= 0.9.1, + filepath, +- generic-deriving, + mtl, + nats, + parallel, +@@ -394,7 +386,6 @@ benchmark plated + comonad, + criterion, + deepseq, +- generic-deriving, + lens, + transformers + +@@ -429,7 +420,6 @@ benchmark unsafe + comonads-fd, + criterion, + deepseq, +- generic-deriving, + lens, + transformers + +@@ -446,6 +436,5 @@ benchmark zipper + comonads-fd, + criterion, + deepseq, +- generic-deriving, + lens, + transformers +diff --git a/src/Control/Exception/Lens.hs b/src/Control/Exception/Lens.hs +index 5c26d4e..9909132 100644 +--- a/src/Control/Exception/Lens.hs ++++ b/src/Control/Exception/Lens.hs +@@ -112,7 +112,7 @@ import Prelude + , Maybe(..), Either(..), Functor(..), String, IO + ) + +-{-# ANN module "HLint: ignore Use Control.Exception.catch" #-} ++ + + -- $setup + -- >>> :set -XNoOverloadedStrings +diff --git a/src/Control/Lens.hs b/src/Control/Lens.hs +index 8481e44..74700ae 100644 +--- a/src/Control/Lens.hs ++++ b/src/Control/Lens.hs +@@ -59,7 +59,7 @@ module Control.Lens + , module Control.Lens.Review + , module Control.Lens.Setter + , module Control.Lens.Simple +-#ifndef DISABLE_TEMPLATE_HASKELL ++#if 0 + , module Control.Lens.TH + #endif + , module Control.Lens.Traversal +@@ -89,7 +89,7 @@ import Control.Lens.Reified + import Control.Lens.Review + import Control.Lens.Setter + import Control.Lens.Simple +-#ifndef DISABLE_TEMPLATE_HASKELL ++#if 0 + import Control.Lens.TH + #endif + import Control.Lens.Traversal +@@ -99,4 +99,4 @@ import Control.Lens.Wrapped + import Control.Lens.Zipper + import Control.Lens.Zoom + +-{-# ANN module "HLint: ignore Use import/export shortcut" #-} ++ +diff --git a/src/Control/Lens/Equality.hs b/src/Control/Lens/Equality.hs +index 982c2d7..3a3fe1a 100644 +--- a/src/Control/Lens/Equality.hs ++++ b/src/Control/Lens/Equality.hs +@@ -28,8 +28,8 @@ module Control.Lens.Equality + import Control.Lens.Internal.Setter + import Control.Lens.Type + +-{-# ANN module "HLint: ignore Use id" #-} +-{-# ANN module "HLint: ignore Eta reduce" #-} ++ ++ + + -- $setup + -- >>> import Control.Lens +diff --git a/src/Control/Lens/Fold.hs b/src/Control/Lens/Fold.hs +index ae5100d..467eb37 100644 +--- a/src/Control/Lens/Fold.hs ++++ b/src/Control/Lens/Fold.hs +@@ -161,9 +161,9 @@ import Data.Traversable + -- >>> let g :: Expr -> Expr; g = Debug.SimpleReflect.Vars.g + -- >>> let timingOut :: NFData a => a -> IO a; timingOut = fmap (fromMaybe (error "timeout")) . timeout (5*10^6) . evaluate . force + +-{-# ANN module "HLint: ignore Eta reduce" #-} +-{-# ANN module "HLint: ignore Use camelCase" #-} +-{-# ANN module "HLint: ignore Use curry" #-} ++ ++ ++ + + infixl 8 ^.., ^?, ^?!, ^@.., ^@?, ^@?! + +diff --git a/src/Control/Lens/Internal.hs b/src/Control/Lens/Internal.hs +index 295662e..539642d 100644 +--- a/src/Control/Lens/Internal.hs ++++ b/src/Control/Lens/Internal.hs +@@ -43,4 +43,4 @@ import Control.Lens.Internal.Review + import Control.Lens.Internal.Setter + import Control.Lens.Internal.Zoom + +-{-# ANN module "HLint: ignore Use import/export shortcut" #-} ++ +diff --git a/src/Control/Lens/Internal/Zipper.hs b/src/Control/Lens/Internal/Zipper.hs +index 95875b7..76060be 100644 +--- a/src/Control/Lens/Internal/Zipper.hs ++++ b/src/Control/Lens/Internal/Zipper.hs +@@ -53,7 +53,7 @@ import Data.Profunctor.Unsafe + -- >>> import Control.Lens + -- >>> import Data.Char + +-{-# ANN module "HLint: ignore Use foldl" #-} ++ + + ------------------------------------------------------------------------------ + -- * Jacket +diff --git a/src/Control/Lens/Iso.hs b/src/Control/Lens/Iso.hs +index 62d40ef..235511a 100644 +--- a/src/Control/Lens/Iso.hs ++++ b/src/Control/Lens/Iso.hs +@@ -70,8 +70,6 @@ import Data.Profunctor.Unsafe + import Unsafe.Coerce + #endif + +-{-# ANN module "HLint: ignore Use on" #-} +- + -- $setup + -- >>> :set -XNoOverloadedStrings + -- >>> import Control.Lens +diff --git a/src/Control/Lens/Lens.hs b/src/Control/Lens/Lens.hs +index ff2a45f..5401ec4 100644 +--- a/src/Control/Lens/Lens.hs ++++ b/src/Control/Lens/Lens.hs +@@ -120,7 +120,7 @@ import Data.Profunctor + import Data.Profunctor.Rep + import Data.Profunctor.Unsafe + +-{-# ANN module "HLint: ignore Use ***" #-} ++ + + -- $setup + -- >>> :set -XNoOverloadedStrings +diff --git a/src/Control/Lens/Operators.hs b/src/Control/Lens/Operators.hs +index d88cb49..fa7b37e 100644 +--- a/src/Control/Lens/Operators.hs ++++ b/src/Control/Lens/Operators.hs +@@ -107,4 +107,4 @@ import Control.Lens.Review + import Control.Lens.Setter + import Control.Lens.Zipper + +-{-# ANN module "HLint: ignore Use import/export shortcut" #-} ++ +diff --git a/src/Control/Lens/Plated.hs b/src/Control/Lens/Plated.hs +index 07d9212..27070c0 100644 +--- a/src/Control/Lens/Plated.hs ++++ b/src/Control/Lens/Plated.hs +@@ -95,7 +95,7 @@ import Data.Data.Lens + import Data.Monoid + import Data.Tree + +-{-# ANN module "HLint: ignore Reduce duplication" #-} ++ + + -- | A 'Plated' type is one where we know how to extract its immediate self-similar children. + -- +diff --git a/src/Control/Lens/Setter.hs b/src/Control/Lens/Setter.hs +index 2acbfa6..4a12c6b 100644 +--- a/src/Control/Lens/Setter.hs ++++ b/src/Control/Lens/Setter.hs +@@ -87,8 +87,6 @@ import Data.Profunctor + import Data.Profunctor.Rep + import Data.Profunctor.Unsafe + +-{-# ANN module "HLint: ignore Avoid lambda" #-} +- + -- $setup + -- >>> import Control.Lens + -- >>> import Control.Monad.State +diff --git a/src/Control/Lens/TH.hs b/src/Control/Lens/TH.hs +index fbf4adb..ee723d7 100644 +--- a/src/Control/Lens/TH.hs ++++ b/src/Control/Lens/TH.hs +@@ -87,7 +87,7 @@ import Language.Haskell.TH + import Language.Haskell.TH.Syntax + import Language.Haskell.TH.Lens + +-{-# ANN module "HLint: ignore Use foldl" #-} ++ + + -- | Flags for 'Lens' construction + data LensFlag +diff --git a/src/Data/Data/Lens.hs b/src/Data/Data/Lens.hs +index cf1e7c9..b39dacf 100644 +--- a/src/Data/Data/Lens.hs ++++ b/src/Data/Data/Lens.hs +@@ -65,9 +65,9 @@ import Data.Monoid + import GHC.Exts (realWorld#) + #endif + +-{-# ANN module "HLint: ignore Eta reduce" #-} +-{-# ANN module "HLint: ignore Use foldl" #-} +-{-# ANN module "HLint: ignore Reduce duplication" #-} ++ ++ ++ + + -- $setup + -- >>> :set -XNoOverloadedStrings +-- +1.8.2.rc3 + diff --git a/standalone/licences.gz b/standalone/licences.gz Binary files a/standalone/licences.gz and b/standalone/licences.gz differ diff --git a/templates/configurators/addia.hamlet b/templates/configurators/addia.hamlet new file mode 100644 --- /dev/null +++ b/templates/configurators/addia.hamlet @@ -0,0 +1,32 @@ +
+

+ Adding an Internet Archive item +

+ The Internet Archive allows anyone # + to publically archive their information, for free. All you need to # + get started is to # + + Create an account +

+ The Internet Archive stores "items". An item can be a single file, or # + a related group of files. You can make as many different items as you # + like. +

+ By default, only files that you place in a special directory # + will be uploaded to your Internet Archive item. Any other files # + in your repository will remain private. +

+

+
+ ^{form} + ^{webAppFormAuthToken} +
+