moving to filterdriver branch

Not used in master, so remove until/unless filterdriver branch is
merged.
This commit is contained in:
Joey Hess 2018-08-14 13:37:17 -04:00
parent 63cfc1a615
commit 42c5d7c64f
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
3 changed files with 0 additions and 304 deletions

View file

@ -1,141 +0,0 @@
{- 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 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

View file

@ -1,161 +0,0 @@
{- Git pkt-line format, as documented in
- git/Documentation/technical/protocol-common.txt
-
- Copyright 2018 Joey Hess <id@joeyh.name>
-
- 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

View file

@ -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