mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

make --debug show transcript of special remote protocol messages

Browse source
This commit is contained in:
Joey Hess 2013-12-27 03:10:00 -04:00
parent 526a7bb2b4
commit 5d8ff64dc1
2 changed files with 16 additions and 1 deletions
Download patch file Download diff file Expand all files Collapse all files

15
Remote/External.hs
View file

@ -25,6 +25,7 @@ import Annex.Exception
import Control.Concurrent.STM import Control.Concurrent.STM
import System.Process (std_in, std_out, std_err) import System.Process (std_in, std_out, std_err)
import System.Log.Logger (debugM)
import qualified Data.Map as M import qualified Data.Map as M
remote :: RemoteType remote :: RemoteType
@ -194,7 +195,11 @@ handleRequest' lck external req mp responsehandler = do
sendMessage :: Sendable m => ExternalLock -> External -> m -> Annex () sendMessage :: Sendable m => ExternalLock -> External -> m -> Annex ()
sendMessage lck external m = sendMessage lck external m =
fromExternal lck external externalSend $ \h -> fromExternal lck external externalSend $ \h ->
liftIO $ hPutStrLn h $ unwords $ formatMessage m liftIO $ do
protocolDebug external True line
hPutStrLn h line
where
line = unwords $ formatMessage m
{- Waits for a message from the external remote, and passes it to the {- Waits for a message from the external remote, and passes it to the
- apppropriate handler. - apppropriate handler.
@ -209,6 +214,7 @@ receiveMessage
-> Annex a -> Annex a
receiveMessage lck external handleresponse handlerequest handleasync = do receiveMessage lck external handleresponse handlerequest handleasync = do
s <- fromExternal lck external externalReceive $ liftIO . hGetLine s <- fromExternal lck external externalReceive $ liftIO . hGetLine
liftIO $ protocolDebug external False s
case parseMessage s :: Maybe Response of case parseMessage s :: Maybe Response of
Just resp -> maybe (protocolError s) id (handleresponse resp) Just resp -> maybe (protocolError s) id (handleresponse resp)
Nothing -> case parseMessage s :: Maybe RemoteRequest of Nothing -> case parseMessage s :: Maybe RemoteRequest of
@ -219,6 +225,13 @@ receiveMessage lck external handleresponse handlerequest handleasync = do
where where
protocolError s = error $ "external special remote protocol error, unexpectedly received \"" ++ s ++ "\"" protocolError s = error $ "external special remote protocol error, unexpectedly received \"" ++ s ++ "\""
protocolDebug :: External -> Bool -> String -> IO ()
protocolDebug external sendto line = debugM "external" $ unwords
[ externalRemoteProgram (externalType external)
, if sendto then "<--" else "-->"
, line
]
{- Starts up the external remote if it's not yet running, {- Starts up the external remote if it's not yet running,
- and passes a value extracted from its state to an action. - and passes a value extracted from its state to an action.
-} -}

2
doc/special_remotes/external.mdwn
View file

@ -14,6 +14,8 @@ It's not hard!
* Install it in PATH. * Install it in PATH.
* When the user runs `git annex initremote foo type=external externaltype=$bar`, * When the user runs `git annex initremote foo type=external externaltype=$bar`,
it will use your program. it will use your program.
* If things don't seem to work, pass `--debug` and you'll see, amoung other
things, a transcript of git-annex's communication with your program.
* If you build a new special remote, please add it to the list * If you build a new special remote, please add it to the list
of [[special_remotes]]. of [[special_remotes]].