send remote-daemon a RELOAD after making a ssh remote

This doesn't work yet, because RELOAD is buggy and does not notice the new
remote.

Assistant/Threads/RemoteControl.hs

@@ -52,8 +52,10 @@ remoteControlThread = namedThread "RemoteControl" $ do
 remoteControllerThread :: Handle -> Assistant ()
 remoteControllerThread toh = do
 	clicker <- getAssistant remoteControl
-	liftIO $ forever $ do
+	forever $ do
-		msg <- readChan clicker
+		msg <- liftIO $ readChan clicker
+		debug [show msg]
+		liftIO $ do
 			hPutStrLn toh $ unwords $ formatMessage msg
 			hFlush toh
 
@@ -63,6 +65,7 @@ remoteResponderThread fromh urimap = go M.empty
   where
 	go syncalerts = do
 		l <- liftIO $ hGetLine fromh
+		debug [l]
 		case parseMessage l of
 			Just (CONNECTED uri) -> changeconnected S.insert uri
 			Just (DISCONNECTED uri) -> changeconnected S.delete uri

Assistant/WebApp/Configurators/Ssh.hs

@@ -24,6 +24,7 @@ import Git.Types (RemoteName)
 import qualified Remote.GCrypt as GCrypt
 import Annex.UUID
 import Logs.UUID
+import Assistant.RemoteControl
 
 #ifdef mingw32_HOST_OS
 import Utility.Tmp
@@ -405,12 +406,19 @@ prepSsh' newgcrypt origsshdata sshdata keypair a = sshSetup
 makeSshRepo :: SshData -> Handler Html
 makeSshRepo sshdata
 	| onlyCapability sshdata RsyncCapable = setupCloudRemote TransferGroup Nothing go
-	| otherwise = setupRemote EditNewRepositoryR TransferGroup Nothing go
+	| otherwise = makeSshRepoConnection go
   where
 	go = makeSshRemote sshdata
 
+makeSshRepoConnection :: Annex RemoteName -> Handler Html
+makeSshRepoConnection a = setupRemote postsetup TransferGroup Nothing a
+  where
+	postsetup u = do
+		liftAssistant $ sendRemoteControl RELOAD
+		redirect $ EditNewRepositoryR u
+
 makeGCryptRepo :: KeyId -> SshData -> Handler Html
-makeGCryptRepo keyid sshdata = setupRemote EditNewRepositoryR TransferGroup Nothing $ 
+makeGCryptRepo keyid sshdata = makeSshRepoConnection $ 
 	makeGCryptRemote (sshRepoName sshdata) (genSshUrl sshdata) keyid
 
 getAddRsyncNetR :: Handler Html

Assistant/WebApp/MakeRemote.hs

@@ -31,13 +31,13 @@ import Utility.Yesod
  - This includes displaying the connectionNeeded nudge if appropariate.
  -}
 setupCloudRemote :: StandardGroup -> Maybe Cost -> Annex RemoteName -> Handler a
-setupCloudRemote = setupRemote EditNewCloudRepositoryR
+setupCloudRemote = setupRemote $ redirect . EditNewCloudRepositoryR
 
-setupRemote :: (UUID -> Route WebApp) -> StandardGroup -> Maybe Cost -> Annex RemoteName -> Handler a
+setupRemote :: (UUID -> Handler a) -> StandardGroup -> Maybe Cost -> Annex RemoteName -> Handler a
-setupRemote redirto defaultgroup mcost getname = do
+setupRemote postsetup defaultgroup mcost getname = do
 	r <- liftAnnex $ addRemote getname
 	liftAnnex $ do
 		setStandardGroup (Remote.uuid r) defaultgroup
 		maybe noop (Config.setRemoteCost (Remote.repo r)) mcost
 	liftAssistant $ syncRemote r
-	redirect $ redirto $ Remote.uuid r
+	postsetup $ Remote.uuid r

RemoteDaemon/Types.hs

@@ -20,6 +20,7 @@ import Control.Concurrent
 
 -- The URI of a remote is used to uniquely identify it (names change..)
 newtype RemoteURI = RemoteURI URI
+  deriving (Show)
 
 -- A Transport for a particular git remote consumes some messages
 -- from a Chan, and emits others to another Chan.
@@ -38,6 +39,7 @@ data Emitted
 	| SYNCING RemoteURI
 	| DONESYNCING RemoteURI Bool
 	| WARNING RemoteURI String
+	deriving (Show)
 
 -- Messages that the deamon consumes.
 data Consumed
@@ -47,6 +49,7 @@ data Consumed
 	| CHANGED RefList
 	| RELOAD
 	| STOP
+	deriving (Show)
 
 type RefList = [Git.Ref]