wire up scan and transfer to newly added removable drive

remote setup still todo

Assistant.hs

@@ -155,7 +155,7 @@ startAssistant assistant daemonize webappwaiter = do
 			mapM_ startthread
 				[ watch $ commitThread st changechan commitchan transferqueue dstatus
 #ifdef WITH_WEBAPP
-				, assist $ webAppThread (Just st) dstatus transferqueue Nothing webappwaiter
+				, assist $ webAppThread (Just st) dstatus scanremotes transferqueue Nothing webappwaiter
 #endif
 				, assist $ pushThread st dstatus commitchan pushmap
 				, assist $ pushRetryThread st dstatus pushmap

Assistant/Threads/MountWatcher.hs

@@ -154,13 +154,14 @@ pollingThread st dstatus scanremotes = go =<< currentMountPoints
 			go nowmounted
 
 handleMounts :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> MountPoints -> MountPoints -> IO ()
-handleMounts st dstatus scanremotes wasmounted nowmounted = mapM_ (handleMount st dstatus scanremotes) $
-	S.toList $ newMountPoints wasmounted nowmounted
+handleMounts st dstatus scanremotes wasmounted nowmounted =
+	mapM_ (handleMount st dstatus scanremotes . mnt_dir) $
+		S.toList $ newMountPoints wasmounted nowmounted
 
-handleMount :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> Mntent -> IO ()
-handleMount st dstatus scanremotes mntent = do
+handleMount :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> FilePath -> IO ()
+handleMount st dstatus scanremotes dir = do
 	debug thisThread ["detected mount of", dir]
-	rs <- remotesUnder st dstatus mntent
+	rs <- remotesUnder st dstatus dir
 	unless (null rs) $ do
 		branch <- runThreadState st $ Command.Sync.currentBranch
 		let nonspecial = filter (Git.repoIsLocal . Remote.repo) rs
@@ -171,8 +172,6 @@ handleMount st dstatus scanremotes mntent = do
 				now <- getCurrentTime	
 				pushToRemotes thisThread now st Nothing nonspecial
 		addScanRemotes scanremotes rs
-	where
-		dir = mnt_dir mntent
 
 {- Finds remotes located underneath the mount point.
  -
@@ -182,8 +181,8 @@ handleMount st dstatus scanremotes mntent = do
  - at startup time, or may have changed (it could even be a different
  - repository at the same remote location..)
  -}
-remotesUnder :: ThreadState -> DaemonStatusHandle -> Mntent -> IO [Remote]
-remotesUnder st dstatus mntent = runThreadState st $ do
+remotesUnder :: ThreadState -> DaemonStatusHandle -> FilePath -> IO [Remote]
+remotesUnder st dstatus dir = runThreadState st $ do
 	repotop <- fromRepo Git.repoPath
 	rs <- remoteList
 	pairs <- mapM (checkremote repotop) rs
@@ -194,7 +193,7 @@ remotesUnder st dstatus mntent = runThreadState st $ do
 	return $ map snd $ filter fst pairs
 	where
 		checkremote repotop r = case Remote.path r of
-			Just p | under mntent (absPathFrom repotop p) ->
+			Just p | dirContains dir (absPathFrom repotop p) ->
 				(,) <$> pure True <*> updateremote r
 			_ -> return (False, r)
 		updateremote r = do
@@ -214,7 +213,3 @@ currentMountPoints = S.fromList <$> getMounts
 
 newMountPoints :: MountPoints -> MountPoints -> MountPoints
 newMountPoints old new = S.difference new old
-
-{- Checks if a mount point contains a path. The path must be absolute. -}
-under :: Mntent -> FilePath -> Bool
-under = dirContains . mnt_dir

Assistant/Threads/WebApp.hs

@@ -19,6 +19,7 @@ import Assistant.WebApp.Configurators
 import Assistant.WebApp.Documentation
 import Assistant.ThreadedMonad
 import Assistant.DaemonStatus
+import Assistant.ScanRemotes
 import Assistant.TransferQueue
 import Utility.WebApp
 import Utility.FileMode
@@ -40,14 +41,16 @@ type Url = String
 webAppThread 
 	:: (Maybe ThreadState) 
 	-> DaemonStatusHandle
+	-> ScanRemoteMap
 	-> TransferQueue
 	-> Maybe (IO String)
 	-> Maybe (Url -> FilePath -> IO ())
 	-> IO ()
-webAppThread mst dstatus transferqueue postfirstrun onstartup = do
+webAppThread mst dstatus scanremotes transferqueue postfirstrun onstartup = do
 	webapp <- WebApp
 		<$> pure mst
 		<*> pure dstatus
+		<*> pure scanremotes
 		<*> pure transferqueue
 		<*> (pack <$> genRandomToken)
 		<*> getreldir mst

Assistant/WebApp.hs

@@ -13,6 +13,7 @@ module Assistant.WebApp where
 import Assistant.Common
 import Assistant.ThreadedMonad
 import Assistant.DaemonStatus
+import Assistant.ScanRemotes
 import Assistant.TransferQueue
 import Assistant.Alert hiding (Widget)
 import Utility.NotificationBroadcaster
@@ -32,6 +33,7 @@ mkYesodData "WebApp" $(parseRoutesFile "Assistant/WebApp/routes")
 data WebApp = WebApp
 	{ threadState :: Maybe ThreadState
 	, daemonStatus :: DaemonStatusHandle
+	, scanRemotes :: ScanRemoteMap
 	, transferQueue :: TransferQueue
 	, secretToken :: Text
 	, relDir :: Maybe FilePath

Assistant/WebApp/Configurators.hs

@@ -12,6 +12,7 @@ module Assistant.WebApp.Configurators where
 import Assistant.Common
 import Assistant.WebApp
 import Assistant.WebApp.SideBar
+import Assistant.Threads.MountWatcher (handleMount)
 import Utility.Yesod
 import qualified Remote
 import Logs.Web (webUUID)
@@ -32,7 +33,6 @@ import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Char
 import System.Posix.Directory
-import System.Posix.User
 import qualified Control.Exception as E
 
 {- The main configuration screen. -}
@@ -199,7 +199,7 @@ selectDriveForm drives def = renderBootstrap $ RemovableDrive
 					, "free)"
 					]
 
-{- Making the first repository, when starting the webapp for the first time. -}
+{- Adding a removable drive. -}
 getAddDriveR :: Handler RepHtml
 getAddDriveR = bootstrap (Just Config) $ do
 	sideBarDisplay
@@ -211,50 +211,38 @@ getAddDriveR = bootstrap (Just Config) $ do
 		selectDriveForm (sort writabledrives) Nothing
 	case res of
 		FormSuccess (RemovableDrive { mountPoint = d }) -> lift $ do
-			liftIO $ go $ T.unpack d </> "annex"
+			webapp <- getYesod
+			liftIO $ go webapp $ T.unpack d </> "annex"
 			setMessage $ toHtml $ T.unwords ["Added", d]
 			redirect ListRepositoriesR
 		_ -> do
 			let authtoken = webAppFormAuthToken
 			$(widgetFile "configurators/adddrive")
 	where
-		{- There may already be a git-annex repo on the drive.
-		 - If so, avoid re-initualizing it; this will be the 
-		 - case if a user is adding the same removable drive
-		 - to several computers.
-		 -
-		 - Some drives will have FAT or another horrible filesystem
-		 - that does not support symlinks; make a bare repo on those.
-		 -
-		 - Use the basename of the mount point, along with the
-		 - username (but without the hostname as this repo
-		 - travels!), as the repo description, and use the basename
-		 - of the mount point as the git remote name.
-		 -}
-		go dir = do
+		go webapp dir = do
 			r <- E.try getannex :: IO (Either E.SomeException Annex.AnnexState)
-			state <- case r of
-				Right state -> return state
+			case r of
+				Right _ -> noop
 				Left _e -> do
 					createDirectoryIfMissing True dir
 					bare <- not <$> canMakeSymlink dir
 					makeRepo dir bare
-					getannex
-			desc <- getdesc
-			Annex.eval state $
-				unlessM isInitialized $
-					initialize $ Just desc
+			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. -}
+			handleMount
+				(fromJust $ threadState webapp)
+				(daemonStatus webapp)
+				(scanRemotes webapp)
+				dir
 			where
 				getannex = Annex.new =<< Git.Construct.fromAbsPath dir
 				remotename = takeFileName dir
-				getdesc = do
-					username <- userName <$>
-			                        (getUserEntryForID =<< getEffectiveUserID)
-					return $ concat
-						[ username
-						, ":"
-						, remotename
-						]
 
 {- List of removable drives. -}
 driveList :: IO [RemovableDrive]
@@ -265,12 +253,12 @@ driveList = mapM (gen . mnt_dir) =<< filter sane <$> getMounts
 			<*> pure (T.pack dir)
 		-- filter out some things that are surely not removable drives
 		sane Mntent { mnt_dir = dir, mnt_fsname = dev }
-			-- We want real disks like /dev/foo, not
-			-- dummy mount points like proc or tmpfs or
-			-- gvfs-fuse-daemon
+			{- We want real disks like /dev/foo, not
+			 - dummy mount points like proc or tmpfs or
+			 - gvfs-fuse-daemon. -}
 			| not ('/' `elem` dev) = False
-			-- Just in case: These mount points are surely not
-			-- removable disks.
+			{- Just in case: These mount points are surely not
+			 - removable disks. -}
 			| dir == "/" = False
 			| dir == "/tmp" = False
 			| dir == "/run/shm" = False
@@ -305,9 +293,10 @@ makeRepo path bare = do
 {- Initializes a git-annex repository in a directory with a description. -}
 initRepo :: FilePath -> Maybe String -> IO ()
 initRepo path desc = do
-	g <- Git.Config.read =<< Git.Construct.fromPath path
-	state <- Annex.new g
-	Annex.eval state $ initialize desc
+	state <- Annex.new =<< Git.Config.read =<< Git.Construct.fromPath path
+	Annex.eval state $ 
+		unlessM isInitialized $
+			initialize desc
 
 {- Adds a directory to the autostart file. -}
 addAutoStart :: FilePath -> IO ()

Command/WebApp.hs

@@ -11,6 +11,7 @@ import Common.Annex
 import Command
 import Assistant
 import Assistant.DaemonStatus
+import Assistant.ScanRemotes
 import Assistant.TransferQueue
 import Assistant.Threads.WebApp
 import Utility.WebApp
@@ -83,10 +84,12 @@ autoStart autostartfile = do
 firstRun :: IO ()
 firstRun = do
 	dstatus <- atomically . newTMVar =<< newDaemonStatus
+	scanremotes <- newScanRemoteMap
 	transferqueue <- newTransferQueue
 	v <- newEmptyMVar
 	let callback a = Just $ a v
-	webAppThread Nothing dstatus transferqueue (callback signaler) (callback mainthread)
+	webAppThread Nothing dstatus scanremotes transferqueue
+		(callback signaler) (callback mainthread)
 	where
 		signaler v = do
 			putMVar v ""