git long-running process handshake implementation

This commit was supported by the NSF-funded DataLad project.

Git/Protocol/LongRunningProcess.hs

@@ -0,0 +1,138 @@
+{- Git long-running process protocol, as documented in 
+ - git/Documentation/technical/long-running-process-protocol.txt
+ -
+ - Copyright 2018 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE OverloadedStrings, LambdaCase #-}
+
+module Git.Protocol.LongRunningProcess where
+
+import Git.Protocol.PktLine
+
+import qualified Data.Text as T
+import Data.ByteString.Builder
+import Data.Monoid
+import Control.Applicative
+import System.IO
+
+data ClientServer = Client | Server
+	deriving (Show)
+
+clientServerSuffix :: ClientServer -> T.Text
+clientServerSuffix Client = "-client"
+clientServerSuffix Server = "-server"
+
+data Role = Role ClientServer T.Text
+	deriving (Show)
+
+parseRole :: T.Text -> Maybe Role
+parseRole t = go Client <|> go Server
+  where
+	go cs = 
+		let suffix = clientServerSuffix cs
+		in if suffix `T.isSuffixOf` t
+			then Just $ Role cs $
+				T.take (T.length t - T.length suffix) t
+			else Nothing
+
+pktRole :: PktLine -> Maybe Role
+pktRole = either (const Nothing) parseRole
+	. pktLineText
+
+rolePkt :: Role -> Maybe PktLine
+rolePkt (Role cs t) = textPktLine $ t <> clientServerSuffix cs
+
+newtype Capability = Capability { fromCapability :: T.Text }
+	deriving (Show, Eq)
+
+pktCapability :: PktLine -> Maybe Capability
+pktCapability = parseKV "capability" Capability
+
+capabilityPkt :: Capability -> Maybe PktLine
+capabilityPkt = formatKV "capability" fromCapability
+
+newtype Version = Version { fromVersion :: T.Text }
+	deriving (Show, Eq)
+
+pktVersion :: PktLine -> Maybe Version
+pktVersion = parseKV "version" Version
+
+versionPkt :: Version -> Maybe PktLine
+versionPkt = formatKV "version" fromVersion
+
+-- | Runs the protocol's initial handshake.
+--
+-- The Role selection function should convert a Client role into a
+-- Server role; git will be the Client and the program using this module
+-- the Server.
+handshake
+	:: (Role -> Either String Role) -- ^ role selection function
+	-> ([Capability] -> [Capability]) -- ^ capability selection function
+	-> Handle -- ^ handle to receive data from git
+	-> Handle -- ^ handle to send data to git
+	-> IO (Either String (Role, [Capability]))
+handshake selectrole selectcapabilities input output =
+	getpkt pktRole $ \role ->
+		checkversion $ do
+			case selectrole role of
+				Left e -> return (Left e)
+				Right myrole -> sendpkt rolePkt myrole $
+					sendpkt versionPkt (Version "2") $
+						exchangecaps $ \mycaps -> return $ 
+							Right (myrole, mycaps)
+  where
+	protoerr e = return $ Left $ e ++ " from git in protocol handshake"
+	
+	sendpkt f v cnt = case f v of
+		Just pkt -> do
+			hPutBuilder output $ encodePktLine pkt
+			hFlush output
+			cnt
+		Nothing -> return $ Left $ 
+			"failed constructing pkt-line packet for: " ++ show v
+	
+	sendpkts _ [] cnt = sendpkt Just flushPkt cnt
+	sendpkts f (v:vs) cnt = sendpkt f v $ sendpkts f vs cnt
+
+	getpkt parser cnt = readPktLine input >>= \case
+		Nothing -> protoerr "EOF"
+		Just (Left e) -> return (Left e)
+		Just (Right pkt) -> case parser pkt of
+			Nothing -> protoerr $ "unparsable packet: " ++ show pkt
+			Just v -> cnt v
+	
+	getpkts parser cnt = go []
+	  where
+		go c = getpkt Just $ \pkt ->
+			if pkt == flushPkt
+				then cnt (reverse c)
+				else case parser pkt of
+					Nothing -> protoerr $ "unparsable packet" ++ show pkt
+					Just v -> go (v:c)
+	
+	checkversion cnt = getpkts pktVersion $ \versions ->
+		if any (== Version "2") versions
+			then cnt
+			else return $ Left $
+				"git is using an unsupported protocol version: " ++ show versions
+	
+	exchangecaps cnt = getpkts pktCapability $ \caps -> do
+		let mycaps = selectcapabilities caps
+		sendpkts capabilityPkt mycaps $
+			cnt mycaps
+
+formatKV :: T.Text -> (v -> T.Text ) -> v -> Maybe PktLine
+formatKV k f v = textPktLine $ k <> "=" <> f v
+
+parseKV :: T.Text -> (T.Text -> v) -> PktLine -> Maybe v
+parseKV k mkv = either (const Nothing) go . pktLineText
+  where
+	kprefix = k <> "="
+	go t
+		| kprefix `T.isPrefixOf` t = Just $ mkv $ 
+			T.drop (T.length kprefix) t
+		| otherwise = Nothing
+

Git/Protocol/PktLine.hs

@@ -18,6 +18,7 @@ module Git.Protocol.PktLine (
 	parsePktLine,
 	decodePktLine,
 	splitPktLine,
+	readPktLine,
 ) where
 
 import qualified Data.ByteString as S
@@ -31,12 +32,13 @@ import qualified Data.Text.Encoding as E
 import qualified Data.Text.Encoding.Error as E
 import Data.Monoid
 import Data.Word
+import System.IO
 
 -- | A pkt-line encodes a variable length binary string with a maximum size.
 --
 -- This module only exports smart constructors for legal pkt-lines.
 newtype PktLine = PktLine S.ByteString
-	deriving (Show)
+	deriving (Show, Eq)
 
 -- | Maximum data that can be contained in a pkt-line, not
 -- including the 4 byte length header.
@@ -96,17 +98,17 @@ encodePktLine (PktLine b)
 
 -- | Attoparsec parser for a pkt-line.
 parsePktLine :: Parser PktLine
-parsePktLine = do
-	len <- parseLengthHeader
-	if len == 0
-		then do
-			endOfInput
-			return flushPkt
-		else if len < 4
-			-- It's impossible for a pkt-line to be less than
-			-- 4 bytes long, since the length header is 4 bytes.
-			then fail "invalid pkt-line length"
-			else PktLine <$> A.take (len - 4)
+parsePktLine = parsePktLine' =<< parseLengthHeader
+
+parsePktLine' :: Int -> Parser PktLine
+parsePktLine' len
+	| len == 0 = do
+		endOfInput
+		return flushPkt
+	-- It's impossible for a pkt-line to be less than
+	-- 4 bytes long, since the length header is 4 bytes.
+	| len < 4 = fail "invalid pkt-line length"
+	| otherwise = PktLine <$> A.take (len - 4)
 
 parseLengthHeader :: Parser Int
 parseLengthHeader = do
@@ -134,3 +136,23 @@ splitPktLine = go . AL.parse parsePktLine
   where
 	go (AL.Done rest p) = Right (p, rest)
 	go (AL.Fail _ _ e) = Left e
+
+-- | Read the next PktLine from a Handle. 
+--
+-- Nothing is returned at EOF.
+readPktLine :: Handle -> IO (Maybe (Either String PktLine))
+readPktLine h = do
+	header <- S.hGet h 4
+	if S.null header
+		then return Nothing
+		else case parseOnly parseLengthHeader header of
+			Left e -> return $ Just $ Left e
+			Right len
+				| len == 0 -> return $ Just $ Right flushPkt
+				| otherwise -> do
+					-- The header parser rejects headers that
+					-- are too long, so this will never use
+					-- much memory.
+					body <- S.hGet h (len - 4)
+					let parser = parsePktLine' len <* endOfInput
+					return $ Just $ parseOnly parser body

git-annex.cabal

@@ -847,6 +847,7 @@ Executable git-annex
     Git.LsTree
     Git.Merge
     Git.Objects
+    Git.Protocol.LongRunningProcess
     Git.Protocol.PktLine
     Git.Queue
     Git.Ref