moving to filterdriver branch
Not used in master, so remove until/unless filterdriver branch is merged.
This commit is contained in:
Joey Hess
parent
63cfc1a615
commit
42c5d7c64f
3 changed files with 0 additions and 304 deletions
|
|
@ -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
|
||||
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue