work around ssh brain-damange

The control socket path passed to ssh needs to be 17 characters shorter
than the maximum unix domain socket length, because ssh appends stuff to it
to make a temporary filename. Closes: #725512

Also, take the shorter of the relative and the absolute paths to the
socket. Typically the relative path will be a lot shorter (unless
deep inside a subdirectory of the repository), and so using it will
avoid flirting with the maximum safe socket lenghts in more situations,
and so lead to less breakage if all my attempts at fixing this are
still buggy.

1 files changed, 30 insertions, 11 deletions

diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs
index 3b1e4b457..e2b6564e4 100644
--- a/Annex/Ssh.hs
+++ b/Annex/Ssh.hs
@@ -52,14 +52,30 @@ sshInfo (host, port) = go =<< sshCacheDir
   where
 	go Nothing = return (Nothing, [])
 	go (Just dir) = do
-		let socketfile = dir </> hostport2socket host port
-		if valid_unix_socket_path socketfile
-			then return (Just socketfile, sshConnectionCachingParams socketfile)
-			else do
-				socketfile' <- liftIO $ relPathCwdToFile socketfile
-				return $ if valid_unix_socket_path socketfile'
-					then (Just socketfile', sshConnectionCachingParams socketfile')
-					else (Nothing, [])
+		r <- liftIO $ bestSocketPath $ dir </> hostport2socket host port
+		return $ case r of
+			Nothing -> (Nothing, [])
+			Just socketfile -> (Just socketfile, sshConnectionCachingParams socketfile)
+
+{- Given an absolute path to use for a socket file,
+ - returns whichever is shorter of that or the relative path to the same
+ - file.
+ -
+ - If no path can be constructed that is a valid socket, returns Nothing. -}
+bestSocketPath :: FilePath -> IO (Maybe FilePath)
+bestSocketPath abssocketfile = do
+	relsocketfile <- liftIO $ relPathCwdToFile abssocketfile
+	let socketfile = if length abssocketfile <= length relsocketfile
+		then abssocketfile
+		else relsocketfile
+	return $ if valid_unix_socket_path (socketfile ++ sshgarbage)
+			then Just socketfile
+			else Nothing
+  where
+  	-- ssh appends a 16 char extension to the socket when setting it
+	-- up, which needs to be taken into account when checking
+	-- that a valid socket was constructed.
+  	sshgarbage = take (1+16) $ repeat 'X'
 
 sshConnectionCachingParams :: FilePath -> [CommandParam]
 sshConnectionCachingParams socketfile = 
@@ -96,8 +112,9 @@ sshCleanup = go =<< sshCacheDir
   where
 	go Nothing = noop
 	go (Just dir) = do
-		sockets <- filter (not . isLock) <$>
-			liftIO (catchDefaultIO [] $ dirContents dir)
+		sockets <- liftIO $ filter (not . isLock) . catMaybes 
+			<$> (mapM bestSocketPath
+				=<< catchDefaultIO [] (dirContents dir))
 		forM_ sockets cleanup
 	cleanup socketfile = do
 #ifndef mingw32_HOST_OS
@@ -139,8 +156,10 @@ hostport2socket host Nothing = hostport2socket' host
 hostport2socket host (Just port) = hostport2socket' $ host ++ "!" ++ show port
 hostport2socket' :: String -> FilePath
 hostport2socket' s
-	| length s > 32 = md5s (Str s)
+	| length s > lengthofmd5s = md5s (Str s)
 	| otherwise = s
+  where
+	lengthofmd5s = 32
 
 socket2lock :: FilePath -> FilePath
 socket2lock socket = socket ++ lockExt