diff --git a/Annex/Branch.hs b/Annex/Branch.hs --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -22,6 +22,7 @@ ) where import qualified Data.ByteString.Lazy.Char8 as L +import System.Environment import Common.Annex import Annex.BranchState @@ -292,7 +293,8 @@ withIndex' bootstrapping a = do f <- fromRepo gitAnnexIndex g <- gitRepo - let g' = g { gitEnv = Just [("GIT_INDEX_FILE", f)] } + e <- liftIO getEnvironment + let g' = g { gitEnv = Just $ ("GIT_INDEX_FILE", f):e } Annex.changeState $ \s -> s { Annex.repo = g' } checkIndexOnce $ unlessM (liftIO $ doesFileExist f) $ do diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs --- a/Assistant/DaemonStatus.hs +++ b/Assistant/DaemonStatus.hs @@ -17,6 +17,8 @@ import Logs.Transfer import Logs.Trust import qualified Remote +import qualified Types.Remote as Remote +import Config import Control.Concurrent.STM import System.Posix.Types @@ -86,10 +88,11 @@ sendNotification $ changeNotifier s return b -{- Remotes ordered by cost, with dead ones thrown out. -} +{- Syncable remotes ordered by cost. -} calcKnownRemotes :: Annex [Remote] calcKnownRemotes = do - rs <- concat . Remote.byCost <$> Remote.enabledRemoteList + rs <- filterM (repoSyncable . Remote.repo) =<< + concat . Remote.byCost <$> Remote.enabledRemoteList alive <- snd <$> trustPartition DeadTrusted (map Remote.uuid rs) let good r = Remote.uuid r `elem` alive return $ filter good rs diff --git a/Assistant/MakeRemote.hs b/Assistant/MakeRemote.hs --- a/Assistant/MakeRemote.hs +++ b/Assistant/MakeRemote.hs @@ -90,10 +90,10 @@ - Returns the name of the remote. -} makeRemote :: String -> String -> (String -> Annex ()) -> Annex String makeRemote basename location a = do - r <- fromRepo id - if not (any samelocation $ Git.remotes r) + g <- gitRepo + if not (any samelocation $ Git.remotes g) then do - let name = uniqueRemoteName basename 0 r + let name = uniqueRemoteName basename 0 g a name return name else return basename diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs --- a/Assistant/Sync.hs +++ b/Assistant/Sync.hs @@ -84,7 +84,7 @@ pushToRemotes :: ThreadName -> UTCTime -> ThreadState -> Maybe FailedPushMap -> [Remote] -> IO Bool pushToRemotes threadname now st mpushmap remotes = do (g, branch, u) <- runThreadState st $ (,,) - <$> fromRepo id + <$> gitRepo <*> inRepo Git.Branch.current <*> getUUID go True branch g u remotes @@ -145,7 +145,7 @@ {- Manually pull from remotes and merge their branches. -} manualPull :: ThreadState -> Maybe Git.Ref -> [Remote] -> IO Bool manualPull st currentbranch remotes = do - g <- runThreadState st $ fromRepo id + g <- runThreadState st gitRepo forM_ remotes $ \r -> Git.Command.runBool "fetch" [Param $ Remote.name r] g haddiverged <- runThreadState st Annex.Branch.forceUpdate diff --git a/Assistant/Threads/Merger.hs b/Assistant/Threads/Merger.hs --- a/Assistant/Threads/Merger.hs +++ b/Assistant/Threads/Merger.hs @@ -25,7 +25,7 @@ - pushes. -} mergeThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> NamedThread mergeThread st dstatus transferqueue = thread $ do - g <- runThreadState st $ fromRepo id + g <- runThreadState st gitRepo let dir = Git.localGitDir g "refs" createDirectoryIfMissing True dir let hook a = Just $ runHandler st dstatus transferqueue a diff --git a/Assistant/Threads/PairListener.hs b/Assistant/Threads/PairListener.hs --- a/Assistant/Threads/PairListener.hs +++ b/Assistant/Threads/PairListener.hs @@ -17,6 +17,7 @@ import Assistant.WebApp import Assistant.WebApp.Types import Assistant.Alert +import Utility.ThreadScheduler import Network.Multicast import Network.Socket @@ -27,11 +28,16 @@ thisThread = "PairListener" pairListenerThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> UrlRenderer -> NamedThread -pairListenerThread st dstatus scanremotes urlrenderer = thread $ withSocketsDo $ do - sock <- multicastReceiver (multicastAddress $ IPv4Addr undefined) pairingPort - go sock [] [] +pairListenerThread st dstatus scanremotes urlrenderer = thread $ withSocketsDo $ + runEvery (Seconds 1) $ void $ tryIO $ do + sock <- getsock + go sock [] [] where thread = NamedThread thisThread + + {- Note this can crash if there's no network interface, + - or only one like lo that doesn't support multicast. -} + getsock = multicastReceiver (multicastAddress $ IPv4Addr undefined) pairingPort go sock reqs cache = getmsg sock [] >>= \msg -> case readish msg of Nothing -> go sock reqs cache diff --git a/Assistant/Threads/SanityChecker.hs b/Assistant/Threads/SanityChecker.hs --- a/Assistant/Threads/SanityChecker.hs +++ b/Assistant/Threads/SanityChecker.hs @@ -74,7 +74,7 @@ - will block the watcher. -} check :: ThreadState -> DaemonStatusHandle -> TransferQueue -> ChangeChan -> IO Bool check st dstatus transferqueue changechan = do - g <- runThreadState st $ fromRepo id + g <- runThreadState st gitRepo -- Find old unstaged symlinks, and add them to git. (unstaged, cleanup) <- Git.LsFiles.notInRepo False ["."] g now <- getPOSIXTime diff --git a/Assistant/Threads/TransferPoller.hs b/Assistant/Threads/TransferPoller.hs --- a/Assistant/Threads/TransferPoller.hs +++ b/Assistant/Threads/TransferPoller.hs @@ -24,7 +24,7 @@ - of each transfer is complete. -} transferPollerThread :: ThreadState -> DaemonStatusHandle -> NamedThread transferPollerThread st dstatus = thread $ do - g <- runThreadState st $ fromRepo id + g <- runThreadState st gitRepo tn <- newNotificationHandle =<< transferNotifier <$> getDaemonStatus dstatus forever $ do diff --git a/Assistant/Threads/TransferScanner.hs b/Assistant/Threads/TransferScanner.hs --- a/Assistant/Threads/TransferScanner.hs +++ b/Assistant/Threads/TransferScanner.hs @@ -94,7 +94,7 @@ expensiveScan st dstatus transferqueue rs = unless onlyweb $ do liftIO $ debug thisThread ["starting scan of", show visiblers] void $ alertWhile dstatus (scanAlert visiblers) $ do - g <- runThreadState st $ fromRepo id + g <- runThreadState st gitRepo (files, cleanup) <- LsFiles.inRepo [] g go files void cleanup diff --git a/Assistant/Threads/TransferWatcher.hs b/Assistant/Threads/TransferWatcher.hs --- a/Assistant/Threads/TransferWatcher.hs +++ b/Assistant/Threads/TransferWatcher.hs @@ -24,7 +24,7 @@ - and updates the DaemonStatus's map of ongoing transfers. -} transferWatcherThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> NamedThread transferWatcherThread st dstatus transferqueue = thread $ do - g <- runThreadState st $ fromRepo id + g <- runThreadState st gitRepo let dir = gitAnnexTransferDir g createDirectoryIfMissing True dir let hook a = Just $ runHandler st dstatus transferqueue a diff --git a/Assistant/WebApp/Configurators.hs b/Assistant/WebApp/Configurators.hs --- a/Assistant/WebApp/Configurators.hs +++ b/Assistant/WebApp/Configurators.hs @@ -13,14 +13,16 @@ import Assistant.WebApp import Assistant.WebApp.Types import Assistant.WebApp.SideBar -import Assistant.DaemonStatus +import Assistant.WebApp.Utility import Assistant.WebApp.Configurators.Local +import Assistant.DaemonStatus import Utility.Yesod import qualified Remote import qualified Types.Remote as Remote import Annex.UUID (getUUID) import Logs.Remote import Logs.Trust +import Config import Yesod import Data.Text (Text) @@ -36,42 +38,82 @@ $(widgetFile "configurators/main") ) +{- An intro message, list of repositories, and nudge to make more. -} +introDisplay :: Text -> Widget +introDisplay ident = do + webapp <- lift getYesod + repolist <- lift $ repoList True False + let n = length repolist + let numrepos = show n + let notenough = n < enough + $(widgetFile "configurators/intro") + lift $ modifyWebAppState $ \s -> s { showIntro = False } + where + enough = 2 + {- Lists known repositories, followed by options to add more. -} getRepositoriesR :: Handler RepHtml getRepositoriesR = bootstrap (Just Config) $ do sideBarDisplay setTitle "Repositories" - repolist <- lift $ repoList False + repolist <- lift $ repoList False True $(widgetFile "configurators/repositories") -data SetupRepo = EnableRepo (Route WebApp) | EditRepo (Route WebApp) +data Actions + = DisabledRepoActions + { setupRepoLink :: Route WebApp } + | SyncingRepoActions + { setupRepoLink :: Route WebApp + , syncToggleLink :: Route WebApp + } + | NotSyncingRepoActions + { setupRepoLink :: Route WebApp + , syncToggleLink :: Route WebApp + } -needsEnabled :: SetupRepo -> Bool -needsEnabled (EnableRepo _) = True +mkSyncingRepoActions :: UUID -> Actions +mkSyncingRepoActions u = SyncingRepoActions + { setupRepoLink = EditRepositoryR u + , syncToggleLink = DisableSyncR u + } + +mkNotSyncingRepoActions :: UUID -> Actions +mkNotSyncingRepoActions u = NotSyncingRepoActions + { setupRepoLink = EditRepositoryR u + , syncToggleLink = EnableSyncR u + } + +needsEnabled :: Actions -> Bool +needsEnabled (DisabledRepoActions _) = True needsEnabled _ = False -setupRepoLink :: SetupRepo -> Route WebApp -setupRepoLink (EnableRepo r) = r -setupRepoLink (EditRepo r) = r +notSyncing :: Actions -> Bool +notSyncing (SyncingRepoActions _ _) = False +notSyncing _ = True -{- A numbered list of known repositories, including the current one. -} -repoList :: Bool -> Handler [(String, String, SetupRepo)] -repoList onlyconfigured +{- A numbered list of known repositories, + - with actions that can be taken on them. -} +repoList :: Bool -> Bool -> Handler [(String, String, Actions)] +repoList onlyconfigured includehere | onlyconfigured = list =<< configured - | otherwise = list =<< (++) <$> configured <*> unconfigured + | otherwise = list =<< (++) <$> configured <*> rest where configured = do rs <- filter (not . Remote.readonly) . knownRemotes <$> (liftIO . getDaemonStatus =<< daemonStatus <$> getYesod) runAnnex [] $ do u <- getUUID - let l = u : map Remote.uuid rs - return $ zip l (map editlink l) - editlink = EditRepo . EditRepositoryR - unconfigured = runAnnex [] $ do + let l = map Remote.uuid rs + let l' = if includehere then u : l else l + return $ zip l' $ map mkSyncingRepoActions l' + rest = runAnnex [] $ do m <- readRemoteLog - catMaybes . map (findtype m) . snd + unconfigured <- catMaybes . map (findtype m) . snd <$> (trustPartition DeadTrusted $ M.keys m) + unsyncable <- map Remote.uuid <$> + (filterM (\r -> not <$> repoSyncable (Remote.repo r)) + =<< Remote.enabledRemoteList) + return $ zip unsyncable (map mkNotSyncingRepoActions unsyncable) ++ unconfigured findtype m u = case M.lookup u m of Nothing -> Nothing Just c -> case M.lookup "type" c of @@ -79,7 +121,7 @@ Just "directory" -> u `enableswith` EnableDirectoryR Just "S3" -> u `enableswith` EnableS3R _ -> Nothing - u `enableswith` r = Just (u, EnableRepo $ r u) + u `enableswith` r = Just (u, DisabledRepoActions $ r u) list l = runAnnex [] $ do let l' = nubBy (\x y -> fst x == fst y) l zip3 @@ -88,17 +130,14 @@ <*> pure (map snd l') counter = map show ([1..] :: [Int]) -{- An intro message, list of repositories, and nudge to make more. -} -introDisplay :: Text -> Widget -introDisplay ident = do - webapp <- lift getYesod - repolist <- lift $ repoList True - let n = length repolist - let numrepos = show n - let notenough = n < enough - let barelyenough = n == enough - let morethanenough = n > enough - $(widgetFile "configurators/intro") - lift $ modifyWebAppState $ \s -> s { showIntro = False } - where - enough = 2 +getEnableSyncR :: UUID -> Handler () +getEnableSyncR = flipSync True + +getDisableSyncR :: UUID -> Handler () +getDisableSyncR = flipSync False + +flipSync :: Bool -> UUID -> Handler () +flipSync enable uuid = do + mremote <- runAnnex undefined $ snd <$> Remote.repoFromUUID uuid + changeSyncable mremote enable + redirect RepositoriesR 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 @@ -13,44 +13,100 @@ import Assistant.WebApp import Assistant.WebApp.Types import Assistant.WebApp.SideBar +import Assistant.WebApp.Utility import Utility.Yesod import qualified Remote import Logs.UUID +import Logs.Group +import Logs.PreferredContent +import Types.StandardGroups +import qualified Config +import Annex.UUID +import qualified Git import Yesod import Data.Text (Text) import qualified Data.Text as T import qualified Data.Map as M +import qualified Data.Set as S +data RepoGroup = RepoGroupCustom String | RepoGroupStandard StandardGroup + deriving (Show, Eq) + data RepoConfig = RepoConfig { repoDescription :: Text + , repoGroup :: RepoGroup + , repoSyncable :: Bool } deriving (Show) +getRepoConfig :: UUID -> Git.Repo -> Annex RepoConfig +getRepoConfig uuid r = RepoConfig + <$> (T.pack . fromMaybe "" . M.lookup uuid <$> uuidMap) + <*> getrepogroup + <*> Config.repoSyncable r + where + getrepogroup = do + groups <- lookupGroups uuid + return $ + maybe (RepoGroupCustom $ unwords $ S.toList groups) RepoGroupStandard + (getStandardGroup groups) + +{- Returns Just False if syncing should be disabled, Just True when enabled; + - Nothing when it is not changed. -} +setRepoConfig :: UUID -> Git.Repo -> RepoConfig -> Annex (Maybe Bool) +setRepoConfig uuid r c = do + describeUUID uuid $ T.unpack $ repoDescription c + case repoGroup c of + RepoGroupStandard g -> setStandardGroup uuid g + RepoGroupCustom s -> groupSet uuid $ S.fromList $ words s + ifM ((==) uuid <$> getUUID) + ( return Nothing + , do + syncable <- Config.repoSyncable r + return $ if (syncable /= repoSyncable c) + then Just $ repoSyncable c + else Nothing + ) + editRepositoryAForm :: RepoConfig -> AForm WebApp WebApp RepoConfig editRepositoryAForm def = RepoConfig <$> areq textField "Description" (Just $ repoDescription def) - -getRepoConfig :: UUID -> Annex RepoConfig -getRepoConfig uuid = RepoConfig - <$> (T.pack . fromMaybe "" . M.lookup uuid <$> uuidMap) + <*> areq (selectFieldList $ customgroups++standardgroups) "Repository group" (Just $ repoGroup def) + <*> areq checkBoxField "Syncing enabled" (Just $ repoSyncable def) + where + standardgroups :: [(Text, RepoGroup)] + standardgroups = map (\g -> (T.pack $ descStandardGroup g , RepoGroupStandard g)) + [minBound :: StandardGroup .. maxBound :: StandardGroup] + customgroups :: [(Text, RepoGroup)] + customgroups = case repoGroup def of + RepoGroupCustom s -> [(T.pack s, RepoGroupCustom s)] + _ -> [] getEditRepositoryR :: UUID -> Handler RepHtml -getEditRepositoryR uuid = bootstrap (Just Config) $ do +getEditRepositoryR = editForm False + +getEditNewRepositoryR :: UUID -> Handler RepHtml +getEditNewRepositoryR = editForm True + +editForm :: Bool -> UUID -> Handler RepHtml +editForm new uuid = bootstrap (Just Config) $ do sideBarDisplay setTitle "Configure repository" - - curr <- lift $ runAnnex undefined $ getRepoConfig uuid + + (repo, mremote) <- lift $ runAnnex undefined $ Remote.repoFromUUID uuid + curr <- lift $ runAnnex undefined $ getRepoConfig uuid repo ((result, form), enctype) <- lift $ runFormGet $ renderBootstrap $ editRepositoryAForm curr case result of - FormSuccess input -> do - error (show input) - _ -> showform form enctype + FormSuccess input -> lift $ do + syncchanged <- runAnnex undefined $ + setRepoConfig uuid repo input + maybe noop (changeSyncable mremote) syncchanged + redirect RepositoriesR + _ -> showform form enctype curr where - showform form enctype = do + showform form enctype curr = do + let istransfer = repoGroup curr == RepoGroupStandard TransferGroup let authtoken = webAppFormAuthToken - description <- lift $ - runAnnex T.empty $ T.pack . concat <$> - Remote.prettyListUUIDs [uuid] $(widgetFile "configurators/editrepository") 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 @@ -13,7 +13,7 @@ import Assistant.WebApp import Assistant.WebApp.Types import Assistant.WebApp.SideBar -import Assistant.Sync +import Assistant.WebApp.Utility import Assistant.MakeRemote import Utility.Yesod import Init @@ -28,13 +28,13 @@ import Utility.DataUnits import Utility.Network import Remote (prettyListUUIDs) -import Logs.Group import Annex.UUID +import Types.StandardGroups +import Logs.PreferredContent import Yesod import Data.Text (Text) import qualified Data.Text as T -import qualified Data.Set as S import Data.Char import System.Posix.Directory import qualified Control.Exception as E @@ -147,7 +147,7 @@ let path = T.unpack p liftIO $ makeRepo path False u <- liftIO $ initRepo path Nothing - runAnnex () $ groupSet u (S.singleton "clients") + runAnnex () $ setStandardGroup u ClientGroup liftIO $ addAutoStart path redirect $ SwitchToRepositoryR path _ -> $(widgetFile "configurators/newrepository") @@ -185,19 +185,19 @@ ((res, form), enctype) <- lift $ runFormGet $ selectDriveForm (sort writabledrives) Nothing case res of - FormSuccess (RemovableDrive { mountPoint = d }) -> lift $ do - go $ T.unpack d - redirect RepositoriesR + FormSuccess (RemovableDrive { mountPoint = d }) -> lift $ + make (T.unpack d) >>= redirect . EditNewRepositoryR _ -> do let authtoken = webAppFormAuthToken $(widgetFile "configurators/adddrive") where - go mountpoint = do + make mountpoint = do liftIO $ makerepo dir u <- liftIO $ initRepo dir $ Just remotename r <- addremote dir remotename - runAnnex () $ groupSet u (S.singleton "drives") + runAnnex () $ setStandardGroup u TransferGroup syncRemote r + return u where dir = mountpoint gitAnnexAssistantDefaultDir remotename = takeFileName mountpoint @@ -227,16 +227,6 @@ T.pack . concat <$> prettyListUUIDs [uuid] $(widgetFile "configurators/enabledirectory") -{- Start syncing a newly added remote, using a background thread. -} -syncRemote :: Remote -> Handler () -syncRemote remote = do - webapp <- getYesod - liftIO $ syncNewRemote - (fromJust $ threadState webapp) - (daemonStatus webapp) - (scanRemotes webapp) - remote - {- List of removable drives. -} driveList :: IO [RemovableDrive] driveList = mapM (gen . mnt_dir) =<< filter sane <$> getMounts @@ -264,10 +254,11 @@ startFullAssistant :: FilePath -> Handler () startFullAssistant path = do webapp <- getYesod - liftIO $ makeRepo path False - u <- liftIO $ initRepo path Nothing - runAnnex () $ groupSet u (S.singleton "clients") url <- liftIO $ do + makeRepo path False + u <- initRepo path Nothing + inDir path $ + setStandardGroup u ClientGroup addAutoStart path changeWorkingDirectory path fromJust $ postFirstRun webapp diff --git a/Assistant/WebApp/Configurators/S3.hs b/Assistant/WebApp/Configurators/S3.hs --- a/Assistant/WebApp/Configurators/S3.hs +++ b/Assistant/WebApp/Configurators/S3.hs @@ -21,12 +21,12 @@ import Logs.Remote import qualified Remote import Types.Remote (RemoteConfig) -import Logs.Group +import Types.StandardGroups +import Logs.PreferredContent import Yesod import Data.Text (Text) import qualified Data.Text as T -import qualified Data.Set as S import qualified Data.Map as M s3Configurator :: Widget -> Handler RepHtml @@ -94,7 +94,7 @@ let authtoken = webAppFormAuthToken $(widgetFile "configurators/adds3") setgroup r = runAnnex () $ - groupSet (Remote.uuid r) (S.singleton "servers") + setStandardGroup (Remote.uuid r) TransferGroup getEnableS3R :: UUID -> Handler RepHtml getEnableS3R uuid = s3Configurator $ do @@ -125,4 +125,4 @@ return remotename setup r liftIO $ syncNewRemote st (daemonStatus webapp) (scanRemotes webapp) r - redirect RepositoriesR + redirect $ EditNewRepositoryR $ Remote.uuid r 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 @@ -19,13 +19,13 @@ import Utility.Rsync (rsyncUrlIsShell) import Logs.Remote import Remote -import Logs.Group +import Logs.PreferredContent +import Types.StandardGroups import Yesod import Data.Text (Text) import qualified Data.Text as T import qualified Data.Map as M -import qualified Data.Set as S import Network.Socket import System.Posix.User @@ -291,7 +291,7 @@ (scanRemotes webapp) forcersync sshdata setup r - redirect RepositoriesR + redirect $ EditRepositoryR $ Remote.uuid r getAddRsyncNetR :: Handler RepHtml getAddRsyncNetR = do @@ -348,4 +348,4 @@ isRsyncNet (Just host) = ".rsync.net" `T.isSuffixOf` T.toLower host setupGroup :: Remote -> Handler () -setupGroup r = runAnnex () $ groupSet (Remote.uuid r) (S.singleton "server") +setupGroup r = runAnnex () $ setStandardGroup (Remote.uuid r) TransferGroup diff --git a/Assistant/WebApp/DashBoard.hs b/Assistant/WebApp/DashBoard.hs --- a/Assistant/WebApp/DashBoard.hs +++ b/Assistant/WebApp/DashBoard.hs @@ -12,13 +12,12 @@ import Assistant.Common import Assistant.WebApp import Assistant.WebApp.Types +import Assistant.WebApp.Utility import Assistant.WebApp.SideBar import Assistant.WebApp.Notifications import Assistant.WebApp.Configurators import Assistant.DaemonStatus import Assistant.TransferQueue -import Assistant.TransferSlots -import qualified Assistant.Threads.Transferrer as Transferrer import Utility.NotificationBroadcaster import Utility.Yesod import Logs.Transfer @@ -27,14 +26,11 @@ import Types.Key import qualified Remote import qualified Git -import Locations.UserConfig import Yesod import Text.Hamlet import qualified Data.Map as M import Control.Concurrent -import System.Posix.Signals (signalProcessGroup, sigTERM, sigKILL) -import System.Posix.Process (getProcessGroupIDOf) {- A display of currently running and queued transfers. - @@ -162,76 +158,3 @@ getCancelTransferR t = cancelTransfer False t >> redirectBack postCancelTransferR :: Transfer -> Handler () postCancelTransferR t = cancelTransfer False t - -pauseTransfer :: Transfer -> Handler () -pauseTransfer = cancelTransfer True - -cancelTransfer :: Bool -> Transfer-> Handler () -cancelTransfer pause t = do - webapp <- getYesod - let dstatus = daemonStatus webapp - m <- getCurrentTransfers - liftIO $ do - unless pause $ - {- remove queued transfer -} - void $ dequeueTransfers (transferQueue webapp) dstatus $ - equivilantTransfer t - {- stop running transfer -} - maybe noop (stop dstatus) (M.lookup t m) - where - stop dstatus info = do - {- When there's a thread associated with the - - transfer, it's signaled first, to avoid it - - displaying any alert about the transfer having - - failed when the transfer process is killed. -} - maybe noop signalthread $ transferTid info - maybe noop killproc $ transferPid info - if pause - then void $ - alterTransferInfo dstatus t $ \i -> i - { transferPaused = True } - else void $ - removeTransfer dstatus t - signalthread tid - | pause = throwTo tid PauseTransfer - | otherwise = killThread tid - {- In order to stop helper processes like rsync, - - kill the whole process group of the process running the - - transfer. -} - killproc pid = do - g <- getProcessGroupIDOf pid - void $ tryIO $ signalProcessGroup sigTERM g - threadDelay 50000 -- 0.05 second grace period - void $ tryIO $ signalProcessGroup sigKILL g - -startTransfer :: Transfer -> Handler () -startTransfer t = do - m <- getCurrentTransfers - maybe startqueued go (M.lookup t m) - where - go info = maybe (start info) resume $ transferTid info - startqueued = do - webapp <- getYesod - let dstatus = daemonStatus webapp - let q = transferQueue webapp - is <- liftIO $ map snd <$> getMatchingTransfers q dstatus (== t) - maybe noop start $ headMaybe is - resume tid = do - webapp <- getYesod - let dstatus = daemonStatus webapp - liftIO $ do - alterTransferInfo dstatus t $ \i -> i - { transferPaused = False } - throwTo tid ResumeTransfer - start info = do - webapp <- getYesod - let st = fromJust $ threadState webapp - let dstatus = daemonStatus webapp - let slots = transferSlots webapp - liftIO $ inImmediateTransferSlot dstatus slots $ do - program <- readProgramFile - Transferrer.startTransfer st dstatus program t info - -getCurrentTransfers :: Handler TransferMap -getCurrentTransfers = currentTransfers - <$> (liftIO . getDaemonStatus =<< daemonStatus <$> getYesod) diff --git a/Assistant/WebApp/Utility.hs b/Assistant/WebApp/Utility.hs new file mode 100644 --- /dev/null +++ b/Assistant/WebApp/Utility.hs @@ -0,0 +1,144 @@ +{- git-annex assistant webapp utilities + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Assistant.WebApp.Utility where + +import Assistant.Common +import Assistant.WebApp +import Assistant.WebApp.Types +import Assistant.DaemonStatus +import Assistant.ThreadedMonad +import Assistant.TransferQueue +import Assistant.TransferSlots +import Assistant.Sync +import qualified Remote +import qualified Types.Remote as Remote +import qualified Remote.List as Remote +import qualified Assistant.Threads.Transferrer as Transferrer +import Logs.Transfer +import Locations.UserConfig +import qualified Config + +import Yesod +import qualified Data.Map as M +import Control.Concurrent +import System.Posix.Signals (signalProcessGroup, sigTERM, sigKILL) +import System.Posix.Process (getProcessGroupIDOf) + +{- Use Nothing to change global sync setting. -} +changeSyncable :: (Maybe Remote) -> Bool -> Handler () +changeSyncable Nothing _ = noop -- TODO +changeSyncable (Just r) True = do + changeSyncFlag r True + syncRemote r +changeSyncable (Just r) False = do + changeSyncFlag r False + webapp <- getYesod + let dstatus = daemonStatus webapp + let st = fromJust $ threadState webapp + liftIO $ runThreadState st $ updateKnownRemotes dstatus + {- Stop all transfers to or from this remote. + - XXX Can't stop any ongoing scan, or git syncs. -} + void $ liftIO $ dequeueTransfers (transferQueue webapp) dstatus tofrom + mapM_ (cancelTransfer False) =<< + filter tofrom . M.keys <$> + liftIO (currentTransfers <$> getDaemonStatus dstatus) + where + tofrom t = transferUUID t == Remote.uuid r + +changeSyncFlag :: Remote -> Bool -> Handler () +changeSyncFlag r enabled = runAnnex undefined $ do + Config.setConfig key value + void $ Remote.remoteListRefresh + where + key = Config.remoteConfig (Remote.repo r) "sync" + value + | enabled = "true" + | otherwise = "false" + +{- Start syncing remote, using a background thread. -} +syncRemote :: Remote -> Handler () +syncRemote remote = do + webapp <- getYesod + liftIO $ syncNewRemote + (fromJust $ threadState webapp) + (daemonStatus webapp) + (scanRemotes webapp) + remote + +pauseTransfer :: Transfer -> Handler () +pauseTransfer = cancelTransfer True + +cancelTransfer :: Bool -> Transfer -> Handler () +cancelTransfer pause t = do + webapp <- getYesod + let dstatus = daemonStatus webapp + m <- getCurrentTransfers + liftIO $ do + unless pause $ + {- remove queued transfer -} + void $ dequeueTransfers (transferQueue webapp) dstatus $ + equivilantTransfer t + {- stop running transfer -} + maybe noop (stop dstatus) (M.lookup t m) + where + stop dstatus info = do + {- When there's a thread associated with the + - transfer, it's signaled first, to avoid it + - displaying any alert about the transfer having + - failed when the transfer process is killed. -} + maybe noop signalthread $ transferTid info + maybe noop killproc $ transferPid info + if pause + then void $ + alterTransferInfo dstatus t $ \i -> i + { transferPaused = True } + else void $ + removeTransfer dstatus t + signalthread tid + | pause = throwTo tid PauseTransfer + | otherwise = killThread tid + {- In order to stop helper processes like rsync, + - kill the whole process group of the process running the + - transfer. -} + killproc pid = do + g <- getProcessGroupIDOf pid + void $ tryIO $ signalProcessGroup sigTERM g + threadDelay 50000 -- 0.05 second grace period + void $ tryIO $ signalProcessGroup sigKILL g + +startTransfer :: Transfer -> Handler () +startTransfer t = do + m <- getCurrentTransfers + maybe startqueued go (M.lookup t m) + where + go info = maybe (start info) resume $ transferTid info + startqueued = do + webapp <- getYesod + let dstatus = daemonStatus webapp + let q = transferQueue webapp + is <- liftIO $ map snd <$> getMatchingTransfers q dstatus (== t) + maybe noop start $ headMaybe is + resume tid = do + webapp <- getYesod + let dstatus = daemonStatus webapp + liftIO $ do + alterTransferInfo dstatus t $ \i -> i + { transferPaused = False } + throwTo tid ResumeTransfer + start info = do + webapp <- getYesod + let st = fromJust $ threadState webapp + let dstatus = daemonStatus webapp + let slots = transferSlots webapp + liftIO $ inImmediateTransferSlot dstatus slots $ do + program <- readProgramFile + Transferrer.startTransfer st dstatus program t info + +getCurrentTransfers :: Handler TransferMap +getCurrentTransfers = currentTransfers + <$> (liftIO . getDaemonStatus =<< daemonStatus <$> getYesod) diff --git a/Assistant/WebApp/routes b/Assistant/WebApp/routes --- a/Assistant/WebApp/routes +++ b/Assistant/WebApp/routes @@ -11,6 +11,9 @@ /config/repository/new NewRepositoryR GET /config/repository/switchto/#FilePath SwitchToRepositoryR GET /config/repository/edit/#UUID EditRepositoryR GET +/config/repository/edit/new/#UUID EditNewRepositoryR GET +/config/repository/sync/disable/#UUID DisableSyncR GET +/config/repository/sync/enable/#UUID EnableSyncR GET /config/repository/add/drive AddDriveR GET /config/repository/add/ssh AddSshR GET diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,25 @@ +git-annex (3.20121010) unstable; urgency=low + + * Renamed --ingroup to --inallgroup. + * Standard groups changed to client, transfer, archive, and backup. + Each of these has its own standard preferred content setting. + * dead: Remove dead repository from all groups. + * Avoid unsetting HOME when running certian git commands. Closes: #690193 + * test: Fix threaded runtime hang. + * Makefile: Avoid building with -threaded if the ghc threaded runtime does + not exist. + * webapp: Improve wording of intro display. Closes: #689848 + * webapp: Repositories can now be configured, to change their description, + their group, or even to disable syncing to them. + * git config remote.name.annex-sync can be used to control whether + a remote gets synced. + * Fix a crash when merging files in the git-annex branch that contain + invalid utf8. + * Automatically detect when a ssh remote does not have git-annex-shell + installed, and set annex-ignore. + + -- Joey Hess Fri, 12 Oct 2012 13:45:21 -0400 + git-annex (3.20121009) unstable; urgency=low * watch, assistant: It's now safe to git annex unlock files while diff --git a/Command/Dead.hs b/Command/Dead.hs --- a/Command/Dead.hs +++ b/Command/Dead.hs @@ -11,7 +11,10 @@ import Command import qualified Remote import Logs.Trust +import Logs.Group +import qualified Data.Set as S + def :: [Command] def = [command "dead" (paramRepeating paramRemote) seek "hide a lost repository"] @@ -29,4 +32,5 @@ perform :: UUID -> CommandPerform perform uuid = do trustSet uuid DeadTrusted + groupSet uuid S.empty next $ return True diff --git a/Command/Sync.hs b/Command/Sync.hs --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -26,6 +26,7 @@ import qualified Types.Remote import qualified Remote.Git import Types.Key +import Config import qualified Data.ByteString.Lazy as L import Data.Hash.MD5 @@ -71,7 +72,8 @@ unwords (map Types.Remote.name s) return l available = filter (not . Remote.specialRemote) - <$> Remote.enabledRemoteList + <$> (filterM (repoSyncable . Types.Remote.repo) + =<< Remote.enabledRemoteList) good = filterM $ Remote.Git.repoAvail . Types.Remote.repo fastest = fromMaybe [] . headMaybe . Remote.byCost diff --git a/Command/WebApp.hs b/Command/WebApp.hs --- a/Command/WebApp.hs +++ b/Command/WebApp.hs @@ -39,9 +39,12 @@ seek = [withNothing start] start :: CommandStart -start = notBareRepo $ do +start = start' True + +start' :: Bool -> CommandStart +start' allowauto = notBareRepo $ do liftIO $ ensureInstalled - ifM isInitialized ( go , liftIO startNoRepo ) + ifM isInitialized ( go , auto ) stop where go = do @@ -52,6 +55,11 @@ , startDaemon True True $ Just $ const $ openBrowser browser ) + auto + | allowauto = liftIO startNoRepo + | otherwise = do + d <- liftIO getCurrentDirectory + error $ "no git repository in " ++ d checkpid = do pidfile <- fromRepo gitAnnexPidFile liftIO $ isJust <$> checkDaemon pidfile @@ -74,7 +82,7 @@ (d:_) -> do changeWorkingDirectory d state <- Annex.new =<< Git.CurrentRepo.get - void $ Annex.eval state $ doCommand start + void $ Annex.eval state $ doCommand $ start' False {- Run the webapp without a repository, which prompts the user, makes one, - changes to it, starts the regular assistant, and redirects the @@ -125,8 +133,11 @@ openBrowser cmd htmlshim = go $ maybe runBrowser runCustomBrowser cmd where url = fileUrl htmlshim - go a = unlessM (a url) $ - error $ "failed to start web browser on url " ++ url + go a = do + putStrLn "" + putStrLn $ "Launching web browser on " ++ url + unlessM (a url) $ + error $ "failed to start web browser" runCustomBrowser c u = boolSystem c [Param u] {- web.browser is a generic git config setting for a web browser program -} diff --git a/Config.hs b/Config.hs --- a/Config.hs +++ b/Config.hs @@ -86,6 +86,11 @@ repoNotIgnored r = not . fromMaybe False . Git.Config.isTrue <$> getRemoteConfig r "ignore" "" +{- Checks if a repo should be synced. -} +repoSyncable :: Git.Repo -> Annex Bool +repoSyncable r = fromMaybe True . Git.Config.isTrue + <$> getRemoteConfig r "sync" "" + {- If a value is specified, it is used; otherwise the default is looked up - in git config. forcenumcopies overrides everything. -} getNumCopies :: Maybe Int -> Annex Int diff --git a/Git/Command.hs b/Git/Command.hs --- a/Git/Command.hs +++ b/Git/Command.hs @@ -73,7 +73,7 @@ pipeWriteRead :: [CommandParam] -> String -> Repo -> IO String pipeWriteRead params s repo = assertLocal repo $ writeReadProcessEnv "git" (toCommand $ gitCommandLine params repo) - (gitEnv repo) s + (gitEnv repo) s (Just fileEncoding) {- Runs a git subcommand, feeding it input on a handle with an action. -} pipeWrite :: [CommandParam] -> Repo -> (Handle -> IO ()) -> IO () diff --git a/Git/UnionMerge.hs b/Git/UnionMerge.hs --- a/Git/UnionMerge.hs +++ b/Git/UnionMerge.hs @@ -86,7 +86,7 @@ -- split it into lines to union merge. Using the -- FileSystemEncoding for this is a hack, but ensures there -- are no decoding errors. Note that this works because - -- streamUpdateIndex sets fileEncoding on its write handle. + -- hashObject sets fileEncoding on its write handle. getcontents s = lines . encodeW8 . L.unpack <$> catObject h s {- Calculates a union merge between a list of refs, with contents. diff --git a/GitAnnex.hs b/GitAnnex.hs --- a/GitAnnex.hs +++ b/GitAnnex.hs @@ -147,7 +147,7 @@ "skip files with fewer copies" , Option ['B'] ["inbackend"] (ReqArg Limit.addInBackend paramName) "skip files not using a key-value backend" - , Option [] ["ingroup"] (ReqArg Limit.addInGroup paramGroup) + , Option [] ["inallgroup"] (ReqArg Limit.addInAllGroup paramGroup) "skip files not present in all remotes in a group" , Option [] ["largerthan"] (ReqArg Limit.addLargerThan paramSize) "skip files larger than a size" diff --git a/INSTALL b/INSTALL --- a/INSTALL +++ b/INSTALL @@ -1,21 +1,20 @@ ## Pick your OS -Quick commands given where possible, but see the individual pages for -details. - -[[!table format=dsv header=no data=""" -[[OSX]] | [download git-annex.app](http://downloads.kitenet.net/git-annex/OSX/git-annex.dmg.bz2) **beta** +[[!table format=dsv header=yes data=""" +detailed instructions | quick install +[[OSX]] | [download git-annex.app](http://downloads.kitenet.net/git-annex/OSX/git-annex.dmg.bz2) **beta** [[Linux|linux_standalone]] | [download prebuilt linux tarball](http://downloads.kitenet.net/git-annex/linux/) -[[Debian]] | `apt-get install git-annex` -[[Ubuntu]] | `apt-get install git-annex` -[[FreeBSD]] | `pkg_add -r hs-git-annex` -[[ArchLinux]] | `yaourt -Sy git-annex` -[[NixOS]] | `nix-env -i git-annex` -[[Gentoo]] | `emerge git-annex` -[[ScientificLinux5]] | (and other RHEL5 clones like CentOS5) -[[Fedora]] | -[[openSUSE]] | -Windows | [[sorry, Windows not supported yet|todo/windows_support]] +[[Debian]] | `apt-get install git-annex` +[[Ubuntu]] | `apt-get install git-annex` +[[Fedora]] | `yum install git-annex` +[[FreeBSD]] | `pkg_add -r hs-git-annex` +[[ArchLinux]] | `yaourt -Sy git-annex` +[[NixOS]] | `nix-env -i git-annex` +[[Gentoo]] | `emerge git-annex` +[[NixOS]] | `nix install git-annex` +[[ScientificLinux5]] | (and other RHEL5 clones like CentOS5) +[[openSUSE]] | +Windows | [[sorry, Windows not supported yet|todo/windows_support]] """]] ## Using cabal diff --git a/Limit.hs b/Limit.hs --- a/Limit.hs +++ b/Limit.hs @@ -139,13 +139,13 @@ {- Adds a limit to skip files not believed to be present in all - repositories in the specified group. -} -addInGroup :: String -> Annex () -addInGroup groupname = do +addInAllGroup :: String -> Annex () +addInAllGroup groupname = do m <- groupMap - addLimit $ limitInGroup m groupname + addLimit $ limitInAllGroup m groupname -limitInGroup :: GroupMap -> MkLimit -limitInGroup m groupname +limitInAllGroup :: GroupMap -> MkLimit +limitInAllGroup m groupname | S.null want = Right $ const $ const $ return True | otherwise = Right $ \notpresent -> Backend.lookupFile >=> check notpresent diff --git a/Logs/Group.hs b/Logs/Group.hs --- a/Logs/Group.hs +++ b/Logs/Group.hs @@ -10,6 +10,7 @@ groupSet, lookupGroups, groupMap, + getStandardGroup, ) where import qualified Data.Map as M @@ -21,6 +22,7 @@ import qualified Annex import Logs.UUIDBased import Types.Group +import Types.StandardGroups {- Filename of group.log. -} groupLog :: FilePath @@ -64,3 +66,9 @@ bygroup = M.fromListWith S.union $ concat $ map explode $ M.toList byuuid explode (u, s) = map (\g -> (g, S.singleton u)) (S.toList s) + +{- If a repository is in exactly one standard group, returns it. -} +getStandardGroup :: S.Set Group -> Maybe StandardGroup +getStandardGroup s = case catMaybes $ map toStandardGroup $ S.toList s of + [g] -> Just g + _ -> Nothing diff --git a/Logs/PreferredContent.hs b/Logs/PreferredContent.hs --- a/Logs/PreferredContent.hs +++ b/Logs/PreferredContent.hs @@ -11,9 +11,11 @@ preferredContentMap, preferredContentMapRaw, checkPreferredContentExpression, + setStandardGroup, ) where import qualified Data.Map as M +import qualified Data.Set as S import Data.Either import Data.Time.Clock.POSIX @@ -27,6 +29,7 @@ import Git.FilePath import Types.Group import Logs.Group +import Types.StandardGroups {- Filename of preferred-content.log. -} preferredContentLog :: FilePath @@ -61,7 +64,8 @@ case cached of Just m -> return m Nothing -> do - m <- simpleMap . parseLog (Just . makeMatcher groupmap) + m <- simpleMap + . parseLogWithUUID ((Just .) . makeMatcher groupmap) <$> Annex.Branch.get preferredContentLog Annex.changeState $ \s -> s { Annex.preferredcontentmap = Just m } return m @@ -74,17 +78,28 @@ - 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 -> String -> Utility.Matcher.Matcher MatchFiles -makeMatcher groupmap s - | null (lefts tokens) = Utility.Matcher.generate $ rights tokens - | otherwise = Utility.Matcher.generate [] +makeMatcher :: GroupMap -> UUID -> String -> Utility.Matcher.Matcher MatchFiles +makeMatcher groupmap u s + | s == "standard" = standardMatcher groupmap u + | null (lefts tokens) = Utility.Matcher.generate $ rights tokens + | otherwise = matchAll where tokens = map (parseToken groupmap) (tokenizeMatcher s) +{- Standard matchers are pre-defined for some groups. If none is defined, + - or a repository is in multiple groups with standard matchers, match all. -} +standardMatcher :: GroupMap -> UUID -> Utility.Matcher.Matcher MatchFiles +standardMatcher m u = maybe matchAll (makeMatcher m u . preferredContent) $ + getStandardGroup =<< u `M.lookup` groupsByUUID m + +matchAll :: Utility.Matcher.Matcher MatchFiles +matchAll = Utility.Matcher.generate [] + {- Checks if an expression can be parsed, if not returns Just error -} checkPreferredContentExpression :: String -> Maybe String -checkPreferredContentExpression s = - case lefts $ map (parseToken emptyGroupMap) (tokenizeMatcher s) of +checkPreferredContentExpression s + | s == "standard" = Nothing + | otherwise = case lefts $ map (parseToken emptyGroupMap) (tokenizeMatcher s) of [] -> Nothing l -> Just $ unwords $ map ("Parse failure: " ++) l @@ -102,7 +117,7 @@ , ("inbackend", limitInBackend) , ("largerthan", limitSize (>)) , ("smallerthan", limitSize (<)) - , ("ingroup", limitInGroup groupmap) + , ("inallgroup", limitInAllGroup groupmap) ] use a = Utility.Matcher.Operation <$> a v @@ -113,3 +128,12 @@ tokenizeMatcher = filter (not . null ) . concatMap splitparens . words where splitparens = segmentDelim (`elem` "()") + +{- 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. -} +setStandardGroup :: UUID -> StandardGroup -> Annex () +setStandardGroup u g = do + groupSet u $ S.singleton $ fromStandardGroup g + m <- preferredContentMap + unless (isJust $ M.lookup u m) $ + preferredContentSet u "standard" diff --git a/Logs/UUIDBased.hs b/Logs/UUIDBased.hs --- a/Logs/UUIDBased.hs +++ b/Logs/UUIDBased.hs @@ -17,6 +17,7 @@ LogEntry(..), TimeStamp(..), parseLog, + parseLogWithUUID, showLog, changeLog, addLog, @@ -56,15 +57,18 @@ unwords [fromUUID k, shower v] parseLog :: (String -> Maybe a) -> String -> Log a -parseLog parser = M.fromListWith best . mapMaybe parse . lines +parseLog = parseLogWithUUID . const + +parseLogWithUUID :: (UUID -> String -> Maybe a) -> String -> Log a +parseLogWithUUID parser = M.fromListWith best . mapMaybe parse . lines where parse line | null ws = Nothing - | otherwise = parser (unwords info) >>= makepair + | otherwise = parser u (unwords info) >>= makepair where - makepair v = Just (toUUID u, LogEntry ts v) + makepair v = Just (u, LogEntry ts v) ws = words line - u = Prelude.head ws + u = toUUID $ Prelude.head ws t = Prelude.last ws ts | tskey `isPrefixOf` t = diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -1,7 +1,7 @@ CFLAGS=-Wall GIT_ANNEX_TMP_BUILD_DIR?=tmp IGNORE=-ignore-package monads-fd -ignore-package monads-tf -BASEFLAGS=-threaded -Wall $(IGNORE) -outputdir $(GIT_ANNEX_TMP_BUILD_DIR) -IUtility +BASEFLAGS=-Wall $(IGNORE) -outputdir $(GIT_ANNEX_TMP_BUILD_DIR) -IUtility # If you get build failures due to missing haskell libraries, # you can turn off some of these features. @@ -18,8 +18,10 @@ ifeq ($(OS),Linux) OPTFLAGS=-DWITH_INOTIFY -DWITH_DBUS clibs=Utility/libdiskfree.o Utility/libmounts.o +THREADFLAGS=$(shell if test -e `ghc --print-libdir`/libHSrts_thr.a; then printf -- -threaded; fi) else # BSD system +THREADFLAGS=-threaded OPTFLAGS=-DWITH_KQUEUE clibs=Utility/libdiskfree.o Utility/libmounts.o Utility/libkqueue.o ifeq ($(OS),Darwin) @@ -31,11 +33,13 @@ endif endif +ALLFLAGS = $(BASEFLAGS) $(FEATURES) $(OPTFLAGS) $(THREADFLAGS) + PREFIX=/usr -GHCFLAGS=-O2 $(BASEFLAGS) $(FEATURES) $(OPTFLAGS) +GHCFLAGS=-O2 $(ALLFLAGS) ifdef PROFILE -GHCFLAGS=-prof -auto-all -rtsopts -caf-all -fforce-recomp $(BASEFLAGS) $(FEATURES) $(OPTFLAGS) +GHCFLAGS=-prof -auto-all -rtsopts -caf-all -fforce-recomp $(ALLFLAGS) endif GHCMAKE=ghc $(GHCFLAGS) --make @@ -51,7 +55,7 @@ sources: $(sources) # Disables optimisation. Not for production use. -fast: GHCFLAGS=$(BASEFLAGS) $(FEATURES) $(OPTFLAGS) +fast: GHCFLAGS=$(ALLFLAGS) fast: $(bins) Build/SysConfig.hs: configure.hs Build/TestConfig.hs Build/Configure.hs diff --git a/Remote.hs b/Remote.hs --- a/Remote.hs +++ b/Remote.hs @@ -27,6 +27,7 @@ byCost, prettyPrintUUIDs, prettyListUUIDs, + repoFromUUID, remotesWithUUID, remotesWithoutUUID, keyLocations, @@ -52,6 +53,7 @@ import Logs.Trust import Logs.Location import Remote.List +import qualified Git {- Map from UUIDs of Remotes to a calculated value. -} remoteMap :: (Remote -> a) -> Annex (M.Map UUID a) @@ -144,6 +146,17 @@ | otherwise = n where n = finddescription m u + +{- Gets the git repo associated with a UUID. + - There's no associated remote when this is the UUID of the local repo. -} +repoFromUUID :: UUID -> Annex (Git.Repo, Maybe Remote) +repoFromUUID u = ifM ((==) u <$> getUUID) + ( (,) <$> gitRepo <*> pure Nothing + , do + remote <- fromMaybe (error "Unknown UUID") . M.lookup u + <$> remoteMap id + return (repo remote, Just remote) + ) {- Filters a list of remotes to ones that have the listed uuids. -} remotesWithUUID :: [Remote] -> [UUID] -> [Remote] diff --git a/Remote/Git.hs b/Remote/Git.hs --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -22,6 +22,7 @@ import qualified Git import qualified Git.Config import qualified Git.Construct +import qualified Git.Command import qualified Annex import Logs.Presence import Logs.Transfer @@ -126,7 +127,20 @@ tryGitConfigRead :: Git.Repo -> Annex Git.Repo tryGitConfigRead r | not $ M.null $ Git.config r = return r -- already read - | Git.repoIsSsh r = store $ onRemote r (pipedconfig, r) "configlist" [] [] + | 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 "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 "config" [Param k, Param "true"] + return r + _ -> return r | Git.repoIsHttp r = do headers <- getHttpHeaders store $ safely $ geturlconfig headers @@ -140,18 +154,21 @@ safely a = either (const $ return r) return =<< liftIO (try a :: IO (Either SomeException Git.Repo)) - pipedconfig cmd params = safely $ + pipedconfig cmd params = withHandle StdoutHandle createProcessSuccess p $ Git.Config.hRead r where p = proc cmd $ toCommand params + pipedsshconfig cmd params = + liftIO (try (pipedconfig cmd params) :: IO (Either SomeException Git.Repo)) + geturlconfig headers = do s <- Url.get (Git.repoLocation r ++ "/config") headers withTempFile "git-annex.tmp" $ \tmpfile h -> do hPutStr h s hClose h - pipedconfig "git" [Param "config", Param "--null", Param "--list", Param "--file", File tmpfile] + safely $ pipedconfig "git" [Param "config", Param "--null", Param "--list", Param "--file", File tmpfile] store = observe $ \r' -> do g <- gitRepo diff --git a/Types/StandardGroups.hs b/Types/StandardGroups.hs new file mode 100644 --- /dev/null +++ b/Types/StandardGroups.hs @@ -0,0 +1,37 @@ +{- git-annex standard repository groups + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Types.StandardGroups where + +data StandardGroup = ClientGroup | TransferGroup | ArchiveGroup | BackupGroup + deriving (Eq, Ord, Enum, Bounded, Show) + +fromStandardGroup :: StandardGroup -> String +fromStandardGroup ClientGroup = "client" +fromStandardGroup TransferGroup = "transfer" +fromStandardGroup ArchiveGroup = "archive" +fromStandardGroup BackupGroup = "backup" + +toStandardGroup :: String -> Maybe StandardGroup +toStandardGroup "client" = Just ClientGroup +toStandardGroup "transfer" = Just TransferGroup +toStandardGroup "archive" = Just ArchiveGroup +toStandardGroup "backup" = Just BackupGroup +toStandardGroup _ = Nothing + +descStandardGroup :: StandardGroup -> String +descStandardGroup ClientGroup = "client: a repository on your computer" +descStandardGroup TransferGroup = "transfer: distributes files to clients" +descStandardGroup ArchiveGroup = "archive: collects files that are not archived elsewhere" +descStandardGroup BackupGroup = "backup: collects all files" + +{- See doc/preferred_content.mdwn for explanations of these expressions. -} +preferredContent :: StandardGroup -> String +preferredContent ClientGroup = "exclude=*/archive/*" +preferredContent TransferGroup = "not inallgroup=client and " ++ preferredContent ClientGroup +preferredContent ArchiveGroup = "not copies=archive:1" +preferredContent BackupGroup = "" -- all content is preferred diff --git a/Utility/Applicative.o b/Utility/Applicative.o new file mode 100644 Binary files /dev/null and b/Utility/Applicative.o differ diff --git a/Utility/CoProcess.o b/Utility/CoProcess.o new file mode 100644 Binary files /dev/null and b/Utility/CoProcess.o differ diff --git a/Utility/Directory.o b/Utility/Directory.o new file mode 100644 Binary files /dev/null and b/Utility/Directory.o differ diff --git a/Utility/Exception.o b/Utility/Exception.o new file mode 100644 Binary files /dev/null and b/Utility/Exception.o differ diff --git a/Utility/FileMode.o b/Utility/FileMode.o new file mode 100644 Binary files /dev/null and b/Utility/FileMode.o differ diff --git a/Utility/FileSystemEncoding.o b/Utility/FileSystemEncoding.o new file mode 100644 Binary files /dev/null and b/Utility/FileSystemEncoding.o differ diff --git a/Utility/Misc.o b/Utility/Misc.o new file mode 100644 Binary files /dev/null and b/Utility/Misc.o differ diff --git a/Utility/Monad.o b/Utility/Monad.o new file mode 100644 Binary files /dev/null and b/Utility/Monad.o differ diff --git a/Utility/PartialPrelude.o b/Utility/PartialPrelude.o new file mode 100644 Binary files /dev/null and b/Utility/PartialPrelude.o differ diff --git a/Utility/Path.o b/Utility/Path.o new file mode 100644 Binary files /dev/null and b/Utility/Path.o differ diff --git a/Utility/Process.hs b/Utility/Process.hs --- a/Utility/Process.hs +++ b/Utility/Process.hs @@ -64,17 +64,24 @@ , env = environ } -{- Writes stdout to a process, returns its output, and also allows specifying - - the environment. -} +{- Writes a string to a process on its stdout, + - returns its output, and also allows specifying the environment. + - + - + -} writeReadProcessEnv :: FilePath -> [String] -> Maybe [(String, String)] - -> String + -> String + -> (Maybe (Handle -> IO ())) -> IO String -writeReadProcessEnv cmd args environ input = do +writeReadProcessEnv cmd args environ input adjusthandle = do (Just inh, Just outh, _, pid) <- createProcess p + maybe (return ()) (\a -> a inh) adjusthandle + maybe (return ()) (\a -> a outh) adjusthandle + -- fork off a thread to start consuming the output output <- hGetContents outh outMVar <- newEmptyMVar @@ -203,7 +210,6 @@ debugM "Utility.Process" $ unwords [ action ++ ":" , showCmd p - , maybe "" show (env p) ] where action diff --git a/Utility/Process.o b/Utility/Process.o new file mode 100644 Binary files /dev/null and b/Utility/Process.o differ diff --git a/Utility/SafeCommand.o b/Utility/SafeCommand.o new file mode 100644 Binary files /dev/null and b/Utility/SafeCommand.o differ diff --git a/Utility/TempFile.o b/Utility/TempFile.o new file mode 100644 Binary files /dev/null and b/Utility/TempFile.o differ diff --git a/Utility/Url.hs b/Utility/Url.hs --- a/Utility/Url.hs +++ b/Utility/Url.hs @@ -5,6 +5,8 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE CPP #-} + module Utility.Url ( URLString, check, @@ -108,6 +110,10 @@ Nothing -> return rsp Just newURI -> go n newURI_abs where +#ifdef URI_24 + newURI_abs = newURI `relativeTo` u +#else newURI_abs = fromMaybe newURI (newURI `relativeTo` u) +#endif addheaders req = setHeaders req (rqHeaders req ++ userheaders) userheaders = rights $ map parseHeader headers diff --git a/debian/changelog b/debian/changelog --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,25 @@ +git-annex (3.20121010) unstable; urgency=low + + * Renamed --ingroup to --inallgroup. + * Standard groups changed to client, transfer, archive, and backup. + Each of these has its own standard preferred content setting. + * dead: Remove dead repository from all groups. + * Avoid unsetting HOME when running certian git commands. Closes: #690193 + * test: Fix threaded runtime hang. + * Makefile: Avoid building with -threaded if the ghc threaded runtime does + not exist. + * webapp: Improve wording of intro display. Closes: #689848 + * webapp: Repositories can now be configured, to change their description, + their group, or even to disable syncing to them. + * git config remote.name.annex-sync can be used to control whether + a remote gets synced. + * Fix a crash when merging files in the git-annex branch that contain + invalid utf8. + * Automatically detect when a ssh remote does not have git-annex-shell + installed, and set annex-ignore. + + -- Joey Hess Fri, 12 Oct 2012 13:45:21 -0400 + git-annex (3.20121009) unstable; urgency=low * watch, assistant: It's now safe to git annex unlock files while diff --git a/doc/assistant/errata.mdwn b/doc/assistant/errata.mdwn --- a/doc/assistant/errata.mdwn +++ b/doc/assistant/errata.mdwn @@ -1,3 +1,36 @@ +## version 3.20121009 + +This is a maintenance release of the git-annex assistant, which is still in +beta. + +In general, anything you can configure with the assistant's web app +will work. Some examples of use cases supported by this release include: + +* [[Pairing|pairing_walkthrough]] two computers that are on the same local + network (or VPN) and automatically keeping the files in the annex in + sync as changes are made to them. +* Cloning your repository to removable drives, USB keys, etc. The assistant + will notice when the drive is mounted and keep it in sync. + Such a drive can be stored as an offline backup, or transported between + computers to keep them in sync. +* Cloning your repository to a remote server, running ssh, and uploading + changes made to your files to the server. There is special support + for using the rsync.net cloud provider this way, or any shell account + on a typical unix server, such as a Linode VPS can be used. + +The following are known limitations of this release of the git-annex +assistant: + +* On Mac OSX and BSD operating systems, the assistant uses kqueue to watch + files. Kqueue has to open every directory it watches, so too many + directories will run it out of the max number of open files (typically + 1024), and fail. See [[bugs/Issue_on_OSX_with_some_system_limits]] + for a workaround. +* In order to ensure that all multiple repositories are kept in sync, + each computer with a repository must be running the git-annex assistant. +* The assistant does not yet always manage to keep repositories in sync + when some are hidden from others behind firewalls. + ## version 3.20120924 This is the first beta release of the git-annex assistant. diff --git a/doc/assistant/repogroups.png b/doc/assistant/repogroups.png new file mode 100644 Binary files /dev/null and b/doc/assistant/repogroups.png differ diff --git a/doc/assistant/thanks.mdwn b/doc/assistant/thanks.mdwn --- a/doc/assistant/thanks.mdwn +++ b/doc/assistant/thanks.mdwn @@ -32,6 +32,7 @@ * AJ Ashton * Svenne Krap * Drew Hess +* Peter van Westen ## Prioritizers @@ -45,7 +46,8 @@ Ian McEwen, asc, Paul Tagliamonte, Sherif Abouseda, Igor Támara, Anne Wind, Mesar Hameed, Brandur K. Holm Petersen, Takahiro Inoue, Kai Hendry, Stephen Youndt, Lee Roberson, Ben Strawbridge, Andrew Greenberg, Alfred Adams -Andrew, Aaron De Vries, Monti Knazze, Jorge Canseco, Hamish, Mark Eichin +Andrew, Aaron De Vries, Monti Knazze, Jorge Canseco, Hamish, Mark Eichin, +Sherif Abouseda, Ben Strawbridge And special thanks to Kevin McKenzie, who also gave me a login to a Mac OSX machine, which has proven invaluable, and Jimmy Tang who has helped @@ -79,7 +81,7 @@ Manuel Roumain, Jason Walsh, np, Shawn, Johan Tibell, Branden Tyree, Dinyar Rabady, Andrew Mason, damond armstead, Ethan Aubin, TomTom Tommie, Jimmy Kaplowitz, Steven Zakulec, mike smith, Jacob Kirkwood, Mark Hymers, Nathan -Collins, Asbjørn Sloth Tønnesen, Misty De Meo, +Collins, Asbjørn Sloth Tønnesen, Misty De Meo, James Shubin, Jim Paris, Adam Sjøgren, miniBill, Taneli, Kumar Appaiah, Greg Grossmeier, Sten Turpin, Otavio Salvador, Teemu Hukkanen, Brian Stengaard, bob walker, bibeneus, andrelo, Yaroslav Halchenko, hesfalling, Tommy L, jlargentaye, @@ -215,7 +217,8 @@ Woofenden, Joe Danziger, Declan Morahan, KaptainUfolog, Vladron, bart, Jeff McNeill, Christian Schlotter, Ben McQuillan, Anthony, Julian, Martin O, altruism, Eric Solheim, MarkS, ndrwc, Matthew, David Lehn, Matthew -Cisneros, Mike Skoglund, Kristy Carey +Cisneros, Mike Skoglund, Kristy Carey, fmotta, Tom Lowenthal, Branden +Tyree ## Also thanks to diff --git a/doc/bugs/error_when_using_repositories_with_non-ASCII_characters.mdwn b/doc/bugs/error_when_using_repositories_with_non-ASCII_characters.mdwn --- a/doc/bugs/error_when_using_repositories_with_non-ASCII_characters.mdwn +++ b/doc/bugs/error_when_using_repositories_with_non-ASCII_characters.mdwn @@ -57,3 +57,6 @@ > try to look at it again soon; the last 2 times I looked at that code > I could not see an easy way to make it allow invalid utf-8 encoded data. > --[[Joey]] + +>> [[done]], although I am no longer so sure this was the last utf-8 +>> encoding bug.. --[[Joey]] diff --git a/doc/bugs/fatal:_empty_ident_name.mdwn b/doc/bugs/fatal:_empty_ident_name.mdwn --- a/doc/bugs/fatal:_empty_ident_name.mdwn +++ b/doc/bugs/fatal:_empty_ident_name.mdwn @@ -46,3 +46,6 @@ **Please provide any additional information below.** > [[done]] by adding name to the user, in /etc/passwd. --Stone + +>> Actually, [[done]] by avoiding clobbering HOME when running some git +>> commands. --[[Joey]] diff --git a/doc/design/assistant/blog/.day_101__transfer_control_done.mdwn.swp b/doc/design/assistant/blog/.day_101__transfer_control_done.mdwn.swp deleted file mode 100644 Binary files a/doc/design/assistant/blog/.day_101__transfer_control_done.mdwn.swp and /dev/null differ diff --git a/doc/design/assistant/blog/day_101__transfer_control_done.mdwn b/doc/design/assistant/blog/day_101__transfer_control_done.mdwn deleted file mode 100644 --- a/doc/design/assistant/blog/day_101__transfer_control_done.mdwn +++ /dev/null @@ -1,12 +0,0 @@ -Got the assistant honoring preferred content settings. Although so far that -only determines what it transfers. Additional work will be needed to make -content be dropped when it stops being preferred. - ----- - -Now all repositories created by the webapp will be put into one of three -groups: clients, drives, and servers. - ----- - - diff --git a/doc/design/assistant/blog/day_102__very_high_level_programming.mdwn b/doc/design/assistant/blog/day_102__very_high_level_programming.mdwn new file mode 100644 --- /dev/null +++ b/doc/design/assistant/blog/day_102__very_high_level_programming.mdwn @@ -0,0 +1,37 @@ +## today + +Came up with four groups of repositories that it makes sense to +define standard preferred content expressions for. + +[[!format haskell """ + preferredContent :: StandardGroup -> String + preferredContent ClientGroup = "exclude=*/archive/*" + preferredContent TransferGroup = "not inallgroup=client and " ++ preferredContent ClientGroup + preferredContent ArchiveGroup = "not copies=archive:1" + preferredContent BackupGroup = "" -- all content is preferred +"""]] + +[[preferred_content]] has the details about these groups, but +as I was writing those three preferred content expressions, +I realized they are some of the highest level programming I've ever done, +in a way. + +Anyway, these make for a very simple repository configuration UI: + +[[!img /assistant/repogroups.png alt="form with simple select box"]] + +## yesterday (forgot to post this) + +Got the assistant honoring preferred content settings. Although so far that +only determines what it transfers. Additional work will be needed to make +content be dropped when it stops being preferred. + +---- + +Added a "configure" link next to each repository on the repository config +page. This will go to a form to allow setting things like repository +descriptions, groups, and preferred content settings. + +---- + +Cut a release. diff --git a/doc/design/assistant/blog/day_103__bugfix_day.mdwn b/doc/design/assistant/blog/day_103__bugfix_day.mdwn new file mode 100644 --- /dev/null +++ b/doc/design/assistant/blog/day_103__bugfix_day.mdwn @@ -0,0 +1,25 @@ +Bugfixes all day. + +The most amusing bug, which I just stumbled over randomly on my own, +after someone on IRC yesterday was possibly encountering the same issue, +made `git annex webapp` go into an infinite memory-consuming loop on +startup if the repository it had been using was no longer a valid git +repository. + +Then there was the place where HOME got unset, with also sometimes amusing +results. + +Also fixed several build problems, including a threaded runtime hang +in the test suite. Hopefully the next release will build on all Debian +architectures again. + +I'll be cutting that release tomorrow. I also updated the linux +prebuilt tarballs today. + +---- + +Hmm, not entirely bugfixes after all. Had time (and power) to work +on the repository configuration form too, and added a check box to it that +can be unchecked to disable syncing with a repository. +Also, made that form be displayed after the webapp creates a new +repository. diff --git a/doc/design/assistant/blog/day_104__foo.mdwn b/doc/design/assistant/blog/day_104__foo.mdwn new file mode 100644 --- /dev/null +++ b/doc/design/assistant/blog/day_104__foo.mdwn @@ -0,0 +1,15 @@ +Switched the OSX standalone app to use `DYLD_ROOT_PATH`. +This is the third `DYLD_*` variable I've tried; neither +of the other two worked in all situations. This one may do better. +If not, I may be stuck modifying the library names in each executable +using `install_name_tool` +([good reference for doing that](http://www.mikeash.com/pyblog/friday-qa-2009-11-06-linking-and-install-names.html)). +As far as I know, every existing dynamic library lookup system is broken +in some way other other; nothing I've seen about OSX's so far +disproves that rule. + +Fixed a nasty utf-8 encoding crash that could occur when merging the +git-annex branch. I hope I'm almost done with those. + +Made git-annex auto-detect when a git remote is on a sever like github +that doesn't support git-annex, and automatically set annex-ignore. diff --git a/doc/design/assistant/polls/prioritizing_special_remotes.mdwn b/doc/design/assistant/polls/prioritizing_special_remotes.mdwn --- a/doc/design/assistant/polls/prioritizing_special_remotes.mdwn +++ b/doc/design/assistant/polls/prioritizing_special_remotes.mdwn @@ -6,7 +6,7 @@ Help me prioritize my work: What special remote would you most like to use with the git-annex assistant? -[[!poll open=yes 14 "Amazon S3 (done)" 9 "Amazon Glacier" 7 "Box.com" 54 "My phone (or MP3 player)" 7 "Tahoe-LAFS" 3 "OpenStack SWIFT" 16 "Google Drive"]] +[[!poll open=yes 15 "Amazon S3 (done)" 9 "Amazon Glacier" 7 "Box.com" 55 "My phone (or MP3 player)" 9 "Tahoe-LAFS" 4 "OpenStack SWIFT" 16 "Google Drive"]] This poll is ordered with the options I consider easiest to build listed first. Mostly because git-annex already supports them and they diff --git a/doc/design/assistant/webapp.mdwn b/doc/design/assistant/webapp.mdwn --- a/doc/design/assistant/webapp.mdwn +++ b/doc/design/assistant/webapp.mdwn @@ -8,6 +8,11 @@ This is quite likely because of how the div containing transfers is refereshed. If instead javascript was used to update the progress bar etc for transfers with json data, the buttons would work better. +* Disabling syncing to a remote doesn't stop any running transfer scan, + which can still queue uploads or downloads to the remote. +* Transfers from a remote with syncing disabled show as from "unknown". + (Note that it's probably not practical to prevent a remote with syncing + disabled from initiating transfers, so this can happen.) ## interface diff --git a/doc/forum/Can__39__t_get_pairing_to_work.mdwn b/doc/forum/Can__39__t_get_pairing_to_work.mdwn new file mode 100644 --- /dev/null +++ b/doc/forum/Can__39__t_get_pairing_to_work.mdwn @@ -0,0 +1,5 @@ +I'm trying to pair my ~/music repositories on my two laptops (Ubuntu 10.04 and 12.04) using the Linux standalone tarball on my home WiFi network. After entering the same passphrase on both machines, nothing happens, both remain in "Pairing in progress" state. + +The router I'm using is, I think, fairly standard, it's a ZyXEL P-2812HNU-F1 with factory settings. + +Are others having the problem too? Any advice where I should start looking for what goes wrong? diff --git a/doc/forum/Pushing_git_repo_to_AWS_S3_from_behind_proxy.mdwn b/doc/forum/Pushing_git_repo_to_AWS_S3_from_behind_proxy.mdwn new file mode 100644 --- /dev/null +++ b/doc/forum/Pushing_git_repo_to_AWS_S3_from_behind_proxy.mdwn @@ -0,0 +1,9 @@ +I want to setup my remote git repo on S3 +Referred to +http://git-annex.branchable.com/tips/using_Amazon_S3/ +http://git-annex.branchable.com/special_remotes/S3/ + +I need support for AWS.config param proxy_uri +http://docs.amazonwebservices.com/AWSRubySDK/latest/AWS.html + +Can some one help? diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn --- a/doc/git-annex.mdwn +++ b/doc/git-annex.mdwn @@ -636,14 +636,14 @@ Matches only files that git-annex believes have the specified number of copies, on remotes in the specified group. For example, - "--copies=archival:2" + "--copies=archive:2" * --inbackend=name Matches only files whose content is stored using the specified key-value backend. -* --ingroup=groupname +* --inallgroup=groupname Matches only files that git-annex believes are present in all repositories in the specified group. @@ -794,6 +794,11 @@ 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. + +* `remote..annex-sync` + + If set to `false`, prevents git-annex sync (and the git-annex assistant) + from syncing with this remote. * `remote..annexUrl` diff --git a/doc/install.mdwn b/doc/install.mdwn --- a/doc/install.mdwn +++ b/doc/install.mdwn @@ -1,21 +1,20 @@ ## Pick your OS -Quick commands given where possible, but see the individual pages for -details. - -[[!table format=dsv header=no data=""" -[[OSX]] | [download git-annex.app](http://downloads.kitenet.net/git-annex/OSX/git-annex.dmg.bz2) **beta** +[[!table format=dsv header=yes data=""" +detailed instructions | quick install +[[OSX]] | [download git-annex.app](http://downloads.kitenet.net/git-annex/OSX/git-annex.dmg.bz2) **beta** [[Linux|linux_standalone]] | [download prebuilt linux tarball](http://downloads.kitenet.net/git-annex/linux/) -[[Debian]] | `apt-get install git-annex` -[[Ubuntu]] | `apt-get install git-annex` -[[FreeBSD]] | `pkg_add -r hs-git-annex` -[[ArchLinux]] | `yaourt -Sy git-annex` -[[NixOS]] | `nix-env -i git-annex` -[[Gentoo]] | `emerge git-annex` -[[ScientificLinux5]] | (and other RHEL5 clones like CentOS5) -[[Fedora]] | -[[openSUSE]] | -Windows | [[sorry, Windows not supported yet|todo/windows_support]] +[[Debian]] | `apt-get install git-annex` +[[Ubuntu]] | `apt-get install git-annex` +[[Fedora]] | `yum install git-annex` +[[FreeBSD]] | `pkg_add -r hs-git-annex` +[[ArchLinux]] | `yaourt -Sy git-annex` +[[NixOS]] | `nix-env -i git-annex` +[[Gentoo]] | `emerge git-annex` +[[NixOS]] | `nix install git-annex` +[[ScientificLinux5]] | (and other RHEL5 clones like CentOS5) +[[openSUSE]] | +Windows | [[sorry, Windows not supported yet|todo/windows_support]] """]] ## Using cabal diff --git a/doc/install/Fedora.mdwn b/doc/install/Fedora.mdwn --- a/doc/install/Fedora.mdwn +++ b/doc/install/Fedora.mdwn @@ -1,10 +1,12 @@ -git-annex is recently finding its way into Fedora. +git-annex is available in recent versions of Fedora. Although it is +not currently a very recent version, it should work ok. +[status](http://koji.fedoraproject.org/koji/packageinfo?packageID=14145) -* [Status of getting a Fedora package](https://bugzilla.redhat.com/show_bug.cgi?id=662259) -* [Koji build for F17](http://koji.fedoraproject.org/koji/buildinfo?buildID=328654) -* [Koji build for F16](http://koji.fedoraproject.org/koji/buildinfo?buildID=328656) +Should be as simple as: `yum install git-annex` -Installation recipe for Fedora 14 thruough 15. +---- + +Older version? Here's an installation recipe for Fedora 14 through 15. 
 sudo yum install ghc cabal-install pcre-devel
diff --git a/doc/install/OSX/comment_4_d68c36432c7be3f4a76f4f0d7300bac9._comment b/doc/install/OSX/comment_4_d68c36432c7be3f4a76f4f0d7300bac9._comment
new file mode 100644
--- /dev/null
+++ b/doc/install/OSX/comment_4_d68c36432c7be3f4a76f4f0d7300bac9._comment
@@ -0,0 +1,20 @@
+[[!comment format=mdwn
+ username="https://www.google.com/accounts/o8/id?id=AItOawmY_4MvT5yEeztrS7UIJseStUe4mtgp6YE"
+ nickname="Сергей"
+ subject="Have error"
+ date="2012-10-10T11:47:09Z"
+ content="""
+[ 98 of 248] Compiling Utility.DiskFree ( Utility/DiskFree.hs, dist/build/git-annex/git-annex-tmp/Utility/DiskFree.o )
+[ 99 of 248] Compiling Utility.Url      ( Utility/Url.hs, dist/build/git-annex/git-annex-tmp/Utility/Url.o )
+
+Utility/Url.hs:111:88:
+    Couldn't match expected type `Maybe URI' with actual type `URI'
+    In the second argument of `fromMaybe', namely
+      `(newURI `relativeTo` u)'
+    In the expression: fromMaybe newURI (newURI `relativeTo` u)
+    In an equation for `newURI_abs':
+        newURI_abs = fromMaybe newURI (newURI `relativeTo` u)
+cabal: Error: some packages failed to install:
+git-annex-3.20121009 failed during the building phase. The exception was:
+ExitFailure 1
+"""]]
diff --git a/doc/install/OSX/comment_5_626a4b4bf302d4ae750174f860402f70._comment b/doc/install/OSX/comment_5_626a4b4bf302d4ae750174f860402f70._comment
new file mode 100644
--- /dev/null
+++ b/doc/install/OSX/comment_5_626a4b4bf302d4ae750174f860402f70._comment
@@ -0,0 +1,8 @@
+[[!comment format=mdwn
+ username="http://joeyh.name/"
+ ip="4.153.248.164"
+ subject="comment 5"
+ date="2012-10-10T15:34:23Z"
+ content="""
+@Сергей, I've fixeed that in git.
+"""]]
diff --git a/doc/news/version_3.20120807.mdwn b/doc/news/version_3.20120807.mdwn
deleted file mode 100644
--- a/doc/news/version_3.20120807.mdwn
+++ /dev/null
@@ -1,7 +0,0 @@
-git-annex 3.20120807 released with [[!toggle text="these changes"]]
-[[!toggleable text="""
-   * initremote: Avoid recording remote's description before checking
-     that its config is valid.
-   * unused, status: Avoid crashing when ran in bare repo.
-   * Avoid crashing when "git annex get" fails to download from one
-     location, and falls back to downloading from a second location."""]]
diff --git a/doc/news/version_3.20121010.mdwn b/doc/news/version_3.20121010.mdwn
new file mode 100644
--- /dev/null
+++ b/doc/news/version_3.20121010.mdwn
@@ -0,0 +1,19 @@
+git-annex 3.20121010 released with [[!toggle text="these changes"]]
+[[!toggleable text="""
+   * Renamed --ingroup to --inallgroup.
+   * Standard groups changed to client, transfer, archive, and backup.
+     Each of these has its own standard preferred content setting.
+   * dead: Remove dead repository from all groups.
+   * Avoid unsetting HOME when running certian git commands. Closes: #[690193](http://bugs.debian.org/690193)
+   * test: Fix threaded runtime hang.
+   * Makefile: Avoid building with -threaded if the ghc threaded runtime does
+     not exist.
+   * webapp: Improve wording of intro display. Closes: #[689848](http://bugs.debian.org/689848)
+   * webapp: Repositories can now be configured, to change their description,
+     their group, or even to disable syncing to them.
+   * git config remote.name.annex-sync can be used to control whether
+     a remote gets synced.
+   * Fix a crash when merging files in the git-annex branch that contain
+     invalid utf8.
+   * Automatically detect when a ssh remote does not have git-annex-shell
+     installed, and set annex-ignore."""]]
diff --git a/doc/preferred_content.mdwn b/doc/preferred_content.mdwn
--- a/doc/preferred_content.mdwn
+++ b/doc/preferred_content.mdwn
@@ -28,10 +28,52 @@
 
 So, just remove the dashes, basically.
 
+## file matching
+
 Note that while --include and --exclude match files relative to the current
 directory, preferred content expressions always match files relative to the
-top of the git repository. Perhaps you put files into `out/` directories
+top of the git repository. Perhaps you put files into `archive` directories
 when you're done with them. Then you could configure your laptop to prefer
 to not retain those files, like this:
 
-	exclude=*/out/*
+	exclude=*/archive/*
+
+## standard expressions
+
+git-annex comes with some standard preferred content expressions, that can
+be used with repositories that are in some pre-defined groups. To make a
+repository use one of these, just set its preferred content expression
+to "standard", and put it in one of these groups:
+
+### client
+
+All content is preferred, unless it's in a "archive" directory.
+
+`exclude=*/archive/*`
+
+### transfer
+
+Use for repositories that are used to transfer data between other
+repositories, but do not need to retain data themselves. For
+example, a repository on a server, or in the cloud, or a small
+USB drive used in a sneakernet.
+
+The preferred content expression for these causes them to get and retain
+data until all clients have a copy.
+
+`not inallgroup=client and exclude=*/archive/*`
+
+### archive
+
+All content is preferred, unless it's already been archived somewhere else.
+
+`not copies=archive:1`
+
+Note that if you want to archive multiple copies (not a bad idea!),
+you should instead configure all your archive repositories with a
+version of the above preferred content expression with a larger
+number of copies.
+
+### backup
+
+All content is preferred.
diff --git a/git-annex.1 b/git-annex.1
--- a/git-annex.1
+++ b/git-annex.1
@@ -564,13 +564,13 @@
 .IP "\-\-copies=groupname:number"
 Matches only files that git\-annex believes have the specified number of
 copies, on remotes in the specified group. For example,
-"\-\-copies=archival:2"
+"\-\-copies=archive:2"
 .IP
 .IP "\-\-inbackend=name"
 Matches only files whose content is stored using the specified key\-value
 backend.
 .IP
-.IP "\-\-ingroup=groupname"
+.IP "\-\-inallgroup=groupname"
 Matches only files that git\-annex believes are present in all repositories
 in the specified group.
 .IP
@@ -697,6 +697,10 @@
 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
+.IP "remote..annex\-sync"
+If set to false, prevents git\-annex sync (and the git\-annex assistant)
+from syncing with this remote.
 .IP
 .IP "remote..annexUrl"
 Can be used to specify a different url than the regular remote..url
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: 3.20121009
+Version: 3.20121010
 Cabal-Version: >= 1.8
 License: GPL
 Maintainer: Joey Hess 
@@ -46,7 +46,8 @@
 Executable git-annex
   Main-Is: git-annex.hs
   Build-Depends: MissingH, hslogger, directory, filepath,
-   unix, containers, utf8-string, network, mtl, bytestring, old-locale, time,
+   unix, containers, utf8-string, network (>= 2.4.0.1), mtl,
+   bytestring, old-locale, time,
    pcre-light, extensible-exceptions, dataenc, SHA, process, json, HTTP,
    base == 4.5.*, monad-control, transformers-base, lifted-base,
    IfElse, text, QuickCheck >= 2.1, bloomfilter, edit-distance, process
@@ -58,6 +59,7 @@
     C-Sources: Utility/libkqueue.c
   Extensions: CPP
   GHC-Options: -threaded
+  CPP-Options: -DURI_24
 
   if flag(S3)
     Build-Depends: hS3
diff --git a/standalone/osx/git-annex.app/Contents/MacOS/runshell b/standalone/osx/git-annex.app/Contents/MacOS/runshell
--- a/standalone/osx/git-annex.app/Contents/MacOS/runshell
+++ b/standalone/osx/git-annex.app/Contents/MacOS/runshell
@@ -31,15 +31,17 @@
 PATH=$base/bin:$PATH
 export PATH
 
-# Using DYLD_FALLBACK_LIBRARY_PATH rather than DYLD_LIBRARY_PATH, so as
-# not to force binaries to link against possibly the wrong versions of
-# libraries found in the path. With DYLD_FALLBACK_LIBRARY_PATH, the
-# system's versions of libraries will be used when possible, and otherwise
-# it will fall back to using the libraries bundled with this app.
-for lib in $(cat $base/libdirs); do
-	DYLD_FALLBACK_LIBRARY_PATH="$base/$lib:$DYLD_FALLBACK_LIBRARY_PATH"
-done
-export DYLD_FALLBACK_LIBRARY_PATH
+# This makes the linker first look in the library directories bundled
+# in this app. Only if it fails to find a library there will a system
+# library be used.
+# 
+# This seems to work better than DYLD_LIBRARY_PATH, which can force
+# the wrong version of a library to be used, if the app bundles two
+# different versions of a single library. And it seems to work better
+# than DYLD_FALLBACK_LIBRARY_PATH, which fails to override old system
+# versions of libraries when a program in the app needs a newer version.
+DYLD_ROOT_PATH=$base
+export DYLD_ROOT_PATH
 
 GIT_EXEC_PATH=$base/git-core
 export GIT_EXEC_PATH
diff --git a/templates/configurators/editrepository.hamlet b/templates/configurators/editrepository.hamlet
--- a/templates/configurators/editrepository.hamlet
+++ b/templates/configurators/editrepository.hamlet
@@ -1,6 +1,17 @@
 

   

-    Configuring #{description}
+    Configuring repository
+  $if new
+    

+      This repository is set up and ready to go!
+    

+      Now you can do a little more configuring of it, if you like. #
+      Perhaps enter a better description than the automatically generated one.
+    $if istransfer
+      

+        This repository is currently in the transfer group. That's the #
+        right choice if you'll use it to shuttle data back and forth #
+        between other repositories. Otherwise, pick one of the other groups.
   

     

       

@@ -11,3 +22,7 @@
             Save Changes
           
             Cancel
+  $if new
+    

+      In a hurry? Feel free to skip this step! You can always come back #
+      and configure this repository later.
diff --git a/templates/configurators/intro.hamlet b/templates/configurators/intro.hamlet
--- a/templates/configurators/intro.hamlet
+++ b/templates/configurators/intro.hamlet
@@ -3,18 +3,14 @@
    

       git-annex is watching over your files in #{reldir}
     

-      It will automatically notice changes, and keep files in sync between #
+      It will automatically notice changes, and keep files in sync #
       $if notenough
-        repositories on your devices ...
+        with repositories elsewhere ...
         

           But no other repositories are set up yet.
         Add another repository
       $else
-        $if barelyenough
-          #{numrepos}
-        $else
-          #{numrepos}
-        \ repositories and devices:
+        \ with these repositories:
         
             $forall (num, name, _) <- repolist
diff --git a/templates/configurators/repositories.hamlet b/templates/configurators/repositories.hamlet
--- a/templates/configurators/repositories.hamlet
+++ b/templates/configurators/repositories.hamlet
@@ -3,23 +3,28 @@
     Your repositories
   

           

-      $forall (num, name, setuprepo) <- repolist
+      $forall (num, name, actions) <- repolist
         

     

           
             #{num}
           
-            $if needsEnabled setuprepo
-              #{name}
+            #{name}
+          
+            $if needsEnabled actions
+              
+                 not enabled
             $else
-              #{name}
+              
+                $if notSyncing actions
+                   syncing paused
+                $else
+                   syncing enabled
           
-            $if needsEnabled setuprepo
-              not enabled here #
-              → #
-              
+            $if needsEnabled actions
+              
                 enable
             $else
-              
+              
                 configure
   

     

diff --git a/templates/documentation/about.hamlet b/templates/documentation/about.hamlet
--- a/templates/documentation/about.hamlet
+++ b/templates/documentation/about.hamlet
@@ -3,7 +3,7 @@
     git-annex watches over your files
   

     It will automatically notice changes, and keep files in sync between #
-    repositories and devices.
+    here and repositories elsewhere.
   

     For full details, see #
     the git-annex website.
diff --git a/test.hs b/test.hs
--- a/test.hs
+++ b/test.hs
@@ -14,7 +14,6 @@
 import System.Posix.Directory (changeWorkingDirectory)
 import System.Posix.Files
 import System.Posix.Env
-import System.Posix.Process
 import Control.Exception.Extensible
 import qualified Data.Map as M
 import System.IO.HVFS (SystemFS(..))
@@ -48,6 +47,7 @@
 import qualified Build.SysConfig
 import qualified Utility.Format
 import qualified Utility.Verifiable
+import qualified Utility.Process
 
 -- for quickcheck
 instance Arbitrary Types.Key.Key where
@@ -696,20 +696,10 @@
 {- Runs git-annex and returns its output. -}
 git_annex_output :: String -> [String] -> IO String
 git_annex_output command params = do
-	(frompipe, topipe) <- createPipe
-	pid <- forkProcess $ do
-		_ <- dupTo topipe stdOutput
-		closeFd frompipe
-		_ <- git_annex command params
-		exitSuccess
+	got <- Utility.Process.readProcess "git-annex" (command:params)
 	-- XXX since the above is a separate process, code coverage stats are
 	-- not gathered for things run in it.
-	closeFd topipe
-	fromh <- fdToHandle frompipe
-	got <- hGetContentsStrict fromh
-	hClose fromh
-	_ <- getProcessStatus True False pid
-	-- XXX hack Run same command again, to get code coverage.
+	-- Run same command again, to get code coverage.
 	_ <- git_annex command params
 	return got
 
@@ -877,8 +867,9 @@
 
 prepare :: IO ()
 prepare = do
-	-- While PATH is mostly avoided, the commit hook does run it. Make
-	-- sure that the just-built git annex is used.
+	-- While PATH is mostly avoided, the commit hook does run it,
+	-- and so does git_annex_output. Make sure that the just-built
+	-- git annex is used.
 	cwd <- getCurrentDirectory
 	p <- getEnvDefault  "PATH" ""
 	setEnv "PATH" (cwd ++ ":" ++ p) True