From 42c5d7c64f1752f718afa0d6d9873ff926a382f2 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 14 Aug 2018 13:37:17 -0400 Subject: [PATCH] moving to filterdriver branch Not used in master, so remove until/unless filterdriver branch is merged. --- Git/Protocol/LongRunningProcess.hs | 141 ------------------------- Git/Protocol/PktLine.hs | 161 ----------------------------- git-annex.cabal | 2 - 3 files changed, 304 deletions(-) delete mode 100644 Git/Protocol/LongRunningProcess.hs delete mode 100644 Git/Protocol/PktLine.hs diff --git a/Git/Protocol/LongRunningProcess.hs b/Git/Protocol/LongRunningProcess.hs deleted file mode 100644 index 0ace1863b8..0000000000 --- a/Git/Protocol/LongRunningProcess.hs +++ /dev/null @@ -1,141 +0,0 @@ -{- Git long-running process protocol, as documented in - - git/Documentation/technical/long-running-process-protocol.txt - - - - Copyright 2018 Joey Hess - - - - Licensed under the GNU GPL version 3 or higher. - -} - -{-# LANGUAGE LambdaCase #-} - -module Git.Protocol.LongRunningProcess where - -import Git.Protocol.PktLine - -import Data.List -import Data.Monoid -import Control.Applicative -import System.IO - -data ClientServer = Client | Server - deriving (Show) - -clientServerSuffix :: ClientServer -> String -clientServerSuffix Client = "-client" -clientServerSuffix Server = "-server" - -data Role = Role ClientServer String - deriving (Show) - -parseRole :: String -> Maybe Role -parseRole s = go Client <|> go Server - where - go cs = - let suffix = clientServerSuffix cs - in if suffix `isSuffixOf` s - then Just $ Role cs $ - take (length s - length suffix) s - else Nothing - -pktRole :: PktLine -> Maybe Role -pktRole = parseRole . pktLineString - -rolePkt :: Role -> Maybe PktLine -rolePkt (Role cs t) = stringPktLine $ t <> clientServerSuffix cs - -newtype Capability = Capability { fromCapability :: String } - deriving (Show, Eq) - -pktCapability :: PktLine -> Maybe Capability -pktCapability = parseKV "capability" Capability - -capabilityPkt :: Capability -> Maybe PktLine -capabilityPkt = formatKV "capability" fromCapability - -newtype Version = Version { fromVersion :: String } - 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 -> Bool) -- ^ capability selection function - -> Handle -- ^ handle to receive data from git - -> Handle -- ^ handle to send data to git - -> IO (Either String (Role, [Capability])) -handshake selectrole selectcapability input output = - getpkt pktRole $ \role -> checkversion $ - case selectrole role of - Left e -> return (Left e) - Right myrole -> sendpkt rolePkt myrole $ - sendpkt versionPkt (Version "2") $ do - sendflush - 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 - writePktLine output pkt - cnt - Nothing -> return $ Left $ - "failed constructing pkt-line packet for: " ++ show v - - sendflush = do - writePktLine output flushPkt - hFlush output - - sendpkts _ [] cnt = do - sendflush - 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 = filter selectcapability caps - sendpkts capabilityPkt mycaps $ - cnt mycaps - -formatKV :: String -> (v -> String) -> v -> Maybe PktLine -formatKV k f v = stringPktLine $ k <> "=" <> f v - -parseKV :: String -> (String -> v) -> PktLine -> Maybe v -parseKV k mkv = go . pktLineString - where - kprefix = k <> "=" - go t - | kprefix `isPrefixOf` t = Just $ mkv $ - drop (length kprefix) t - | otherwise = Nothing - diff --git a/Git/Protocol/PktLine.hs b/Git/Protocol/PktLine.hs deleted file mode 100644 index e1adca5a28..0000000000 --- a/Git/Protocol/PktLine.hs +++ /dev/null @@ -1,161 +0,0 @@ -{- Git pkt-line format, as documented in - - git/Documentation/technical/protocol-common.txt - - - - Copyright 2018 Joey Hess - - - - Licensed under the GNU GPL version 3 or higher. - -} - -{-# LANGUAGE OverloadedStrings #-} - -module Git.Protocol.PktLine ( - PktLine, - flushPkt, - stringPktLine, - pktLineString, - streamPktLine, - encodePktLine, - parsePktLine, - decodePktLine, - splitPktLine, - readPktLine, - writePktLine, -) where - -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L -import Data.Attoparsec.ByteString as A -import Data.Attoparsec.ByteString.Char8 as A -import Data.Attoparsec.ByteString.Lazy as AL -import Data.ByteString.Builder -import Data.Monoid -import Data.Word -import System.IO - -import Utility.PartialPrelude -import Utility.FileSystemEncoding - --- | 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, Eq) - --- | Maximum data that can be contained in a pkt-line, not --- including the 4 byte length header. -maxPktLineContent :: Word16 -maxPktLineContent = 65516 - --- | Maximum length of a pkt-line, including the 4 byte size header. -maxPktLineLength :: Word16 -maxPktLineLength = 65520 - --- | The flush-pkt, a special case in the protocol that is often used to --- eg, signal the end of a stream of binary data. -flushPkt :: PktLine -flushPkt = PktLine S.empty - --- | Encodes a String as a PktLine. Fails if the String is too large. --- --- A trailing newline is included after it, as the protocol recommends --- doing for non-binary data. -stringPktLine :: String -> Maybe PktLine -stringPktLine s = - let b = encodeBSS s <> "\n" - in if S.length b > fromIntegral maxPktLineContent - then Nothing - else Just (PktLine b) - --- | Extracts a String from a PktLine. Any trailing newline is removed. -pktLineString :: PktLine -> String -pktLineString (PktLine b) = - let s = decodeBSS b - in if end s == "\n" - then beginning s - else s - --- | Creates a stream of PktLines encoding a lazy ByteString of any size. --- Note that the stream is not terminated with a flushPkt. -streamPktLine :: L.ByteString -> [PktLine] -streamPktLine l = - let (chunk, rest) = L.splitAt (fromIntegral maxPktLineContent) l - pktline = PktLine $ mconcat $ L.toChunks chunk - in if L.null rest - then pktline : [] - else pktline : streamPktLine rest - --- | ByteString builder for a pkt-line. -encodePktLine :: PktLine -> Builder -encodePktLine (PktLine b) - -- Avoid sending an empty pkt-line; send a flush-pkt instead. - | S.null b = "0000" - | otherwise = lengthheader <> byteString b - where - -- The length header is always 4 bytes long, and includes - -- itself in its length. - lengthheader = word16HexFixed (fromIntegral (S.length b) + 4) - --- | Attoparsec parser for a pkt-line. -parsePktLine :: Parser PktLine -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 - -- Attoparsec's hexidecimal parser will consume any amount - -- of hex, but the length header is limited to 4 bytes, so - -- take those and parse only them. - h <- A.take 4 - -- Require all 4 bytes to be hexidecimal by using endOfInput. - case parseOnly (hexadecimal <* endOfInput) h of - Left e -> fail e - Right len - | len > fromIntegral maxPktLineLength -> - fail "pkt-line too long" - | otherwise -> return len - --- | The ByteString must contain only a pkt-line with no additional data --- or this will fail. -decodePktLine :: S.ByteString -> Either String PktLine -decodePktLine = parseOnly (parsePktLine <* endOfInput) - --- | Split the next PktLine from a lazy ByteString, returning it and the --- remainder of the ByteString. -splitPktLine :: L.ByteString -> Either String (PktLine, L.ByteString) -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 - --- | Sends a packet to the Handle. Does not flush the Handle. -writePktLine :: Handle -> PktLine -> IO () -writePktLine h = hPutBuilder h . encodePktLine diff --git a/git-annex.cabal b/git-annex.cabal index 1ec9852138..86f626a438 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -847,8 +847,6 @@ Executable git-annex Git.LsTree Git.Merge Git.Objects - Git.Protocol.LongRunningProcess - Git.Protocol.PktLine Git.Queue Git.Ref Git.RefLog