adding removable drive repos now basically works

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
 

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 ()

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)
 

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