fb3b9412e4
It might even work, although nothing yet triggers XMPP pushes. Also added a set of deferred push messages. Only one push can run at a time, and unrelated push messages get deferred. The set will never grow very large, because it only puts two types of messages in there, that can only vary in the client doing the push.
235 lines
6.9 KiB
Haskell
235 lines
6.9 KiB
Haskell
{- git over XMPP
|
|
-
|
|
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
module Assistant.XMPP.Git where
|
|
|
|
import Assistant.Common
|
|
import Assistant.NetMessager
|
|
import Assistant.Types.NetMessager
|
|
import Assistant.XMPP
|
|
import Assistant.XMPP.Buddies
|
|
import Assistant.DaemonStatus
|
|
import Assistant.Alert
|
|
import Assistant.MakeRemote
|
|
import Assistant.Sync
|
|
import Annex.UUID
|
|
import Config
|
|
import Git
|
|
import Git.Command
|
|
import qualified Git.Branch
|
|
import qualified Annex.Branch
|
|
import Locations.UserConfig
|
|
import qualified Types.Remote as Remote
|
|
|
|
import Network.Protocol.XMPP
|
|
import qualified Data.Text as T
|
|
import System.Posix.Env
|
|
import System.Posix.Types
|
|
import System.Process (std_in, std_out, std_err)
|
|
import Control.Concurrent
|
|
import qualified Data.ByteString as B
|
|
|
|
configKey :: UnqualifiedConfigKey
|
|
configKey = "xmppaddress"
|
|
|
|
finishXMPPPairing :: JID -> UUID -> Assistant ()
|
|
finishXMPPPairing jid u = void $ alertWhile alert $
|
|
makeXMPPGitRemote buddy (baseJID jid) u
|
|
where
|
|
buddy = T.unpack $ buddyName jid
|
|
alert = pairRequestAcknowledgedAlert buddy Nothing
|
|
|
|
{- A git remote for an XMPP user? This is represented as a git remote
|
|
- that has no location set. The user's XMPP address is stored in the
|
|
- xmppaddress setting.
|
|
-
|
|
- The UUID of their remote is also stored as usual.
|
|
-}
|
|
makeXMPPGitRemote :: String -> JID -> UUID -> Assistant Bool
|
|
makeXMPPGitRemote buddyname jid u = do
|
|
remote <- liftAnnex $ addRemote $ makeGitRemote buddyname "" -- no location
|
|
liftAnnex $ do
|
|
let r = Remote.repo remote
|
|
storeUUID (remoteConfig r "uuid") u
|
|
setConfig (remoteConfig r configKey) xmppaddress
|
|
syncNewRemote remote
|
|
return True
|
|
where
|
|
xmppaddress = T.unpack $ formatJID $ baseJID jid
|
|
|
|
{- Pushes the named refs to the remote, over XMPP, communicating with a
|
|
- specific client that either requested the push, or responded to our
|
|
- StartingPush message.
|
|
-
|
|
- Strategy: Set GIT_SSH to run git-annex. By setting the remote url
|
|
- to "xmppgit:dummy", "git-annex xmppgit" will be run locally by
|
|
- "git push". The dataflow them becomes:
|
|
-
|
|
- git push <--> git-annex xmppgit <--> xmppPush <-------> xmpp
|
|
- |
|
|
- git receive-pack <--> xmppReceivePack <---------------> xmpp
|
|
-
|
|
- The pipe between git-annex xmppgit and us is set up and communicated
|
|
- using two file descriptors, GIT_ANNEX_XMPPGIT_IN and
|
|
- GIT_ANNEX_XMPPGIT_OUT. It simply connects those up to its stdin
|
|
- and stdout, respectively, which are in turn connected to "git-push".
|
|
- There is also a GIT_ANNEX_XMPPGIT_CONTROL descriptor, to which an
|
|
- exit status is sent for xmppgit to propigate.
|
|
-
|
|
- We listen at the other end of the pipe and relay to and from XMPP.
|
|
-}
|
|
xmppPush :: ClientID -> Remote -> [Ref] -> Assistant Bool
|
|
xmppPush cid remote refs = runPush (SendPushRunning cid) handleDeferred $ do
|
|
sendNetMessage $ StartingPush cid
|
|
program <- liftIO readProgramFile
|
|
|
|
(Fd inf, writepush) <- liftIO createPipe
|
|
(readpush, Fd outf) <- liftIO createPipe
|
|
(Fd controlf, writecontrol) <- liftIO createPipe
|
|
|
|
env <- liftIO getEnvironment
|
|
let myenv =
|
|
[ ("GIT_SSH", program)
|
|
, (relayIn, show inf)
|
|
, (relayOut, show outf)
|
|
, (relayControl, show controlf)
|
|
]
|
|
g <- liftAnnex gitRepo
|
|
let name = Remote.name remote
|
|
let mainparams = [Param "-c", Param $ "remote."++name++".url=xmpp:client"]
|
|
let params = Param "push" : Param name : map (Param . show) refs
|
|
|
|
inh <- liftIO $ fdToHandle readpush
|
|
outh <- liftIO $ fdToHandle writepush
|
|
controlh <- liftIO $ fdToHandle writecontrol
|
|
liftIO $ hSetBuffering outh NoBuffering
|
|
|
|
t1 <- forkIO <~> toxmpp inh
|
|
t2 <- forkIO <~> fromxmpp outh controlh
|
|
|
|
ok <- liftIO $ boolSystemEnv "git"
|
|
(mainparams ++ gitCommandLine params g)
|
|
(Just $ env ++ myenv)
|
|
liftIO $ mapM_ killThread [t1, t2]
|
|
return ok
|
|
where
|
|
toxmpp inh = forever $ do
|
|
b <- liftIO $ B.hGetSome inh 1024
|
|
if B.null b
|
|
then liftIO $ killThread =<< myThreadId
|
|
else sendNetMessage $ SendPackOutput cid b
|
|
fromxmpp outh controlh = forever $ do
|
|
m <- waitNetPushMessage
|
|
case m of
|
|
(ReceivePackOutput _ b) -> liftIO $ B.hPut outh b
|
|
(ReceivePackDone _ exitcode) -> do
|
|
liftIO $ hPutStrLn controlh (show exitcode)
|
|
_ -> noop
|
|
|
|
relayIn :: String
|
|
relayIn = "GIT_ANNEX_XMPPGIT_IN"
|
|
|
|
relayOut :: String
|
|
relayOut = "GIT_ANNEX_XMPPGIT_OUT"
|
|
|
|
relayControl :: String
|
|
relayControl = "GIT_ANNEX_XMPPGIT_CONTROL"
|
|
|
|
relayHandle :: String -> IO Handle
|
|
relayHandle var = do
|
|
v <- getEnv var
|
|
case readish =<< v of
|
|
Nothing -> error $ var ++ " not set"
|
|
Just n -> fdToHandle $ Fd n
|
|
|
|
{- Called by git-annex xmppgit. -}
|
|
xmppGitRelay :: IO ()
|
|
xmppGitRelay = do
|
|
inh <- relayHandle relayIn
|
|
outh <- relayHandle relayOut
|
|
|
|
hSetBuffering outh NoBuffering
|
|
|
|
{- Is it possible to set up pipes and not need to copy the data
|
|
- ourselves? See splice(2) -}
|
|
void $ forkIO $ forever $ do
|
|
b <- B.hGetSome inh 1024
|
|
when (B.null b) $
|
|
killThread =<< myThreadId
|
|
B.hPut stdout b
|
|
void $ forkIO $ forever $ B.hGetSome stdin 1024 >>= B.hPut outh
|
|
|
|
controlh <- relayHandle relayControl
|
|
s <- hGetLine controlh
|
|
exitWith $ case readish s of
|
|
Just n
|
|
| n == 0 -> ExitSuccess
|
|
| otherwise -> ExitFailure n
|
|
Nothing -> ExitFailure 1
|
|
|
|
{- Relays git receive-pack stdin and stdout via XMPP, as well as propigating
|
|
- its exit status to XMPP. -}
|
|
xmppReceivePack :: ClientID -> Assistant Bool
|
|
xmppReceivePack cid = runPush (ReceivePushRunning cid) handleDeferred $ do
|
|
feeder <- asIO1 toxmpp
|
|
reader <- asIO1 fromxmpp
|
|
sendexitcode <- asIO1 $ sendNetMessage . ReceivePackDone cid
|
|
repodir <- liftAnnex $ fromRepo repoPath
|
|
let p = (proc "git" ["receive-pack", repodir])
|
|
{ std_in = CreatePipe
|
|
, std_out = CreatePipe
|
|
, std_err = Inherit
|
|
}
|
|
liftIO $ do
|
|
(Just inh, Just outh, _, pid) <- createProcess p
|
|
feedertid <- forkIO $ feeder outh
|
|
void $ reader inh
|
|
code <- waitForProcess pid
|
|
void $ sendexitcode code
|
|
killThread feedertid
|
|
return $ code == ExitSuccess
|
|
where
|
|
toxmpp outh = do
|
|
b <- liftIO $ B.hGetSome outh 1024
|
|
if B.null b
|
|
then return () -- EOF
|
|
else do
|
|
sendNetMessage $ ReceivePackOutput cid b
|
|
toxmpp outh
|
|
fromxmpp inh = forever $ do
|
|
m <- waitNetPushMessage
|
|
case m of
|
|
(SendPackOutput _ b) -> liftIO $ B.hPut inh b
|
|
_ -> noop
|
|
|
|
xmppRemotes :: ClientID -> Assistant [Remote]
|
|
xmppRemotes cid = case baseJID <$> parseJID cid of
|
|
Nothing -> return []
|
|
Just jid -> do
|
|
rs <- syncRemotes <$> getDaemonStatus
|
|
let want = T.unpack $ formatJID jid
|
|
liftAnnex $ filterM (matching want) rs
|
|
where
|
|
matching want r = do
|
|
v <- getRemoteConfig (Remote.repo r) configKey ""
|
|
return $ v == want
|
|
|
|
handleDeferred :: NetMessage -> Assistant ()
|
|
handleDeferred = void . handlePush
|
|
|
|
handlePush :: NetMessage -> Assistant Bool
|
|
handlePush (PushRequest cid) = do
|
|
rs <- xmppRemotes cid
|
|
current <- liftAnnex $ inRepo Git.Branch.current
|
|
let refs = catMaybes [current, Just Annex.Branch.fullname]
|
|
any id <$> (forM rs $ \r -> xmppPush cid r refs)
|
|
handlePush (StartingPush cid) = do
|
|
rs <- xmppRemotes cid
|
|
if null rs
|
|
then return False
|
|
else xmppReceivePack cid
|
|
handlePush _ = return False
|