From cb0f435d948a597429db5e51f2b3d2b15294090f Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 5 Aug 2012 14:49:47 -0400 Subject: [PATCH] adding removable drive repos now basically works --- Assistant/Threads/MountWatcher.hs | 13 +----- Assistant/WebApp/Configurators.hs | 78 +++++++++++++++++++++++-------- Init.hs | 9 +--- Remote/List.hs | 23 +++++++++ 4 files changed, 85 insertions(+), 38 deletions(-) diff --git a/Assistant/Threads/MountWatcher.hs b/Assistant/Threads/MountWatcher.hs index 9a33962859..51c7590ea7 100644 --- a/Assistant/Threads/MountWatcher.hs +++ b/Assistant/Threads/MountWatcher.hs @@ -22,10 +22,8 @@ import Utility.ThreadScheduler import Utility.Mounts import Remote.List import qualified Types.Remote as Remote -import qualified Remote.Git import qualified Command.Sync import Assistant.Threads.Merger -import Logs.Remote import Control.Concurrent import qualified Control.Exception as E @@ -194,17 +192,8 @@ remotesUnder st dstatus dir = runThreadState st $ do where checkremote repotop r = case Remote.path r of Just p | dirContains dir (absPathFrom repotop p) -> - (,) <$> pure True <*> updateremote r + (,) <$> pure True <*> updateRemote r _ -> return (False, r) - updateremote r = do - liftIO $ debug thisThread ["updating", show r] - m <- readRemoteLog - repo <- updaterepo $ Remote.repo r - remoteGen m (Remote.remotetype r) repo - updaterepo repo - | Git.repoIsLocal repo || Git.repoIsLocalUnknown repo = - Remote.Git.configRead repo - | otherwise = return repo type MountPoints = S.Set Mntent diff --git a/Assistant/WebApp/Configurators.hs b/Assistant/WebApp/Configurators.hs index dd6eb39c24..f345563e70 100644 --- a/Assistant/WebApp/Configurators.hs +++ b/Assistant/WebApp/Configurators.hs @@ -15,18 +15,22 @@ import Assistant.WebApp.SideBar import Assistant.Threads.MountWatcher (handleMount) import Utility.Yesod import qualified Remote +import Remote.List import Logs.Web (webUUID) import Logs.Trust import Annex.UUID (getUUID) import Init +import qualified Git import qualified Git.Construct import qualified Git.Config +import qualified Git.Command import qualified Annex import Locations.UserConfig import Utility.FreeDesktop import Utility.Mounts import Utility.DiskFree import Utility.DataUnits +import Utility.Network import Yesod import Data.Text (Text) @@ -211,38 +215,70 @@ getAddDriveR = bootstrap (Just Config) $ do selectDriveForm (sort writabledrives) Nothing case res of FormSuccess (RemovableDrive { mountPoint = d }) -> lift $ do - webapp <- getYesod - liftIO $ go webapp $ T.unpack d "annex" + go $ T.unpack d setMessage $ toHtml $ T.unwords ["Added", d] redirect ListRepositoriesR _ -> do let authtoken = webAppFormAuthToken $(widgetFile "configurators/adddrive") where - go webapp dir = do - r <- E.try getannex :: IO (Either E.SomeException Annex.AnnexState) + go mountpoint = do + liftIO $ makerepo dir + liftIO $ initRepo dir $ Just remotename + addremotes dir remotename + webapp <- getYesod + liftIO $ syncrepo dir webapp + where + dir = mountpoint "annex" + remotename = takeFileName mountpoint + {- The repo may already exist, when adding removable media + - that has already been used elsewhere. -} + makerepo dir = liftIO $ do + r <- E.try (inDir dir $ return True) :: IO (Either E.SomeException Bool) case r of Right _ -> noop Left _e -> do createDirectoryIfMissing True dir bare <- not <$> canMakeSymlink dir makeRepo dir bare - initRepo dir $ Just remotename - - -- TODO setup up git remotes - -- TODO add it to Annex.remotes - - {- Now synthesize a mount event of the new - - git repository. This will sync it, and queue - - file transfers. -} + {- Synthesize a mount event of the new git repository. + - This will sync it, and queue file transfers. -} + syncrepo dir webapp = handleMount (fromJust $ threadState webapp) (daemonStatus webapp) (scanRemotes webapp) dir + {- Each repository is made a remote of the other. -} + addremotes dir name = runAnnex () $ do + hostname <- maybe "host" id <$> liftIO getHostname + hostlocation <- fromRepo Git.repoLocation + void $ liftIO $ inDir dir $ + addremote hostname hostlocation + whenM (addremote name dir) $ + void $ remoteListRefresh + {- Adds a remote only if there is not already one with + - the location. -} + addremote name location = inRepo $ \r -> + if (null $ filter samelocation $ Git.remotes r) + then do + let name' = uniqueremotename r name (0 :: Int) + Git.Command.runBool "remote" + [Param "add", Param name', Param location] r + else return False where - getannex = Annex.new =<< Git.Construct.fromAbsPath dir - remotename = takeFileName dir + samelocation x = Git.repoLocation x == location + {- Generate an unused name for a remote, adding a number if + - necessary. -} + uniqueremotename r basename n + | null namecollision = name + | otherwise = uniqueremotename r basename (succ n) + where + namecollision = filter samename (Git.remotes r) + samename x = Git.remoteName x == Just name + name + | n == 0 = basename + | otherwise = basename ++ show n {- List of removable drives. -} driveList :: IO [RemovableDrive] @@ -290,13 +326,17 @@ makeRepo path bare = do | bare = baseparams ++ [Param "--bare", File path] | otherwise = baseparams ++ [File path] +{- Runs an action in the git-annex repository in the specified directory. -} +inDir :: FilePath -> Annex a -> IO a +inDir dir a = do + state <- Annex.new =<< Git.Config.read =<< Git.Construct.fromPath dir + Annex.eval state a + {- Initializes a git-annex repository in a directory with a description. -} initRepo :: FilePath -> Maybe String -> IO () -initRepo path desc = do - state <- Annex.new =<< Git.Config.read =<< Git.Construct.fromPath path - Annex.eval state $ - unlessM isInitialized $ - initialize desc +initRepo dir desc = inDir dir $ + unlessM isInitialized $ + initialize desc {- Adds a directory to the autostart file. -} addAutoStart :: FilePath -> IO () diff --git a/Init.hs b/Init.hs index 7e0f104053..ec85b7fe0d 100644 --- a/Init.hs +++ b/Init.hs @@ -14,6 +14,7 @@ module Init ( import Common.Annex import Utility.TempFile +import Utility.Network import qualified Git import qualified Annex.Branch import Logs.UUID @@ -25,18 +26,12 @@ import System.Posix.User genDescription :: Maybe String -> Annex String genDescription (Just d) = return d genDescription Nothing = do - hostname <- getHostname + hostname <- maybe "" id <$> liftIO getHostname let at = if null hostname then "" else "@" username <- clicketyclickety reldir <- liftIO . relHome =<< fromRepo Git.repoPath return $ concat [username, at, hostname, ":", reldir] where - {- Haskell lacks uname(2) bindings, except in the - - Bindings.Uname addon. Rather than depend on that, - - use uname -n when available. -} - getHostname = liftIO $ catchDefaultIO uname_node "" - uname_node = takeWhile (/= '\n') <$> - readProcess "uname" ["-n"] clicketyclickety = liftIO $ userName <$> (getUserEntryForID =<< getEffectiveUserID) diff --git a/Remote/List.hs b/Remote/List.hs index 4127cf24b0..3f37927440 100644 --- a/Remote/List.hs +++ b/Remote/List.hs @@ -19,6 +19,7 @@ import Annex.UUID import Config import Remote.Helper.Hooks import qualified Git +import qualified Git.Config import qualified Remote.Git #ifdef WITH_S3 @@ -58,12 +59,34 @@ remoteList = do where process m t = enumerate t >>= mapM (remoteGen m t) +{- Forces the remoteList to be re-generated, re-reading the git config. -} +remoteListRefresh :: Annex [Remote] +remoteListRefresh = do + newg <- inRepo Git.Config.reRead + Annex.changeState $ \s -> s + { Annex.remotes = [] + , Annex.repo = newg + } + remoteList + {- Generates a Remote. -} remoteGen :: (M.Map UUID RemoteConfig) -> RemoteType -> Git.Repo -> Annex Remote remoteGen m t r = do u <- getRepoUUID r addHooks =<< generate t r u (M.lookup u m) +{- Updates a local git Remote, re-reading its git config. -} +updateRemote :: Remote -> Annex Remote +updateRemote remote = do + m <- readRemoteLog + remote' <- updaterepo $ repo remote + remoteGen m (remotetype remote) remote' + where + updaterepo r + | Git.repoIsLocal r || Git.repoIsLocalUnknown r = + Remote.Git.configRead r + | otherwise = return r + {- All remotes that are not ignored. -} enabledRemoteList :: Annex [Remote] enabledRemoteList = filterM (repoNotIgnored . repo) =<< remoteList