diff options
Diffstat (limited to 'Assistant/Threads/XMPPPusher.hs')
| -rw-r--r-- | Assistant/Threads/XMPPPusher.hs | 82 |
1 files changed, 0 insertions, 82 deletions
diff --git a/Assistant/Threads/XMPPPusher.hs b/Assistant/Threads/XMPPPusher.hs deleted file mode 100644 index bff17356d..000000000 --- a/Assistant/Threads/XMPPPusher.hs +++ /dev/null @@ -1,82 +0,0 @@ -{- git-annex XMPP pusher threads - - - - This is a pair of threads. One handles git send-pack, - - and the other git receive-pack. Each thread can be running at most - - one such operation at a time. - - - - Why not use a single thread? Consider two clients A and B. - - If both decide to run a receive-pack at the same time to the other, - - they would deadlock with only one thread. For larger numbers of - - clients, the two threads are also sufficient. - - - - Copyright 2013 Joey Hess <id@joeyh.name> - - - - Licensed under the GNU GPL version 3 or higher. - -} - -module Assistant.Threads.XMPPPusher where - -import Assistant.Common -import Assistant.NetMessager -import Assistant.Types.NetMessager -import Assistant.WebApp (UrlRenderer) -import Assistant.WebApp.Configurators.XMPP (checkCloudRepos) -import Assistant.XMPP.Git - -import Control.Exception as E - -xmppSendPackThread :: UrlRenderer -> NamedThread -xmppSendPackThread = pusherThread "XMPPSendPack" SendPack - -xmppReceivePackThread :: UrlRenderer -> NamedThread -xmppReceivePackThread = pusherThread "XMPPReceivePack" ReceivePack - -pusherThread :: String -> PushSide -> UrlRenderer -> NamedThread -pusherThread threadname side urlrenderer = namedThread threadname $ go Nothing - where - go lastpushedto = do - msg <- waitPushInitiation side $ selectNextPush lastpushedto - debug ["started running push", logNetMessage msg] - - runpush <- asIO $ runPush checker msg - r <- liftIO (E.try runpush :: IO (Either SomeException (Maybe ClientID))) - let successful = case r of - Right (Just _) -> True - _ -> False - - {- Empty the inbox, because stuff may have - - been left in it if the push failed. -} - let justpushedto = getclient msg - maybe noop (`emptyInbox` side) justpushedto - - debug ["finished running push", logNetMessage msg, show successful] - go $ if successful then justpushedto else lastpushedto - - checker = checkCloudRepos urlrenderer - - getclient (Pushing cid _) = Just cid - getclient _ = Nothing - -{- Select the next push to run from the queue. - - The queue cannot be empty! - - - - We prefer to select the most recently added push, because its requestor - - is more likely to still be connected. - - - - When passed the ID of a client we just pushed to, we prefer to not - - immediately push again to that same client. This avoids one client - - drowing out others. So pushes from the client we just pushed to are - - relocated to the beginning of the list, to be processed later. - -} -selectNextPush :: Maybe ClientID -> [NetMessage] -> (NetMessage, [NetMessage]) -selectNextPush _ (m:[]) = (m, []) -- common case -selectNextPush _ [] = error "selectNextPush: empty list" -selectNextPush lastpushedto l = go [] l - where - go (r:ejected) [] = (r, ejected) - go rejected (m:ms) = case m of - (Pushing clientid _) - | Just clientid /= lastpushedto -> (m, rejected ++ ms) - _ -> go (m:rejected) ms - go [] [] = error "empty push queue" - |