1 files changed, 113 insertions, 6 deletions

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