more roster stubs and some readibility edits

1 files changed, 72 insertions, 15 deletions

diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs
index f25d3261..7b01711e 100644
--- a/Presence/XMPP.hs
+++ b/Presence/XMPP.hs
@@ -366,10 +366,10 @@ getRoster session iqid = do
     xmlify solicited stype set = flip concatMap (Set.toList set) 
       $ \jid -> 
         [ EventBeginElement "item" 
-            ([("jid",[ContentText (toStrict . L.decodeUtf8 $ jid)])
-             ,("subscription",[ContentText stype])
+            ([ attr "jid" (toStrict . L.decodeUtf8 $ jid)
+             , attr "subscription" stype
              ]++if Set.member jid solicited 
-                 then [("ask",[ContentText "subscribe"])] 
+                 then [attr "ask" "subscribe"]
                  else [] )
         , EventEndElement "item"
         ] 
@@ -390,11 +390,11 @@ handleIQGet session cmdChan tag = do
             let mjid = lookupAttrib "from" (tagAttrs tag)
             let pong = [ EventBeginElement "{jabber:client}iq" 
                          $ (case mjid of
-                             Just jid -> (("to",[ContentText jid]):)
-                             _        -> id)
-                             [("type",[ContentText "result"])
-                             ,("id",[ContentText stanza_id])
-                             ,("from",[ContentText host])
+                             Just jid -> (attr "to" jid :)
+                             _        -> id               )
+                             [ attr "type" "result"
+                             , attr "id"   stanza_id
+                             , attr "from" host
                              ]
                       , EventEndElement "{jabber:client}iq"
                       ]
@@ -442,6 +442,10 @@ fromClient session cmdChan = doNestingXML $ do
             case () of
              _ | stanza `isIQOf` iqTypeSet -> handleIQSet session cmdChan stanza
              _ | stanza `isIQOf` iqTypeGet -> handleIQGet session cmdChan stanza
+             _ | stanza `isPresenceOf` presenceTypeSubscribe 
+                                           -> clientRequestsSubscription session stanza
+             _ | stanza `isPresenceOf` presenceTypeSubscribed
+                                           -> clientApprovesSubscription session stanza
              _ | otherwise                 -> unhandledStanza
 
             awaitCloser stanza_lvl
@@ -597,6 +601,8 @@ matchAttribMaybe name Nothing attrs
 presenceTypeOffline = Just "unavailable"
 presenceTypeOnline  = Nothing
 presenceTypeProbe   = Just "probe"
+presenceTypeSubscribe = Just "subscribe"
+presenceTypeSubscribed = Just "subscribed"
 
 isPresenceOf (EventBeginElement name attrs) testType
     | name=="{jabber:server}presence"
@@ -624,6 +630,53 @@ handlePresenceProbe session stanza = do
                 mapM_ (announcePresence session) ps
     return ()
 
+subscribeToPresence subscribers peer_jid user = do
+    pjid <- parseAddressJID peer_jid
+    if Set.member pjid subscribers
+        then return ()
+        else return ()
+
+bare (JID n host _) = JID n host Nothing
+
+clientRequestsSubscription session stanza = do
+    -- make bare jid
+    -- check local server and obey rules 3.1.3 of rfc 6121
+    -- or forward to remote peer
+    -- or bail with type='error' as shown in 3.1.2
+    -- if not bailed,
+    --  add to solicited
+    --  do roster push with subscription=none ask=subscribe
+    liftIO $ putStrLn $ "CLIENT PRESENCE SUBSCRIBE " ++ show stanza
+    -- add solicited
+    -- notify other clients
+    -- notify peer
+    return ()
+
+peerRequestsSubsription session stanza = do
+    liftIO $ putStrLn $ "PEER PRESENCE SUBSCRIBE " ++ show stanza
+    -- if no client:
+    --   add pending
+    -- else:
+    --   notify client
+    return ()
+
+clientApprovesSubscription session stanza = do
+    liftIO $ putStrLn $ "CLIENT APPROVES SUBSCRIPTION"
+    -- add subscribers
+    -- remove pending
+    -- remove others
+    -- notify peer
+    return ()
+
+peerApprovesSubscription session stanza = do
+    liftIO $ putStrLn $ "PEER APPROVES SUBSCRIPTION"
+    -- if solicited:
+    --   add buddies
+    --   remove others
+    --   remove solicited
+    --   notify client
+    return ()
+
 fromPeer :: (MonadThrow m,MonadIO m, JabberPeerSession session) => 
     session -> Sink XML.Event m ()
 fromPeer session = doNestingXML $ do
@@ -650,6 +703,10 @@ fromPeer session = doNestingXML $ do
                     -> handlePeerPresence session stanza False
               _ | stanza `isPresenceOf` presenceTypeProbe
                     -> handlePresenceProbe session stanza
+              _ | stanza `isPresenceOf` presenceTypeSubscribe
+                    -> peerRequestsSubsription session stanza
+              _ | stanza `isPresenceOf` presenceTypeSubscribed
+                    -> peerApprovesSubscription session stanza
               _ -> unhandledStanza
 
             awaitCloser stanza_lvl
@@ -718,8 +775,8 @@ connect_to_server chan peer = (>> return ()) . runMaybeT $ do
 greetPeer =
     [ EventBeginDocument
     , EventBeginElement (streamP "stream")
-        [("xmlns",[ContentText "jabber:server"])
-        ,("version",[ContentText "1.0"])
+        [ attr "xmlns"   "jabber:server"
+        , attr "version" "1.0"
         ]
     ]
 
@@ -740,9 +797,9 @@ presenceProbe sock fromjid tojid = do
                 <?++> showPeer (peer tojid)
     return 
       [ EventBeginElement "{jabber:server}presence"
-            [("from",[ContentText from])
-            ,("to",[ContentText to])
-            ,("type",[ContentText "probe"])
+            [ attr "from" from
+            , attr "to"   to
+            , attr "type" "probe"
             ]
       , EventEndElement "{jabber:server}presence"
       ]
@@ -932,14 +989,14 @@ xmlifyPresenceForPeer sock (Presence jid stat) = do
                   $ n <$++> "@" <?++> showPeer (RemotePeer addr) <++?>  "/" <++$> rsc 
     return 
       [ EventBeginElement "{jabber:server}presence" 
-            (("from",[ContentText jidstr]):typ stat)
+            (attr "from" jidstr:typ stat)
       , EventBeginElement "{jabber:server}show" []
       , EventContent (ContentText . shw $ stat)
       , EventEndElement "{jabber:server}show"
       , EventEndElement "{jabber:server}presence"
       ]
  where
-    typ Offline = [("type",[ContentText "unavailable"])]
+    typ Offline = [attr "type" "unavailable"]
     typ _       = []
     shw Available = "chat"
     shw Away      = "away"