split out local repo configurators

4 files changed, 365 insertions, 296 deletions

diff --git a/Assistant/WebApp/Configurators.hs b/Assistant/WebApp/Configurators.hs
index ad29459a9..94c84c03a 100644
--- a/Assistant/WebApp/Configurators.hs
+++ b/Assistant/WebApp/Configurators.hs
@@ -13,31 +13,15 @@ import Assistant.Common
 import Assistant.WebApp
 import Assistant.WebApp.SideBar
 import Assistant.DaemonStatus
-import Assistant.Threads.MountWatcher (handleMount)
+import Assistant.WebApp.Configurators.Local
+import Assistant.WebApp.Configurators.Ssh
 import Utility.Yesod
 import qualified Remote
 import qualified Types.Remote as Remote
-import Remote.List
 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)
-import qualified Data.Text as T
-import Data.Char
-import System.Posix.Directory
-import qualified Control.Exception as E
 
 {- The main configuration screen. -}
 getConfigR :: Handler RepHtml
@@ -83,281 +67,3 @@ introDisplay ident = do
 	lift $ modifyWebAppState $ \s -> s { showIntro = False }
 	where
 		enough = 2
-
-data RepositoryPath = RepositoryPath Text
-	deriving Show
-
-{- Custom field display for a RepositoryPath, with an icon etc.
- -
- - Validates that the path entered is not empty, and is a safe value
- - to use as a repository. -}
-repositoryPathField :: forall sub. Bool -> Field sub WebApp Text
-repositoryPathField autofocus = Field { fieldParse = parse, fieldView = view }
-	where
-		view idAttr nameAttr attrs val isReq =
-			[whamlet|<input type="text" *{attrs} id="#{idAttr}" name="#{nameAttr}" :isReq:required :autofocus:autofocus value="#{either id id val}">|]
-
-		parse [path]
-			| T.null path = nopath
-			| otherwise = liftIO $ checkRepositoryPath path
-		parse [] = return $ Right Nothing
-		parse _ = nopath
-
-		nopath = return $ Left "Enter a location for the repository"
-
-{- As well as checking the path for a lot of silly things, tilde is
- - expanded in the returned path. -}
-checkRepositoryPath :: Text -> IO (Either (SomeMessage WebApp) (Maybe Text))
-checkRepositoryPath p = do
-	home <- myHomeDir
-	let basepath = expandTilde home $ T.unpack p
-	path <- absPath basepath
-	let parent = parentDir path
-	problems <- catMaybes <$> mapM runcheck
-		[ (return $ path == "/", "Enter the full path to use for the repository.")
-		, (return $ all isSpace basepath, "A blank path? Seems unlikely.")
-		, (doesFileExist path, "A file already exists with that name.")
-		, (return $ path == home, "Sorry, using git-annex for your whole home directory is not currently supported.")
-		, (not <$> doesDirectoryExist parent, "Parent directory does not exist.")
-		, (not <$> canWrite path, "Cannot write a repository there.")
-		, (not <$> canMakeSymlink path, "That directory is on a filesystem that does not support symlinks. Try a different location.")
-		]
-	return $ 
-		case headMaybe problems of
-			Nothing -> Right $ Just $ T.pack basepath
-			Just prob -> Left prob
-	where
-		runcheck (chk, msg) = ifM (chk)
-			( return $ Just msg
-			, return Nothing
-			)
-		expandTilde home ('~':'/':path) = home </> path
-		expandTilde _ path = path
-		
-
-{- On first run, if run in the home directory, default to putting it in
- - ~/Desktop/annex, when a Desktop directory exists, and ~/annex otherwise.
- -
- - If run in another directory, the user probably wants to put it there. -}
-defaultRepositoryPath :: Bool -> IO FilePath
-defaultRepositoryPath firstrun = do
-	cwd <- liftIO $ getCurrentDirectory
-	home <- myHomeDir
-	if home == cwd && firstrun
-		then do
-			desktop <- userDesktopDir
-			ifM (doesDirectoryExist desktop)
-				(relHome (desktop </> "annex"), return "~/annex")
-		else return cwd
-
-localRepositoryForm :: Form RepositoryPath
-localRepositoryForm msg = do
-	path <- T.pack . addTrailingPathSeparator
-		<$> (liftIO . defaultRepositoryPath =<< lift inFirstRun)
-	(pathRes, pathView) <- mreq (repositoryPathField True) "" (Just path)
-	let (err, errmsg) = case pathRes of
-		FormMissing -> (False, "")
-		FormFailure l -> (True, concat $ map T.unpack l)
-		FormSuccess _ -> (False, "")
-	let form = do
-		webAppFormAuthToken
-		$(widgetFile "configurators/localrepositoryform")
-	return (RepositoryPath <$> pathRes, form)
-
-{- Making the first repository, when starting the webapp for the first time. -}
-getFirstRepositoryR :: Handler RepHtml
-getFirstRepositoryR = bootstrap (Just Config) $ do
-	sideBarDisplay
-	setTitle "Getting started"
-	((res, form), enctype) <- lift $ runFormGet localRepositoryForm
-	case res of
-		FormSuccess (RepositoryPath p) -> lift $
-			startFullAssistant $ T.unpack p
-		_ -> $(widgetFile "configurators/firstrepository")
-
-data RemovableDrive = RemovableDrive 
-	{ diskFree :: Maybe Integer
-	, mountPoint :: Text
-	}
-	deriving (Show, Eq, Ord)
-
-selectDriveForm :: [RemovableDrive] -> Maybe RemovableDrive -> Form RemovableDrive
-selectDriveForm drives def = renderBootstrap $ RemovableDrive
-	<$> pure Nothing
-	<*> areq (selectFieldList pairs) "Select drive:" (mountPoint <$> def)
-	where
-		pairs = zip (map describe drives) (map mountPoint drives)
-		describe drive = case diskFree drive of
-			Nothing -> mountPoint drive
-			Just free -> 
-				let sz = roughSize storageUnits True free
-				in T.unwords
-					[ mountPoint drive
-					, T.concat ["(", T.pack sz]
-					, "free)"
-					]
-
-{- Adding a removable drive. -}
-getAddDriveR :: Handler RepHtml
-getAddDriveR = bootstrap (Just Config) $ do
-	sideBarDisplay
-	setTitle "Add a removable drive"
-	removabledrives <- liftIO $ driveList
-	writabledrives <- liftIO $
-		filterM (canWrite . T.unpack . mountPoint) removabledrives
-	((res, form), enctype) <- lift $ runFormGet $
-		selectDriveForm (sort writabledrives) Nothing
-	case res of
-		FormSuccess (RemovableDrive { mountPoint = d }) -> lift $ do
-			go $ T.unpack d
-			setMessage $ toHtml $ T.unwords ["Added", d]
-			redirect RepositoriesR
-		_ -> do
-			let authtoken = webAppFormAuthToken
-			$(widgetFile "configurators/adddrive")
-	where
-		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
-		{- 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
-				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]
-driveList = mapM (gen . mnt_dir) =<< filter sane <$> getMounts
-	where
-		gen dir = RemovableDrive
-			<$> getDiskFree dir
-			<*> 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. -}
-			| not ('/' `elem` dev) = False
-			{- Just in case: These mount points are surely not
-			 - removable disks. -}
-			| dir == "/" = False
-			| dir == "/tmp" = False
-			| dir == "/run/shm" = False
-			| dir == "/run/lock" = False
-			| otherwise = True
-
-{- Bootstraps from first run mode to a fully running assistant in a
- - repository, by running the postFirstRun callback, which returns the
- - url to the new webapp. -}
-startFullAssistant :: FilePath -> Handler ()
-startFullAssistant path = do
-	webapp <- getYesod
-	url <- liftIO $ do
-		makeRepo path False
-		initRepo path Nothing
-		addAutoStart path
-		changeWorkingDirectory path
-		fromJust $ postFirstRun webapp
-	redirect $ T.pack url
-
-{- Makes a new git-annex repository. -}
-makeRepo :: FilePath -> Bool -> IO ()
-makeRepo path bare = do
-	unlessM (boolSystem "git" params) $
-		error "git init failed!"
-	where
-		baseparams = [Param "init", Param "--quiet"]
-		params
-			| 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 dir desc = inDir dir $
-	unlessM isInitialized $
-		initialize desc
-
-{- Adds a directory to the autostart file. -}
-addAutoStart :: FilePath -> IO ()
-addAutoStart path = do
-	autostart <- autoStartFile
-	createDirectoryIfMissing True (parentDir autostart)
-	appendFile autostart $ path ++ "\n"
-
-{- Checks if the user can write to a directory.
- -
- - The directory may be in the process of being created; if so
- - the parent directory is checked instead. -}
-canWrite :: FilePath -> IO Bool		
-canWrite dir = do
-	tocheck <- ifM (doesDirectoryExist dir)
-		(return dir, return $ parentDir dir)
-	catchBoolIO $ fileAccess tocheck False True False
-
-{- Checks if a directory is on a filesystem that supports symlinks. -}
-canMakeSymlink :: FilePath -> IO Bool
-canMakeSymlink dir = ifM (doesDirectoryExist dir)
-	( catchBoolIO $ test dir
-	, canMakeSymlink (parentDir dir)
-	)
-	where
-		test d = do
-			let link = d </> "delete.me"
-			createSymbolicLink link link
-			removeLink link
-			return True
diff --git a/Assistant/WebApp/Configurators/Local.hs b/Assistant/WebApp/Configurators/Local.hs
new file mode 100644
index 000000000..04345f731
--- /dev/null
+++ b/Assistant/WebApp/Configurators/Local.hs
@@ -0,0 +1,318 @@
+{- git-annex assistant webapp configurators for making local repositories
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
+
+module Assistant.WebApp.Configurators.Local where
+
+import Assistant.Common
+import Assistant.WebApp
+import Assistant.WebApp.SideBar
+import Assistant.DaemonStatus
+import Assistant.Threads.MountWatcher (handleMount)
+import Utility.Yesod
+import qualified Remote
+import qualified Types.Remote as Remote
+import Remote.List
+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)
+import qualified Data.Text as T
+import Data.Char
+import System.Posix.Directory
+import qualified Control.Exception as E
+
+data RepositoryPath = RepositoryPath Text
+	deriving Show
+
+{- Custom field display for a RepositoryPath, with an icon etc.
+ -
+ - Validates that the path entered is not empty, and is a safe value
+ - to use as a repository. -}
+repositoryPathField :: forall sub. Bool -> Field sub WebApp Text
+repositoryPathField autofocus = Field { fieldParse = parse, fieldView = view }
+	where
+		view idAttr nameAttr attrs val isReq =
+			[whamlet|<input type="text" *{attrs} id="#{idAttr}" name="#{nameAttr}" :isReq:required :autofocus:autofocus value="#{either id id val}">|]
+
+		parse [path]
+			| T.null path = nopath
+			| otherwise = liftIO $ checkRepositoryPath path
+		parse [] = return $ Right Nothing
+		parse _ = nopath
+
+		nopath = return $ Left "Enter a location for the repository"
+
+{- As well as checking the path for a lot of silly things, tilde is
+ - expanded in the returned path. -}
+checkRepositoryPath :: Text -> IO (Either (SomeMessage WebApp) (Maybe Text))
+checkRepositoryPath p = do
+	home <- myHomeDir
+	let basepath = expandTilde home $ T.unpack p
+	path <- absPath basepath
+	let parent = parentDir path
+	problems <- catMaybes <$> mapM runcheck
+		[ (return $ path == "/", "Enter the full path to use for the repository.")
+		, (return $ all isSpace basepath, "A blank path? Seems unlikely.")
+		, (doesFileExist path, "A file already exists with that name.")
+		, (return $ path == home, "Sorry, using git-annex for your whole home directory is not currently supported.")
+		, (not <$> doesDirectoryExist parent, "Parent directory does not exist.")
+		, (not <$> canWrite path, "Cannot write a repository there.")
+		, (not <$> canMakeSymlink path, "That directory is on a filesystem that does not support symlinks. Try a different location.")
+		]
+	return $ 
+		case headMaybe problems of
+			Nothing -> Right $ Just $ T.pack basepath
+			Just prob -> Left prob
+	where
+		runcheck (chk, msg) = ifM (chk)
+			( return $ Just msg
+			, return Nothing
+			)
+		expandTilde home ('~':'/':path) = home </> path
+		expandTilde _ path = path
+		
+
+{- On first run, if run in the home directory, default to putting it in
+ - ~/Desktop/annex, when a Desktop directory exists, and ~/annex otherwise.
+ -
+ - If run in another directory, the user probably wants to put it there. -}
+defaultRepositoryPath :: Bool -> IO FilePath
+defaultRepositoryPath firstrun = do
+	cwd <- liftIO $ getCurrentDirectory
+	home <- myHomeDir
+	if home == cwd && firstrun
+		then do
+			desktop <- userDesktopDir
+			ifM (doesDirectoryExist desktop)
+				(relHome (desktop </> "annex"), return "~/annex")
+		else return cwd
+
+localRepositoryForm :: Form RepositoryPath
+localRepositoryForm msg = do
+	path <- T.pack . addTrailingPathSeparator
+		<$> (liftIO . defaultRepositoryPath =<< lift inFirstRun)
+	(pathRes, pathView) <- mreq (repositoryPathField True) "" (Just path)
+	let (err, errmsg) = case pathRes of
+		FormMissing -> (False, "")
+		FormFailure l -> (True, concat $ map T.unpack l)
+		FormSuccess _ -> (False, "")
+	let form = do
+		webAppFormAuthToken
+		$(widgetFile "configurators/localrepositoryform")
+	return (RepositoryPath <$> pathRes, form)
+
+{- Making the first repository, when starting the webapp for the first time. -}
+getFirstRepositoryR :: Handler RepHtml
+getFirstRepositoryR = bootstrap (Just Config) $ do
+	sideBarDisplay
+	setTitle "Getting started"
+	((res, form), enctype) <- lift $ runFormGet localRepositoryForm
+	case res of
+		FormSuccess (RepositoryPath p) -> lift $
+			startFullAssistant $ T.unpack p
+		_ -> $(widgetFile "configurators/firstrepository")
+
+data RemovableDrive = RemovableDrive 
+	{ diskFree :: Maybe Integer
+	, mountPoint :: Text
+	}
+	deriving (Show, Eq, Ord)
+
+selectDriveForm :: [RemovableDrive] -> Maybe RemovableDrive -> Form RemovableDrive
+selectDriveForm drives def = renderBootstrap $ RemovableDrive
+	<$> pure Nothing
+	<*> areq (selectFieldList pairs) "Select drive:" (mountPoint <$> def)
+	where
+		pairs = zip (map describe drives) (map mountPoint drives)
+		describe drive = case diskFree drive of
+			Nothing -> mountPoint drive
+			Just free -> 
+				let sz = roughSize storageUnits True free
+				in T.unwords
+					[ mountPoint drive
+					, T.concat ["(", T.pack sz]
+					, "free)"
+					]
+
+{- Adding a removable drive. -}
+getAddDriveR :: Handler RepHtml
+getAddDriveR = bootstrap (Just Config) $ do
+	sideBarDisplay
+	setTitle "Add a removable drive"
+	removabledrives <- liftIO $ driveList
+	writabledrives <- liftIO $
+		filterM (canWrite . T.unpack . mountPoint) removabledrives
+	((res, form), enctype) <- lift $ runFormGet $
+		selectDriveForm (sort writabledrives) Nothing
+	case res of
+		FormSuccess (RemovableDrive { mountPoint = d }) -> lift $ do
+			go $ T.unpack d
+			setMessage $ toHtml $ T.unwords ["Added", d]
+			redirect RepositoriesR
+		_ -> do
+			let authtoken = webAppFormAuthToken
+			$(widgetFile "configurators/adddrive")
+	where
+		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
+		{- 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
+				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]
+driveList = mapM (gen . mnt_dir) =<< filter sane <$> getMounts
+	where
+		gen dir = RemovableDrive
+			<$> getDiskFree dir
+			<*> 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. -}
+			| not ('/' `elem` dev) = False
+			{- Just in case: These mount points are surely not
+			 - removable disks. -}
+			| dir == "/" = False
+			| dir == "/tmp" = False
+			| dir == "/run/shm" = False
+			| dir == "/run/lock" = False
+			| otherwise = True
+
+{- Bootstraps from first run mode to a fully running assistant in a
+ - repository, by running the postFirstRun callback, which returns the
+ - url to the new webapp. -}
+startFullAssistant :: FilePath -> Handler ()
+startFullAssistant path = do
+	webapp <- getYesod
+	url <- liftIO $ do
+		makeRepo path False
+		initRepo path Nothing
+		addAutoStart path
+		changeWorkingDirectory path
+		fromJust $ postFirstRun webapp
+	redirect $ T.pack url
+
+{- Makes a new git-annex repository. -}
+makeRepo :: FilePath -> Bool -> IO ()
+makeRepo path bare = do
+	unlessM (boolSystem "git" params) $
+		error "git init failed!"
+	where
+		baseparams = [Param "init", Param "--quiet"]
+		params
+			| 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 dir desc = inDir dir $
+	unlessM isInitialized $
+		initialize desc
+
+{- Adds a directory to the autostart file. -}
+addAutoStart :: FilePath -> IO ()
+addAutoStart path = do
+	autostart <- autoStartFile
+	createDirectoryIfMissing True (parentDir autostart)
+	appendFile autostart $ path ++ "\n"
+
+{- Checks if the user can write to a directory.
+ -
+ - The directory may be in the process of being created; if so
+ - the parent directory is checked instead. -}
+canWrite :: FilePath -> IO Bool		
+canWrite dir = do
+	tocheck <- ifM (doesDirectoryExist dir)
+		(return dir, return $ parentDir dir)
+	catchBoolIO $ fileAccess tocheck False True False
+
+{- Checks if a directory is on a filesystem that supports symlinks. -}
+canMakeSymlink :: FilePath -> IO Bool
+canMakeSymlink dir = ifM (doesDirectoryExist dir)
+	( catchBoolIO $ test dir
+	, canMakeSymlink (parentDir dir)
+	)
+	where
+		test d = do
+			let link = d </> "delete.me"
+			createSymbolicLink link link
+			removeLink link
+			return True
diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs
new file mode 100644
index 000000000..912bc7866
--- /dev/null
+++ b/Assistant/WebApp/Configurators/Ssh.hs
@@ -0,0 +1,44 @@
+{- git-annex assistant webapp configurator for ssh-based remotes
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
+
+module Assistant.WebApp.Configurators.Ssh where
+
+import Assistant.Common
+import Assistant.WebApp
+import Assistant.WebApp.SideBar
+import Assistant.DaemonStatus
+import Assistant.Threads.MountWatcher (handleMount)
+import Utility.Yesod
+import qualified Remote
+import qualified Types.Remote as Remote
+import Remote.List
+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)
+import qualified Data.Text as T
+import Data.Char
+import System.Posix.Directory
+import qualified Control.Exception as E
+
+getAddRemoteServerR :: Handler RepHtml
+getAddRemoteServerR = bootstrap (Just Config) $ do
+	error "TODO"
diff --git a/Assistant/WebApp/routes b/Assistant/WebApp/routes
index e3e7daf87..72b76c33d 100644
--- a/Assistant/WebApp/routes
+++ b/Assistant/WebApp/routes
@@ -6,6 +6,7 @@
 /config ConfigR GET
 /config/repository RepositoriesR GET
 /config/repository/add/drive AddDriveR GET
+/config/repository/add/remoteserver AddRemoteServerR GET
 /config/repository/first FirstRepositoryR GET
 
 /transfers/#NotificationId TransfersR GET