1 files changed, 50 insertions, 17 deletions

diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index 591acad6..05b12b73 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE ViewPatterns        #-}
+{-# LANGUAGE TupleSections       #-}
 module XMPPServer ( listenForXmppClients ) where
 
 import Data.HList.TypeEqGeneric1()
@@ -9,27 +10,25 @@ import ByteStringOperators
 
 import Server
 import Data.ByteString.Lazy.Char8 as L 
-    ( ByteString
-    , hPutStrLn
+    ( hPutStrLn
     , unlines
     , pack
-    , unpack
-    , init )
+    , unpack )
 import qualified Data.ByteString.Lazy.Char8 as L 
     ( putStrLn )
 import System.IO 
     ( Handle
     )
-import Control.Concurrent (forkIO)
-import Control.Concurrent.Chan
 import Data.HList
 import AdaptServer
 import Text.XML.HaXml.Lex (xmlLex)
-import Text.XML.HaXml.Parse  (xmlParseWith,element,doctypedecl,processinginstruction,elemOpenTag,elemCloseTag)
+import Text.XML.HaXml.Parse  (xmlParseWith,element,{-doctypedecl,-}processinginstruction,elemOpenTag,elemCloseTag)
 import Text.XML.HaXml.Types as Hax (ElemTag,QName(..),Namespace(..),Element(..),Content(..),AttValue(..))
-import qualified Text.XML.HaXml.Types as Hax (Element)
 import Data.Maybe
 import Debug.Trace
+import Control.Arrow
+import LocalPeerCred
+import Network.Socket
 
 
 
@@ -51,17 +50,21 @@ greet host = L.unlines
     , "</stream:features>"
     ]
 
-startCon st  = do
+startCon sock st  = do
     let h = hOccursFst st :: Handle 
+    cred <- getLocalPeerCred sock
+    Prelude.putStrLn $ "PEER CRED: "++show cred
+    pname <- getPeerName sock
+    Prelude.putStrLn $ "PEER NAME: "++show pname
     return (ConnectionFinalizer (return ()) .*. st)
 
-iq_query_unavailable host id mjid xmlns = L.unlines $
+iq_query_unavailable host id mjid xmlns kind = L.unlines $
     [ "<iq type='error'"
     , "    from='" <++> host <++> "'"
     , case mjid of  Just jid -> "    to='" <++> jid <++> "'"
                     Nothing  -> ""
     , "    id='" <++> id <++> "'>"
-    , "  <query xmlns='" <++> xmlns <++> "'/>"
+    , "  <" <++> kind <++> " xmlns='" <++> xmlns <++> "'/>"
     , "  <error type='cancel'>"
     , "    <service-unavailable"
     , "        xmlns='urn:ietf:params:xml:ns:xmpp-stanzas'/>"
@@ -71,6 +74,7 @@ iq_query_unavailable host id mjid xmlns = L.unlines $
 
 tagattrs tag content = Prelude.concatMap (\(CElem (Elem _ a _) _)->a) 
                           $ Prelude.filter (bindElem tag) content
+anytagattrs content = Prelude.concatMap (\(CElem (Elem n a _) _)->map (second (n,)) a) content
 
 bindElem tag (CElem (Elem (N n) _ _) _) | n==tag = True
 bindElem _   _                                   = False
@@ -132,13 +136,37 @@ iqresponse host (Elem _ attrs content) = do
                 Just (iqresult host id Nothing))
                 
       "get" -> trace ("iq-get "++show (attrs,content)) $ do
-        xmlns <- fmap pack $
-                  lookup (N "xmlns") (tagattrs "query" content) 
-                    >>= listToMaybe . astring
-        Just (iq_query_unavailable host id Nothing xmlns)
+        (tag,as) <- lookup (N "xmlns") (anytagattrs content) 
+        xmlns <- fmap pack $ listToMaybe . astring $ as
+        let servicekind = case tag of { (N s) -> pack s ; _ -> "query" }
+        case xmlns of
+            "urn:xmpp:ping" -> do
+                let to = case fmap pack (lookup (N "from") attrs >>= unattr) of
+                            Just jid -> "to='" <++> jid <++> "' "
+                            Nothing  -> ""
+                Just $ "<iq from='" <++> host <++> "' " <++> to <++> "id='" <++> id <++> "' type='result'/>"
+
+            _ -> Just (iq_query_unavailable host id Nothing xmlns servicekind)
       _ -> Nothing
     
-    
+-- <presence>
+-- <priority>1</priority>
+-- <c xmlns='http://jabber.org/protocol/caps' 
+--     node='http://pidgin.im/' 
+--     hash='sha-1' ver='lV6i//bt2U8Rm0REcX8h4F3Nk3M=' 
+--     ext='voice-v1 camera-v1 video-v1'/>
+-- <x xmlns='vcard-temp:x:update'/>
+-- </presence>
+
+presence_response host (Elem _ attrs content) = do
+    -- let id = fmap pack (lookup (N "id") attrs >>= unattr) 
+    typ <- fmap pack (lookup (N "type") attrs >>= unattr)
+    case typ of
+        "subscribe" -> do
+            -- <presence to='guest@localhost' type='subscribe'/>
+            to <- fmap pack (lookup (N "to") attrs >>= unattr)
+            Just $ "<presence to='" <++> to <++> "' type='subscribed'/>"
+        _ -> Nothing
 
 doCon st elem cont = do
         let h = hOccursFst st :: Handle 
@@ -152,8 +180,13 @@ doCon st elem cont = do
                 hsend (greet host)
             Element e@(Elem (N "iq") _ _) -> 
                 case iqresponse host e of
-                    Nothing -> trace "no respones" $ return ()
+                    Nothing -> trace "IGNORE: no response to <iq>" $ return ()
                     Just r -> hsend r
+            Element e@(Elem (N "presence") _ _) ->
+                case presence_response host e of
+                    Nothing -> trace "IGNORE: no response to <presence>" $ return ()
+                    Just r -> hsend r
+
             _ -> return () -- putStrLn $ "unhandled: "++show v
 
         putStrLn (show elem)