instrument P2P --debug with connection and thread info

For debugging http://git-annex.branchable.com/bugs/annex_get_-J_16_via_ssh_stalls_/

This work is supported by the NIH-funded NICEMAN (ReproNim TR&D3) project.

Command/EnableTor.hs

@@ -122,6 +122,7 @@ checkHiddenService = bracket setup cleanup go
 			, connCheckAuth = const False
 			, connIhdl = h
 			, connOhdl = h
+			, connIdent = ConnIdent Nothing
 			}
 		runst <- mkRunState Client
 		void $ runNetProto runst conn $ P2P.serveAuth u

P2P/IO.hs

@@ -12,6 +12,7 @@ module P2P.IO
 	, RunState(..)
 	, mkRunState
 	, P2PConnection(..)
+	, ConnIdent(..)
 	, ClosableConnection(..)
 	, stdioP2PConnection
 	, connectPeer
@@ -77,8 +78,12 @@ data P2PConnection = P2PConnection
 	, connCheckAuth :: (AuthToken -> Bool)
 	, connIhdl :: Handle
 	, connOhdl :: Handle
+	, connIdent :: ConnIdent
 	}
 
+-- Identifier for a connection, only used for debugging.
+newtype ConnIdent = ConnIdent (Maybe String)
+
 data ClosableConnection conn
 	= OpenConnection conn
 	| ClosedConnection
@@ -90,6 +95,7 @@ stdioP2PConnection g = P2PConnection
 	, connCheckAuth = const False
 	, connIhdl = stdin
 	, connOhdl = stdout
+	, connIdent = ConnIdent Nothing
 	}
 
 -- Opens a connection to a peer. Does not authenticate with it.
@@ -101,6 +107,7 @@ connectPeer g (TorAnnex onionaddress onionport) = do
 		, connCheckAuth = const False
 		, connIhdl = h
 		, connOhdl = h
+		, connIdent = ConnIdent Nothing
 		}
 
 closeConnection :: P2PConnection -> IO ()
@@ -166,7 +173,7 @@ runNet runst conn runner f = case f of
 	SendMessage m next -> do
 		v <- liftIO $ tryNonAsync $ do
 			let l = unwords (formatMessage m)
-			debugMessage "P2P >" m
+			debugMessage conn "P2P >" m
 			hPutStrLn (connOhdl conn) l
 			hFlush (connOhdl conn)
 		case v of
@@ -180,7 +187,7 @@ runNet runst conn runner f = case f of
 				ProtoFailureMessage "protocol error"
 			Right (Just l) -> case parseMessage l of
 				Just m -> do
-					liftIO $ debugMessage "P2P <" m
+					liftIO $ debugMessage conn "P2P <" m
 					runner (next (Just m))
 				Nothing -> runner (next Nothing)
 	SendBytes len b p next -> do
@@ -225,13 +232,19 @@ runNet runst conn runner f = case f of
 		Serving _ _ tv -> tv
 		Client tv -> tv
 
-debugMessage :: String -> Message -> IO ()
-debugMessage prefix m = debugM "p2p" $
-	prefix ++ " " ++ unwords (formatMessage safem)
+debugMessage :: P2PConnection -> String -> Message -> IO ()
+debugMessage conn prefix m = do
+	tid <- myThreadId	
+	debugM "p2p" $ concat $ catMaybes $
+		[ (\ident -> "[connection: " ++ ident ++ "] ") <$> mident
+		, Just $ "[" ++ show tid ++ "] "
+		, Just $ prefix ++ " " ++ unwords (formatMessage safem)
+		]
   where
 	safem = case m of
 		AUTH u _ -> AUTH u nullAuthToken
 		_ -> m
+	ConnIdent mident = connIdent conn
 
 -- Send exactly the specified number of bytes or returns False.
 --

Remote/Helper/Ssh.hs

@@ -29,6 +29,7 @@ import qualified P2P.Annex as P2P
 import Control.Concurrent.STM
 import Control.Concurrent.Async
 import qualified Data.ByteString as B
+import Data.Unique
 
 toRepo :: ConsumeStdin -> Git.Repo -> RemoteGitConfig -> SshCommand -> Annex (FilePath, [CommandParam])
 toRepo cs r gc remotecmd = do
@@ -257,11 +258,16 @@ openP2PSshConnection r connpool = do
 				, std_out = CreatePipe
 				, std_err = CreatePipe
 				}
+		-- Could use getPid, but need to build with older versions
+		-- of process, so instead a unique connection number.
+		connnum <- hashUnique <$> newUnique
 		let conn = P2P.P2PConnection
 			{ P2P.connRepo = repo
 			, P2P.connCheckAuth = const False
 			, P2P.connIhdl = to
 			, P2P.connOhdl = from
+			, P2P.connIdent = P2P.ConnIdent $
+				Just $ "ssh connection " ++ show connnum
 			}
 		stderrhandlerst <- newStderrHandler err
 		runst <- P2P.mkRunState P2P.Client

RemoteDaemon/Transport/Tor.hs

@@ -114,6 +114,7 @@ serveClient th u r q = bracket setup cleanup start
 				, connCheckAuth = (`isAllowedAuthToken` allowed)
 				, connIhdl = h
 				, connOhdl = h
+				, connIdent = ConnIdent $ Just "tor remotedaemon"
 				}
 			-- not really Client, but we don't know their uuid yet
 			runstauth <- liftIO $ mkRunState Client