git long-running filter process implementation

This module is not used yet, but the plan is to use it for smudge/clean
filtering, at least as an option. In some circumstances, using this
interface may perform better than the interface git-annex is currently
using.

Sponsored-by: Brock Spratlen on Patreon

diff --git a/Git/FilterProcess.hs b/Git/FilterProcess.hs
new file mode 100644 (file)
index 0000000..3dcafb3
--- /dev/null
+++ b/Git/FilterProcess.hs
@@ -0,0 +1,186 @@
+{- git long-running filter process
+ -
+ - As documented in git's gitattributes(5) and
+ - Documentation/technical/long-running-process-protocol.txt
+ -
+ - Copyright 2021 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+{-# LANGUAGE OverloadedStrings #-}
+
+module Git.FilterProcess (
+       WelcomeMessage(..),
+       Version(..),
+       Capability(..),
+       readUntilFlushPkt,
+       discardUntilFlushPkt,
+       longRunningProcessHandshake,
+       longRunningFilterProcessHandshake,
+       FilterRequest(..),
+       getFilterRequest,
+) where
+
+import Common
+import Git.PktLine
+
+import System.IO
+import qualified Data.ByteString as B
+
+{- This is a message like "git-filter-client" or "git-filter-server" -}
+data WelcomeMessage = WelcomeMessage PktLine
+       deriving (Show)
+
+{- Configuration message, eg "foo=bar" -}
+data ConfigValue = ConfigValue String String
+       deriving (Show, Eq)
+
+encodeConfigValue :: ConfigValue -> PktLine
+encodeConfigValue (ConfigValue k v) = stringPktLine (k <> "=" <> v)
+
+decodeConfigValue :: PktLine -> Maybe ConfigValue
+decodeConfigValue pktline =
+       let t = pktLineToString pktline
+           (k, v) = break (== '=') t
+       in if null v
+               then Nothing
+               else Just $ ConfigValue k (drop 1 v)
+
+extractConfigValue :: [ConfigValue] -> String -> Maybe String
+extractConfigValue [] _ = Nothing
+extractConfigValue (ConfigValue k v:cs) wantk
+       | k == wantk = Just v
+       | otherwise = extractConfigValue cs wantk
+
+data Version = Version Int
+       deriving (Show, Eq)
+
+encodeVersion :: Version -> PktLine
+encodeVersion (Version n) = encodeConfigValue $ ConfigValue "version" (show n)
+
+decodeVersion :: PktLine -> Maybe Version
+decodeVersion pktline = decodeConfigValue pktline >>= \case
+       ConfigValue "version" v -> Version <$> readish v
+       _ -> Nothing
+
+data Capability = Capability String
+       deriving (Show, Eq)
+
+encodeCapability :: Capability -> PktLine
+encodeCapability (Capability c) = encodeConfigValue $ 
+       ConfigValue "capability" c
+
+decodeCapability :: PktLine -> Maybe Capability
+decodeCapability pktline = decodeConfigValue pktline >>= \case
+       ConfigValue "capability" c -> Just $ Capability c
+       _ -> Nothing
+
+{- Reads PktLines until a flushPkt (or EOF), 
+ - and returns all except the flushPkt -}
+readUntilFlushPkt :: IO [PktLine]
+readUntilFlushPkt = go []
+  where
+       go l = readPktLine stdin >>= \case
+               Just pktline | not (isFlushPkt pktline) -> go (pktline:l)
+               _ -> return (reverse l)
+
+{- Reads PktLines until a flushPkt (or EOF), and throws them away. -}
+discardUntilFlushPkt :: IO ()
+discardUntilFlushPkt = readPktLine stdin >>= \case
+       Just pktline | isFlushPkt pktline -> return ()
+       Nothing -> return ()
+       _ -> discardUntilFlushPkt
+
+longRunningProcessHandshake
+       :: (WelcomeMessage -> Maybe WelcomeMessage)
+       -> ([Version] -> [Version])
+       -> ([Capability] -> [Capability])
+       -> IO (Either String ())
+longRunningProcessHandshake respwelcomemessage filterversions filtercapabilities =
+       readUntilFlushPkt >>= \case
+               [] -> protoerr "no welcome message"
+               (welcomemessage:versions) -> 
+                       checkwelcomemessage welcomemessage $
+                               checkversion versions $ do
+                                       capabilities <- readUntilFlushPkt
+                                       checkcapabilities capabilities success
+  where
+       protoerr msg = return $ Left $ "git protocol error: " ++ msg
+       success = return (Right ())
+
+       checkwelcomemessage welcomemessage cont =
+               case respwelcomemessage (WelcomeMessage welcomemessage) of
+                       Nothing -> protoerr "unsupported welcome message"
+                       Just (WelcomeMessage welcomemessage') -> do
+                               writePktLine stdout welcomemessage'
+                               cont
+
+       checkversion versions cont = do
+               let versions' = filterversions (mapMaybe decodeVersion versions)
+               if null versions'
+                       then protoerr "unsupported protocol version"
+                       else do
+                               forM_ versions' $ \v ->
+                                       writePktLine stdout $ encodeVersion v
+                               writePktLine stdout flushPkt
+                               cont
+       
+       checkcapabilities capabilities cont = do
+               let capabilities' = filtercapabilities (mapMaybe decodeCapability capabilities)
+               if null capabilities'
+                       then protoerr "unsupported protocol capabilities"
+                       else do
+                               forM_ capabilities' $ \c ->
+                                       writePktLine stdout $ encodeCapability c
+                               writePktLine stdout flushPkt
+                               cont
+
+longRunningFilterProcessHandshake :: IO (Either String ())
+longRunningFilterProcessHandshake =
+       longRunningProcessHandshake respwelcomemessage filterversions filtercapabilities
+  where
+       respwelcomemessage (WelcomeMessage w)
+               | pktLineToString w == "git-filter-client" =
+                       Just $ WelcomeMessage $ stringPktLine "git-filter-server"
+               | otherwise = Nothing
+       filterversions = filter (== Version 2)
+       -- Delay capability is not implemented, so filter it out.
+       filtercapabilities = filter (`elem` [Capability "smudge", Capability "clean"])
+
+data FilterRequest = Smudge FilePath | Clean FilePath
+       deriving (Show, Eq)
+
+{- Waits for the next FilterRequest to be received. Does not read
+ - the content to be filtered, which is what gets sent subsequent to the
+ - FilterRequest. Use eg readUntilFlushPkt to read it, before calling
+ - respondFilterRequest. -}
+getFilterRequest :: IO (Maybe FilterRequest)
+getFilterRequest = do
+       ps <- readUntilFlushPkt
+       let cs = mapMaybe decodeConfigValue ps
+       case (extractConfigValue cs "command", extractConfigValue cs "pathname") of
+               (Just command, Just pathname)
+                       | command == "smudge" -> return $ Just $ Smudge pathname
+                       | command == "clean" -> return $ Just $ Clean pathname
+                       | otherwise -> return Nothing
+               _ -> return Nothing
+
+{- Send a response to a FilterRequest, consisting of the filtered content. -}
+respondFilterRequest :: B.ByteString -> IO ()
+respondFilterRequest b = do
+       writePktLine stdout $ encodeConfigValue $ ConfigValue "status" "success"
+       writePktLine stdout flushPkt
+       send b
+       -- The protocol allows for another list of ConfigValues to be sent
+       -- here, but we don't use it. Send another flushPkt to terminate
+       -- the empty list.
+       writePktLine stdout flushPkt
+  where
+       send b' = 
+               let (pktline, rest) = encodePktLine b'
+               in do
+                       writePktLine stdout pktline
+                       case rest of
+                               Just b'' -> send b''
+                               Nothing -> writePktLine stdout flushPkt