adding removable drive repos now basically works

2 files changed, 60 insertions, 31 deletions

diff --git a/Assistant/Threads/MountWatcher.hs b/Assistant/Threads/MountWatcher.hs
index 9a3396285..51c7590ea 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 dd6eb39c2..f345563e7 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
+				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
-				getannex = Annex.new =<< Git.Construct.fromAbsPath dir
-				remotename = takeFileName dir
+				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 ()