pairing probably works now (untested)

3 files changed, 37 insertions, 167 deletions

diff --git a/Assistant/WebApp/Configurators/Local.hs b/Assistant/WebApp/Configurators/Local.hs
index 331130727..dd546881b 100644
--- a/Assistant/WebApp/Configurators/Local.hs
+++ b/Assistant/WebApp/Configurators/Local.hs
@@ -14,15 +14,12 @@ import Assistant.WebApp
 import Assistant.WebApp.Types
 import Assistant.WebApp.SideBar
 import Assistant.Sync
-import Assistant.DaemonStatus
+import Assistant.MakeRemote
 import Utility.Yesod
-import Remote.List
-import qualified Remote
 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
@@ -37,7 +34,6 @@ import qualified Data.Text as T
 import Data.Char
 import System.Posix.Directory
 import qualified Control.Exception as E
-import Control.Concurrent
 
 data RepositoryPath = RepositoryPath Text
 	deriving Show
@@ -198,61 +194,15 @@ getAddDriveR = bootstrap (Just Config) $ do
 				void $ makeGitRemote hostname hostlocation
 			addRemote $ makeGitRemote name dir
 
-{- Runs an action that returns a name of the remote, and finishes adding it. -}
-addRemote :: Annex String -> Annex Remote
-addRemote a = do
-	name <- a
-	void $ remoteListRefresh
-	maybe (error "failed to add remote") return =<< Remote.byName (Just name)
-
-{- Returns the name of the git remote it created. If there's already a
- - remote at the location, returns its name. -}
-makeGitRemote :: String -> String -> Annex String
-makeGitRemote basename location = makeRemote basename location $ \name ->
-	void $ inRepo $
-		Git.Command.runBool "remote"
-			[Param "add", Param name, Param location]
-
-{- If there's not already a remote at the location, adds it using the
- - action, which is passed the name of the remote to make.
- -
- - Returns the name of the remote. -}
-makeRemote :: String -> String -> (String -> Annex ()) -> Annex String
-makeRemote basename location a = do
-	r <- fromRepo id
-	if (null $ filter samelocation $ Git.remotes r)
-		then do
-			let name = uniqueRemoteName r basename 0
-			a name
-			return name
-		else return basename
-	where
-		samelocation x = Git.repoLocation x == location
-
-{- Generate an unused name for a remote, adding a number if
- - necessary. -}
-uniqueRemoteName :: Git.Repo -> String -> Int -> String
-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
-
 {- Start syncing a newly added remote, using a background thread. -}
 syncRemote :: Remote -> Handler ()
 syncRemote remote = do
 	webapp <- getYesod
-	runAnnex () $ updateKnownRemotes (daemonStatus webapp)
-	void $ liftIO $ forkIO $ do
-		reconnectRemotes "WebApp"
-			(fromJust $ threadState webapp)
-			(daemonStatus webapp)
-			(scanRemotes webapp)
-			[remote]
+	liftIO $ syncNewRemote
+		(fromJust $ threadState webapp)
+		(daemonStatus webapp)
+		(scanRemotes webapp)
+		remote
 
 {- List of removable drives. -}
 driveList :: IO [RemovableDrive]
diff --git a/Assistant/WebApp/Configurators/Pairing.hs b/Assistant/WebApp/Configurators/Pairing.hs
index 2e90eec36..4ff81c750 100644
--- a/Assistant/WebApp/Configurators/Pairing.hs
+++ b/Assistant/WebApp/Configurators/Pairing.hs
@@ -39,7 +39,6 @@ import Utility.Yesod
 import Assistant.Common
 import Assistant.Pairing.Network
 import Assistant.Ssh
-import qualified Assistant.WebApp.Configurators.Ssh as Ssh
 import Assistant.Alert
 import Assistant.DaemonStatus
 import Utility.Verifiable
@@ -60,9 +59,7 @@ import Control.Concurrent
 
 getStartPairR :: Handler RepHtml
 #ifdef WITH_PAIRING
-getStartPairR = do
-	keypair <- liftIO genSshKeyPair
-	promptSecret Nothing $ startPairing PairReq keypair noop
+getStartPairR = promptSecret Nothing $ startPairing PairReq noop
 #else
 getStartPairR = noPairing
 #endif
@@ -70,44 +67,19 @@ getStartPairR = noPairing
 getFinishPairR :: PairMsg -> Handler RepHtml
 #ifdef WITH_PAIRING
 getFinishPairR msg = promptSecret (Just msg) $ \_ secret -> do
-	keypair <- setup
-	startPairing PairAck keypair cleanup "" secret
+	setup
+	startPairing PairAck cleanup "" secret
 	where
 		pubkey = remoteSshPubKey $ pairMsgData msg
 		setup  = do
-			validateSshPubKey pubKey
+			liftIO $ validateSshPubKey pubkey
 			unlessM (liftIO $ makeAuthorizedKeys False pubkey) $
 				error "failed setting up ssh authorized keys"
-			keypair <- liftIO genSshKeyPair
-			sshdata <- liftIO $ pairMsgToSshData msg
-			sshdata' <- liftIO $ setupSshKeyPair keypair sshdata
-			void $ lift $ Ssh.makeSshWithKeyPair False sshdata' (Just keypair)
-			return keypair
 		cleanup = error "TODO clean up authorized keys and generated ssh key and remove git remote"
 #else
 getFinishPairR _ = noPairing
 #endif
 
-{- Mostly a straightforward conversion.  Except:
- -  * Determine the best hostname to use to contact the host.
- -  * Strip leading ~/ from the directory name.
- -}
-pairMsgToSshData :: PairMsg -> IO SshData
-pairMsgToSshData msg = do
-	let d = pairMsgData msg
-	hostname <- liftIO $ bestHostName d
-	let dir = case remoteDirectory d of
-		('~':'/':v) -> v
-		v -> v
-	return $ SshData
-		{ sshHostName = T.pack hostname
-		, sshUserName = Just (T.pack $ remoteUserName d)
-		, sshDirectory = T.pack dir
-		, sshRepoName = genSshRepoName besthostname dir
-		, needsPubKey = True
-		, rsyncOnly = False
-		}
-
 getInprogressPairR :: Text -> Handler RepHtml
 #ifdef WITH_PAIRING
 getInprogressPairR secret = pairPage $ do
@@ -127,27 +99,23 @@ getInprogressPairR _ = noPairing
  -
  - Redirects to the pairing in progress page.
  -}
-startPairing :: PairStage -> SshKeyPair -> IO () -> Text -> Secret -> Widget
-startPairing stage keypair oncancel displaysecret secret = do
+startPairing :: PairStage -> IO () -> Text -> Secret -> Widget
+startPairing stage oncancel displaysecret secret = do
+	keypair <- liftIO $ genSshKeyPair
 	dstatus <- daemonStatus <$> lift getYesod
 	urlrender <- lift getUrlRender
 	let homeurl = urlrender HomeR
-	sender <- mksender
+	pairdata <- PairData
+		<$> liftIO getHostname
+		<*> liftIO getUserName
+		<*> (fromJust . relDir <$> lift getYesod)
+		<*> pure (sshPubKey keypair)
 	liftIO $ do
-		pip <- PairingInProgress secret
-			<$> sendrequests sender dstatus homeurl
-			<*> pure keypair
-		oldpip <- modifyDaemonStatus dstatus $
-			\s -> (s { pairingInProgress = Just pip }, pairingInProgress s)
-		maybe noop stopold oldpip
+		let sender = multicastPairMsg Nothing secret stage pairdata
+		let pip = PairingInProgress secret Nothing keypair pairdata
+		startSending dstatus pip $ sendrequests sender dstatus homeurl
 	lift $ redirect $ InprogressPairR displaysecret
 	where
-		mksender = do
-			hostname <- liftIO getHostname
-			username <- liftIO getUserName
-			reldir <- fromJust . relDir <$> lift getYesod
-			return $ multicastPairMsg $ \addr -> PairMsg $ mkVerifiable
-				(stage, PairData hostname addr username reldir (sshPubKey keypair)) secret
 		{- Sends pairing messages until the thread is killed,
 		 - and shows an activity alert while doing it.
 		 -
@@ -156,7 +124,7 @@ startPairing stage keypair oncancel displaysecret secret = do
 		 - have been on a page specific to the in-process pairing
 		 - that just stopped, so can't go back there.
 		 -}
-		sendrequests sender dstatus homeurl = forkIO $ do
+		sendrequests sender dstatus homeurl = do
 			tid <- myThreadId
 			let selfdestruct = AlertButton
 				{ buttonLabel = "Cancel"
@@ -168,7 +136,6 @@ startPairing stage keypair oncancel displaysecret secret = do
 			alertDuring dstatus (pairingAlert selfdestruct) $ do
 				_ <- E.try sender :: IO (Either E.SomeException ())
 				return ()
-		stopold = killThread  . inProgressThreadId
 
 data InputSecret = InputSecret { secretText :: Maybe Text }
 
@@ -200,7 +167,7 @@ promptSecret msg cont = pairPage $ do
 			let badphrase = isJust mproblem
 			let problem = fromMaybe "" mproblem
 			let (username, hostname) = maybe ("", "")
-				(\(_, v) -> (T.pack $ remoteUserName v, T.pack $ fromMaybe (showAddr $ remoteAddress v) (remoteHostName v)))
+				(\(_, v, a) -> (T.pack $ remoteUserName v, T.pack $ fromMaybe (showAddr a) (remoteHostName v)))
 				(verifiableVal . fromPairMsg <$> msg)
 			u <- T.pack <$> liftIO getUserName
 			let sameusername = username == u
diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs
index 3698c8370..f2e80ff5b 100644
--- a/Assistant/WebApp/Configurators/Ssh.hs
+++ b/Assistant/WebApp/Configurators/Ssh.hs
@@ -11,21 +11,15 @@ module Assistant.WebApp.Configurators.Ssh where
 
 import Assistant.Common
 import Assistant.Ssh
+import Assistant.MakeRemote
 import Assistant.WebApp
 import Assistant.WebApp.Types
 import Assistant.WebApp.SideBar
 import Utility.Yesod
-import Assistant.WebApp.Configurators.Local
-import qualified Types.Remote as R
-import qualified Remote.Rsync as Rsync
-import qualified Command.InitRemote
-import Logs.UUID
-import Logs.Remote
 
 import Yesod
 import Data.Text (Text)
 import qualified Data.Text as T
-import qualified Data.Map as M
 import Network.BSD
 import System.Posix.User
 
@@ -127,7 +121,7 @@ getAddSshR = sshConfigurator $ do
 testServer :: SshServer -> IO (ServerStatus, Bool)
 testServer (SshServer { hostname = Nothing }) = return
 	(UnusableServer "Please enter a host name.", False)
-testServer sshserver = do
+testServer sshserver@(SshServer { hostname = Just hn }) = do
 	status <- probe [sshOpt "NumberOfPasswordPrompts" "0"]
 	if usable status
 		then return (status, False)
@@ -141,7 +135,7 @@ testServer sshserver = do
 				, checkcommand "git-annex-shell"
 				, checkcommand "rsync"
 				]
-			knownhost <- knownHost sshserver
+			knownhost <- knownHost hn
 			let sshopts = filter (not . null) $ extraopts ++
 				{- If this is an already known host, let
 				 - ssh check it as usual.
@@ -165,10 +159,6 @@ testServer sshserver = do
 		token r = "git-annex-probe " ++ r
 		report r = "echo " ++ token r
 
-{- user@host or host -}
-genSshHost :: Text -> Maybe Text -> String
-genSshHost host user = maybe "" (\v -> T.unpack v ++ "@") user ++ T.unpack host
-
 {- Runs a ssh command; if it fails shows the user the transcript,
  - and if it succeeds, runs an action. -}
 sshSetup :: [String] -> String -> Handler RepHtml -> Handler RepHtml
@@ -182,16 +172,6 @@ showSshErr :: String -> Handler RepHtml
 showSshErr msg = sshConfigurator $
 	$(widgetFile "configurators/ssh/error")
 
-{- Does ssh have known_hosts data for a hostname? -}
-knownHost :: SshServer -> IO Bool
-knownHost (SshServer { hostname = Nothing }) = return False
-knownHost (SshServer { hostname = Just h }) = do
-	sshdir <- sshDir
-	ifM (doesFileExist $ sshdir </> "known_hosts")
-		( not . null <$> readProcess "ssh-keygen" ["-F", T.unpack h]
-		, return False
-		)
-
 getConfirmSshR :: SshData -> Handler RepHtml
 getConfirmSshR sshdata = sshConfigurator $ do
 	let authtoken = webAppFormAuthToken
@@ -208,11 +188,11 @@ makeSsh rsync sshdata
 	| needsPubKey sshdata = do
 		keypair <- liftIO $ genSshKeyPair
 		sshdata' <- liftIO $ setupSshKeyPair keypair sshdata
-		makeSshWithKeyPair rsync sshdata' (Just keypair)
-	| otherwise = makeSshWithKeyPair rsync sshdata Nothing
+		makeSsh' rsync sshdata' (Just keypair)
+	| otherwise = makeSsh' rsync sshdata Nothing
 
-makeSshWithKeyPair :: Bool -> SshData -> Maybe SshKeyPair -> Handler RepHtml
-makeSshWithKeyPair rsync sshdata keypair =
+makeSsh' :: Bool -> SshData -> Maybe SshKeyPair -> Handler RepHtml
+makeSsh' rsync sshdata keypair =
 	sshSetup [sshhost, remoteCommand] "" $
 		makeSshRepo rsync sshdata
 	where
@@ -230,40 +210,13 @@ makeSshWithKeyPair rsync sshdata keypair =
 
 makeSshRepo :: Bool -> SshData -> Handler RepHtml
 makeSshRepo forcersync sshdata = do
-	r <- runAnnex undefined $
-		addRemote $ maker (sshRepoName sshdata) sshurl
-	syncRemote r
+	webapp <- getYesod
+	liftIO $ makeSshRemote
+		(fromJust $ threadState webapp)
+		(daemonStatus webapp)
+		(scanRemotes webapp)
+		forcersync sshdata
 	redirect RepositoriesR
-	where
-		rsync = forcersync || rsyncOnly sshdata
-		maker
-			| rsync = makeRsyncRemote
-			| otherwise = makeGitRemote
-		sshurl = T.unpack $ T.concat $
-			if rsync
-				then [u, h, ":", sshDirectory sshdata, "/"]
-				else ["ssh://", u, h, d, "/"]
-			where
-				u = maybe "" (\v -> T.concat [v, "@"]) $ sshUserName sshdata
-				h = sshHostName sshdata
-				d
-					| "/" `T.isPrefixOf` sshDirectory sshdata = d
-					| otherwise = T.concat ["/~/", sshDirectory sshdata]
-	
-
-{- Inits a rsync special remote, and returns the name of the remote. -}
-makeRsyncRemote :: String -> String -> Annex String
-makeRsyncRemote name location = makeRemote name location $ const $ do
-	(u, c) <- Command.InitRemote.findByName name
-	c' <- R.setup Rsync.remote u $ M.union config c
-	describeUUID u name
-	configSet u c'
-	where
-		config = M.fromList
-			[ ("encryption", "shared")
-			, ("rsyncurl", location)
-			, ("type", "rsync")
-			]
 
 getAddRsyncNetR :: Handler RepHtml
 getAddRsyncNetR = do
@@ -276,7 +229,7 @@ getAddRsyncNetR = do
 		$(widgetFile "configurators/addrsync.net")
 	case result of
 		FormSuccess sshserver -> do
-			knownhost <- liftIO $ knownHost sshserver
+			knownhost <- liftIO $ maybe (return False) knownHost (hostname sshserver)
 			keypair <- liftIO $ genSshKeyPair
 			sshdata <- liftIO $ setupSshKeyPair keypair
 				(mkSshData sshserver)