broke out fairly generic ssh stuff to Assistant.Ssh so pairing can use it too

I'd rather Utility.Ssh, but the SshData type is not sufficiently clean and
generic for Utility.

5 files changed, 161 insertions, 139 deletions

diff --git a/Assistant/Pairing.hs b/Assistant/Pairing.hs
index c78deace0..399c7e50f 100644
--- a/Assistant/Pairing.hs
+++ b/Assistant/Pairing.hs
@@ -8,6 +8,7 @@
 module Assistant.Pairing where
 
 import Utility.Verifiable
+import Assistant.Ssh
 
 import Control.Concurrent
 import Network.Socket
@@ -40,7 +41,7 @@ data PairData = PairData
 	, remoteAddress :: SomeAddr
 	, remoteUserName :: UserName
 	, remoteDirectory :: FilePath
-	, sshPubKey :: SshPubKey
+	, remoteSshPubKey :: SshPubKey
 	}
 	deriving (Eq, Read, Show)
 
@@ -52,6 +53,7 @@ type UserName = String
 data PairingInProgress = PairingInProgress
 	{ inProgressSecret :: Secret
 	, inProgressThreadId :: ThreadId
+	, inProgressSshKeyPair :: SshKeyPair
 	}
 
 data SomeAddr = IPv4Addr HostAddress | IPv6Addr HostAddress6
diff --git a/Assistant/Ssh.hs b/Assistant/Ssh.hs
new file mode 100644
index 000000000..35ef64caa
--- /dev/null
+++ b/Assistant/Ssh.hs
@@ -0,0 +1,145 @@
+{- git-annex assistant ssh utilities
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.Ssh where
+
+import Common
+import Utility.TempFile
+
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Control.Exception as E
+import System.Process (CreateProcess(..))
+import Control.Concurrent
+
+data SshData = SshData
+	{ sshHostName :: Text
+	, sshUserName :: Maybe Text
+	, sshDirectory :: Text
+	, sshRepoName :: String
+	, needsPubKey :: Bool
+	, rsyncOnly :: Bool
+	}
+	deriving (Read, Show, Eq)
+
+data SshKeyPair = SshKeyPair
+	{ sshPubKey :: String
+	, sshPrivKey :: String
+	}
+
+{- ssh -ofoo=bar command-line option -}
+sshOpt :: String -> String -> String
+sshOpt k v = concat ["-o", k, "=", v]
+
+sshDir :: IO FilePath
+sshDir = do
+	home <- myHomeDir
+	return $ home </> ".ssh"
+
+{- The output of ssh, including both stdout and stderr. -}
+sshTranscript :: [String] -> String -> IO (String, Bool)
+sshTranscript opts input = do
+	(readf, writef) <- createPipe
+	readh <- fdToHandle readf
+	writeh <- fdToHandle writef
+	(Just inh, _, _, pid) <- createProcess $
+		(proc "ssh" opts)
+			{ std_in = CreatePipe
+			, std_out = UseHandle writeh
+			, std_err = UseHandle writeh
+			}
+	hClose writeh
+
+	-- fork off a thread to start consuming the output
+	transcript <- hGetContents readh
+	outMVar <- newEmptyMVar
+	_ <- forkIO $ E.evaluate (length transcript) >> putMVar outMVar ()
+
+	-- now write and flush any input
+	when (not (null input)) $ do hPutStr inh input; hFlush inh
+	hClose inh -- done with stdin
+
+	-- wait on the output
+	takeMVar outMVar
+	hClose readh
+
+	ok <- checkSuccessProcess pid
+	return ()
+	return (transcript, ok)
+
+{- Implemented as a shell command, so it can be run on remote servers over
+ - ssh. -}
+makeAuthorizedKeys :: SshData -> SshKeyPair -> Maybe String
+makeAuthorizedKeys sshdata keypair
+	| needsPubKey sshdata = Just $ join "&&" $
+		[ "mkdir -p ~/.ssh"
+		, "touch ~/.ssh/authorized_keys"
+		, "chmod 600 ~/.ssh/authorized_keys"
+		, unwords
+			[ "echo"
+			, shellEscape $ authorizedKeysLine sshdata keypair
+			, ">>~/.ssh/authorized_keys"
+			]
+		]
+	| otherwise = Nothing
+		
+authorizedKeysLine :: SshData -> SshKeyPair -> String
+authorizedKeysLine sshdata (SshKeyPair { sshPubKey = pubkey })
+	{- TODO: Locking down rsync is difficult, requiring a rather
+	 - long perl script. -}
+	| rsyncOnly sshdata = pubkey
+	| otherwise = limitcommand "git-annex-shell -c" ++ pubkey
+	where
+		limitcommand c = "command=\"perl -e 'exec qw(" ++ c ++ "), $ENV{SSH_ORIGINAL_COMMAND}'\",no-agent-forwarding,no-port-forwarding,no-X11-forwarding "
+
+{- Generates a ssh key pair. -}
+genSshKeyPair :: IO SshKeyPair
+genSshKeyPair = withTempDir "git-annex-keygen" $ \dir -> do
+	ok <- boolSystem "ssh-keygen"
+		[ Param "-P", Param "" -- no password
+		, Param "-f", File $ dir </> "key"
+		]
+	unless ok $
+		error "ssh-keygen failed"
+	SshKeyPair
+		<$> readFile (dir </> "key.pub")
+		<*> readFile (dir </> "key")
+
+{- Installs a ssh key pair, and sets up ssh config with a mangled hostname
+ - that will enable use of the key. This way we avoid changing the user's
+ - regular ssh experience at all. Returns a modified SshData containing the
+ - mangled hostname. -}
+setupSshKeyPair :: SshKeyPair -> SshData -> IO SshData
+setupSshKeyPair sshkeypair sshdata = do
+	sshdir <- sshDir
+	let configfile = sshdir </> "config"
+	createDirectoryIfMissing True sshdir
+
+	unlessM (doesFileExist $ sshdir </> sshprivkeyfile) $ do
+		h <- fdToHandle =<<
+			createFile (sshdir </> sshprivkeyfile)
+				(unionFileModes ownerWriteMode ownerReadMode)
+		hPutStr h (sshPrivKey sshkeypair)
+		hClose h
+	unlessM (doesFileExist $ sshdir </> sshpubkeyfile) $ do
+		writeFile (sshdir </> sshpubkeyfile) (sshPubKey sshkeypair)
+
+	unlessM (catchBoolIO $ isInfixOf mangledhost <$> readFile configfile) $
+		appendFile configfile $ unlines
+			[ ""
+			, "# Added automatically by git-annex"
+			, "Host " ++ mangledhost
+			, "\tHostname " ++ T.unpack (sshHostName sshdata)
+			, "\tIdentityFile ~/.ssh/" ++ sshprivkeyfile
+			]
+
+	return $ sshdata { sshHostName = T.pack mangledhost }
+	where
+		sshprivkeyfile = "key." ++ mangledhost
+		sshpubkeyfile = sshprivkeyfile ++ ".pub"
+		mangledhost = "git-annex-" ++ T.unpack (sshHostName sshdata) ++ user
+		user = maybe "" (\u -> "-" ++ T.unpack u) (sshUserName sshdata)
diff --git a/Assistant/WebApp/Configurators/Pairing.hs b/Assistant/WebApp/Configurators/Pairing.hs
index d4301473f..da54e6a88 100644
--- a/Assistant/WebApp/Configurators/Pairing.hs
+++ b/Assistant/WebApp/Configurators/Pairing.hs
@@ -29,18 +29,19 @@
 module Assistant.WebApp.Configurators.Pairing where
 
 import Assistant.Pairing
+import Assistant.WebApp
+import Assistant.WebApp.Types
+import Assistant.WebApp.SideBar
+import Utility.Yesod
 #ifdef WITH_PAIRING
 import Assistant.Pairing.Network
+import Assistant.Ssh
 import Assistant.Common
 import Assistant.Alert
 import Assistant.DaemonStatus
 import Utility.Verifiable
 import Utility.Network
 #endif
-import Assistant.WebApp
-import Assistant.WebApp.Types
-import Assistant.WebApp.SideBar
-import Utility.Yesod
 
 import Yesod
 import Data.Text (Text)
@@ -60,15 +61,17 @@ getStartPairR = promptSecret Nothing $ \rawsecret secret -> do
 	dstatus <- daemonStatus <$> lift getYesod
 	urlrender <- lift getUrlRender
 	let homeurl = urlrender HomeR
-	hostname <- liftIO $ getHostname
-	username <- liftIO $ getUserName
+	hostname <- liftIO getHostname
+	username <- liftIO getUserName
 	reldir <- fromJust . relDir <$> lift getYesod
-	let sshkey = "" -- TODO generate/read ssh key
+	keypair <- liftIO genSshKeyPair
+	let pubkey = sshPubKey keypair ++ "foo"
 	let mkmsg addr = PairMsg $ mkVerifiable
-		(PairReq, PairData hostname addr username reldir sshkey) secret
+		(PairReq, PairData hostname addr username reldir pubkey) secret
 	liftIO $ do
 		pip <- PairingInProgress secret
 			<$> sendrequests mkmsg dstatus homeurl
+			<*> pure keypair
 		oldpip <- modifyDaemonStatus dstatus $
 			\s -> (s { pairingInProgress = Just pip }, pairingInProgress s)
 		maybe noop stopold oldpip
diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs
index 998249f76..eebcdae03 100644
--- a/Assistant/WebApp/Configurators/Ssh.hs
+++ b/Assistant/WebApp/Configurators/Ssh.hs
@@ -10,11 +10,11 @@
 module Assistant.WebApp.Configurators.Ssh where
 
 import Assistant.Common
+import Assistant.Ssh
 import Assistant.WebApp
 import Assistant.WebApp.Types
 import Assistant.WebApp.SideBar
 import Utility.Yesod
-import Utility.TempFile
 import Assistant.WebApp.Configurators.Local
 import qualified Types.Remote as R
 import qualified Remote.Rsync as Rsync
@@ -26,11 +26,8 @@ import Yesod
 import Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Map as M
-import qualified Control.Exception as E
 import Network.BSD
 import System.Posix.User
-import System.Process (CreateProcess(..))
-import Control.Concurrent
 
 sshConfigurator :: Widget -> Handler RepHtml
 sshConfigurator a = bootstrap (Just Config) $ do
@@ -45,11 +42,6 @@ data SshServer = SshServer
 	}
 	deriving (Show)
 
-data SshKeyPair = SshKeyPair
-	{ sshPubKey :: String
-	, sshPrivKey :: String
-	}
-
 {- SshServer is only used for applicative form prompting, this converts
  - the result of such a form into a SshData. -}
 mkSshData :: SshServer -> SshData
@@ -171,15 +163,6 @@ testServer sshserver = do
 		token r = "git-annex-probe " ++ r
 		report r = "echo " ++ token r
 
-{- ssh -ofoo=bar command-line option -}
-sshOpt :: String -> String -> String
-sshOpt k v = concat ["-o", k, "=", v]
-
-sshDir :: IO FilePath
-sshDir = do
-	home <- myHomeDir
-	return $ home </> ".ssh"
-
 {- user@host or host -}
 genSshHost :: Text -> Maybe Text -> String
 genSshHost host user = maybe "" (\v -> T.unpack v ++ "@") user ++ T.unpack host
@@ -189,37 +172,6 @@ genSshRepoName :: SshServer -> String
 genSshRepoName s = (T.unpack $ fromJust $ hostname s) ++
 	(maybe "" (\d -> '_' : T.unpack d) (directory s))
 
-{- The output of ssh, including both stdout and stderr. -}
-sshTranscript :: [String] -> String -> IO (String, Bool)
-sshTranscript opts input = do
-	(readf, writef) <- createPipe
-	readh <- fdToHandle readf
-	writeh <- fdToHandle writef
-	(Just inh, _, _, pid) <- createProcess $
-		(proc "ssh" opts)
-			{ std_in = CreatePipe
-			, std_out = UseHandle writeh
-			, std_err = UseHandle writeh
-			}
-	hClose writeh
-
-	-- fork off a thread to start consuming the output
-	transcript <- hGetContents readh
-	outMVar <- newEmptyMVar
-	_ <- forkIO $ E.evaluate (length transcript) >> putMVar outMVar ()
-
-	-- now write and flush any input
-	when (not (null input)) $ do hPutStr inh input; hFlush inh
-	hClose inh -- done with stdin
-
-	-- wait on the output
-	takeMVar outMVar
-	hClose readh
-
-	ok <- checkSuccessProcess pid
-	return ()
-	return (transcript, ok)
-
 {- 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
@@ -314,77 +266,6 @@ makeRsyncRemote name location = makeRemote name location $ const $ do
 			, ("type", "rsync")
 			]
 
-makeAuthorizedKeys :: SshData -> SshKeyPair -> Maybe String
-makeAuthorizedKeys sshdata keypair
-	| needsPubKey sshdata = Just $ join "&&" $
-		[ "mkdir -p ~/.ssh"
-		, "touch ~/.ssh/authorized_keys"
-		, "chmod 600 ~/.ssh/authorized_keys"
-		, unwords
-			[ "echo"
-			, shellEscape $ authorizedKeysLine sshdata keypair
-			, ">>~/.ssh/authorized_keys"
-			]
-		]
-	| otherwise = Nothing
-		
-authorizedKeysLine :: SshData -> SshKeyPair -> String
-authorizedKeysLine sshdata (SshKeyPair { sshPubKey = pubkey })
-	{- TODO: Locking down rsync is difficult, requiring a rather
-	 - long perl script. -}
-	| rsyncOnly sshdata = pubkey
-	| otherwise = limitcommand "git-annex-shell -c" ++ pubkey
-	where
-		limitcommand c = "command=\"perl -e 'exec qw(" ++ c ++ "), $ENV{SSH_ORIGINAL_COMMAND}'\",no-agent-forwarding,no-port-forwarding,no-X11-forwarding "
-
-{- Generates a ssh key pair. -}
-genSshKeyPair :: IO SshKeyPair
-genSshKeyPair = withTempDir "git-annex-keygen" $ \dir -> do
-	ok <- boolSystem "ssh-keygen"
-		[ Param "-P", Param "" -- no password
-		, Param "-f", File $ dir </> "key"
-		]
-	unless ok $
-		error "ssh-keygen failed"
-	SshKeyPair
-		<$> readFile (dir </> "key.pub")
-		<*> readFile (dir </> "key")
-
-{- Installs a ssh key pair, and sets up ssh config with a mangled hostname
- - that will enable use of the key. This way we avoid changing the user's
- - regular ssh experience at all. Returns a modified SshData containing the
- - mangled hostname. -}
-setupSshKeyPair :: SshKeyPair -> SshData -> IO SshData
-setupSshKeyPair sshkeypair sshdata = do
-	sshdir <- sshDir
-	let configfile = sshdir </> "config"
-	createDirectoryIfMissing True sshdir
-
-	unlessM (doesFileExist $ sshdir </> sshprivkeyfile) $ do
-		h <- fdToHandle =<<
-			createFile (sshdir </> sshprivkeyfile)
-				(unionFileModes ownerWriteMode ownerReadMode)
-		hPutStr h (sshPrivKey sshkeypair)
-		hClose h
-	unlessM (doesFileExist $ sshdir </> sshpubkeyfile) $ do
-		writeFile (sshdir </> sshpubkeyfile) (sshPubKey sshkeypair)
-
-	unlessM (catchBoolIO $ isInfixOf mangledhost <$> readFile configfile) $
-		appendFile configfile $ unlines
-			[ ""
-			, "# Added automatically by git-annex"
-			, "Host " ++ mangledhost
-			, "\tHostname " ++ T.unpack (sshHostName sshdata)
-			, "\tIdentityFile ~/.ssh/" ++ sshprivkeyfile
-			]
-
-	return $ sshdata { sshHostName = T.pack mangledhost }
-	where
-		sshprivkeyfile = "key." ++ mangledhost
-		sshpubkeyfile = sshprivkeyfile ++ ".pub"
-		mangledhost = "git-annex-" ++ T.unpack (sshHostName sshdata) ++ user
-		user = maybe "" (\u -> "-" ++ T.unpack u) (sshUserName sshdata)
-
 getAddRsyncNetR :: Handler RepHtml
 getAddRsyncNetR = do
 	((result, form), enctype) <- runFormGet $
diff --git a/Assistant/WebApp/Types.hs b/Assistant/WebApp/Types.hs
index d018cddbf..f12aedee1 100644
--- a/Assistant/WebApp/Types.hs
+++ b/Assistant/WebApp/Types.hs
@@ -11,6 +11,7 @@
 module Assistant.WebApp.Types where
 
 import Assistant.Common
+import Assistant.Ssh
 import Assistant.ThreadedMonad
 import Assistant.DaemonStatus
 import Assistant.ScanRemotes
@@ -67,16 +68,6 @@ data WebAppState = WebAppState
 	{ showIntro :: Bool
 	}
 
-data SshData = SshData
-	{ sshHostName :: Text
-	, sshUserName :: Maybe Text
-	, sshDirectory :: Text
-	, sshRepoName :: String
-	, needsPubKey :: Bool
-	, rsyncOnly :: Bool
-	}
-	deriving (Read, Show, Eq)
-
 instance PathPiece SshData where
     toPathPiece = pack . show
     fromPathPiece = readish . unpack