diff options
author | 2012-10-24 15:42:02 -0400 | |
---|---|---|
committer | 2012-10-24 15:42:02 -0400 | |
commit | e61eabc176e145deed2572efff3e1c22c0939b79 (patch) | |
tree | 3f219e8abb3a320f4db66122aeadaab72c671218 /Assistant | |
parent | 74bfce98180d93ac84fea5ca383d981d773e2e50 (diff) |
initial implementation of XMPP push notifier (untested)
Lacking error handling, reconnection, credentials configuration,
and doesn't actually do anything when it receives an incoming notification.
Other than that, it might work! :)
Diffstat (limited to 'Assistant')
-rw-r--r-- | Assistant/Pushes.hs | 14 | ||||
-rw-r--r-- | Assistant/Sync.hs | 4 | ||||
-rw-r--r-- | Assistant/Threads/PushNotifier.hs | 119 |
3 files changed, 122 insertions, 15 deletions
diff --git a/Assistant/Pushes.hs b/Assistant/Pushes.hs index 649975fd1..7842c1884 100644 --- a/Assistant/Pushes.hs +++ b/Assistant/Pushes.hs @@ -8,9 +8,9 @@ module Assistant.Pushes where import Common.Annex +import Utility.TSet import Control.Concurrent.STM -import Control.Concurrent.MSampleVar import Data.Time.Clock import qualified Data.Map as M @@ -19,7 +19,7 @@ type PushMap = M.Map Remote UTCTime type FailedPushMap = TMVar PushMap {- Used to notify about successful pushes. -} -newtype PushNotifier = PushNotifier (MSampleVar ()) +newtype PushNotifier = PushNotifier (TSet UUID) {- The TMVar starts empty, and is left empty when there are no - failed pushes. This way we can block until there are some failed pushes. @@ -50,10 +50,10 @@ changeFailedPushMap v a = atomically $ | otherwise = putTMVar v $! m newPushNotifier :: IO PushNotifier -newPushNotifier = PushNotifier <$> newEmptySV +newPushNotifier = PushNotifier <$> newTSet -notifyPush :: PushNotifier -> IO () -notifyPush (PushNotifier sv) = writeSV sv () +notifyPush :: [UUID] -> PushNotifier -> IO () +notifyPush us (PushNotifier s) = putTSet s us -waitPush :: PushNotifier -> IO () -waitPush (PushNotifier sv) = readSV sv +waitPush :: PushNotifier -> IO [UUID] +waitPush (PushNotifier s) = getTSet s diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs index e333877f2..f9a513d94 100644 --- a/Assistant/Sync.hs +++ b/Assistant/Sync.hs @@ -101,7 +101,7 @@ pushToRemotes threadname now st mpushnotifier mpushmap remotes = do let ok = null failed if ok then do - maybe noop notifyPush mpushnotifier + maybe noop (notifyPush $ map Remote.uuid succeeded) mpushnotifier return ok else if shouldretry then retry branch g u failed @@ -127,7 +127,7 @@ pushToRemotes threadname now st mpushnotifier mpushmap remotes = do (succeeded, failed) <- inParallel (pushfallback g u branch) rs updatemap succeeded failed unless (null succeeded) $ - maybe noop notifyPush mpushnotifier + maybe noop (notifyPush $ map Remote.uuid succeeded) mpushnotifier return $ null failed push g branch remote = Command.Sync.pushBranch remote branch g diff --git a/Assistant/Threads/PushNotifier.hs b/Assistant/Threads/PushNotifier.hs index cc5309712..12cbb3206 100644 --- a/Assistant/Threads/PushNotifier.hs +++ b/Assistant/Threads/PushNotifier.hs @@ -1,4 +1,7 @@ -{- git-annex assistant push notification thread +{- git-annex assistant push notification thread, using XMPP + - + - This handles both sending outgoing push notifications, and receiving + - incoming push notifications. - - Copyright 2012 Joey Hess <joey@kitenet.net> - @@ -8,14 +11,118 @@ module Assistant.Threads.PushNotifier where import Assistant.Common +import Assistant.ThreadedMonad +import Assistant.DaemonStatus import Assistant.Pushes +import qualified Remote + +import Network.Protocol.XMPP +import Network +import Control.Concurrent +import qualified Data.Text as T +import qualified Data.Set as S +import Utility.FileMode thisThread :: ThreadName thisThread = "PushNotifier" -pushNotifierThread :: PushNotifier -> NamedThread -pushNotifierThread pushnotifier = thread $ forever $ do - waitPush pushnotifier - -- TODO +pushNotifierThread :: ThreadState -> DaemonStatusHandle -> PushNotifier -> NamedThread +pushNotifierThread st dstatus pushnotifier = NamedThread thisThread $ do + v <- runThreadState st $ getXMPPCreds + case v of + Nothing -> nocreds + Just c -> case parseJID (xmppUsername c) of + Nothing -> nocreds + Just jid -> void $ client c jid + where + nocreds = do + -- TODO alert + return () -- exit thread + + client c jid = runClient server jid (xmppUsername c) (xmppPassword c) $ do + void $ bindJID jid + void $ putStanza $ emptyPresence PresenceUnavailable + s <- getSession + _ <- liftIO $ forkIO $ void $ sendnotifications s + receivenotifications + where + server = Server + (JID Nothing (jidDomain jid) Nothing) + (xmppHostname c) + (PortNumber $ fromIntegral $ xmppPort c) + + sendnotifications session = runXMPP session $ forever $ do + us <- liftIO $ waitPush pushnotifier + {- Toggle presence to send the notification. -} + putStanza $ (emptyPresence PresenceAvailable) + { presenceID = Just $ encodePushNotification us } + putStanza $ emptyPresence PresenceUnavailable + + receivenotifications = forever $ do + s <- getStanza + case s of + ReceivedPresence (Presence { presenceType = PresenceAvailable, presenceID = Just t }) -> + maybe noop (liftIO . pull dstatus) + (decodePushNotification t) + _ -> noop + +{- Everything we need to know to connect to an XMPP server. -} +data XMPPCreds = XMPPCreds + { xmppUsername :: T.Text + , xmppPassword :: T.Text + , xmppHostname :: HostName + , xmppPort :: Int + } + deriving (Read, Show) + +getXMPPCreds :: Annex (Maybe XMPPCreds) +getXMPPCreds = do + f <- xmppCredsFile + s <- liftIO $ catchMaybeIO $ readFile f + return $ readish =<< s + +setXMPPCreds :: XMPPCreds -> Annex () +setXMPPCreds creds = do + f <- xmppCredsFile + liftIO $ do + h <- openFile f WriteMode + modifyFileMode f $ removeModes + [groupReadMode, otherReadMode] + hPutStr h (show creds) + hClose h + +xmppCredsFile :: Annex FilePath +xmppCredsFile = do + dir <- fromRepo gitAnnexCredsDir + return $ dir </> "notify-xmpp" + +{- A push notification is encoded in the id field of an XMPP presence + - notification, in the form: "git-annex-push:uuid[:uuid:...] + - + - Git repos can be pushed to that do not have a git-annex uuid; an empty + - string is used for those. + -} +prefix :: T.Text +prefix = T.pack "git-annex-push:" + +delim :: T.Text +delim = T.pack ":" + +encodePushNotification :: [UUID] -> T.Text +encodePushNotification us = T.concat + [ prefix + , T.intercalate delim $ map (T.pack . fromUUID) us + ] + +decodePushNotification :: T.Text -> Maybe [UUID] +decodePushNotification t = map (toUUID . T.unpack) . T.splitOn delim + <$> T.stripPrefix prefix t + +pull :: DaemonStatusHandle -> [UUID] -> IO () +pull _ [] = noop +pull dstatus us = do + rs <- filter matching . syncRemotes <$> getDaemonStatus dstatus + print ("TODO pull from", rs) where - thread = NamedThread thisThread + matching r = Remote.uuid r `S.member` s + s = S.fromList us |