Moved xmpp server into module

2 files changed, 200 insertions, 0 deletions

diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
new file mode 100644
index 00000000..591acad6
--- /dev/null
+++ b/Presence/XMPPServer.hs
@@ -0,0 +1,199 @@
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ViewPatterns        #-}
+module XMPPServer ( listenForXmppClients ) where
+
+import Data.HList.TypeEqGeneric1()
+import Data.HList.TypeCastGeneric1()
+import ByteStringOperators
+
+import Server
+import Data.ByteString.Lazy.Char8 as L 
+    ( ByteString
+    , hPutStrLn
+    , unlines
+    , pack
+    , unpack
+    , init )
+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.Types as Hax (ElemTag,QName(..),Namespace(..),Element(..),Content(..),AttValue(..))
+import qualified Text.XML.HaXml.Types as Hax (Element)
+import Data.Maybe
+import Debug.Trace
+
+
+
+greet host = L.unlines 
+    [ "<?xml version='1.0'?>"
+    , "<stream:stream"
+    , "from='" <++> host <++> "'"
+    , "id='someid'"
+    , "xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/streams' version='1.0'>"
+    , "<stream:features>"
+    , "  <bind xmlns='urn:ietf:params:xml:ns:xmpp-bind'/>"
+    {-
+    -- , "  <session xmlns='urn:ietf:params:xml:ns:xmpp-session'/>"
+    , " <mechanisms xmlns='urn:ietf:params:xml:ns:xmpp-sasl'>"
+    -- , " <mechanism>DIGEST-MD5</mechanism>"
+    , " <mechanism>PLAIN</mechanism>"
+    , " </mechanisms> "
+    -}
+    , "</stream:features>"
+    ]
+
+startCon st  = do
+    let h = hOccursFst st :: Handle 
+    return (ConnectionFinalizer (return ()) .*. st)
+
+iq_query_unavailable host id mjid xmlns = L.unlines $
+    [ "<iq type='error'"
+    , "    from='" <++> host <++> "'"
+    , case mjid of  Just jid -> "    to='" <++> jid <++> "'"
+                    Nothing  -> ""
+    , "    id='" <++> id <++> "'>"
+    , "  <query xmlns='" <++> xmlns <++> "'/>"
+    , "  <error type='cancel'>"
+    , "    <service-unavailable"
+    , "        xmlns='urn:ietf:params:xml:ns:xmpp-stanzas'/>"
+    , "  </error>"
+    , "</iq>"
+    ]
+
+tagattrs tag content = Prelude.concatMap (\(CElem (Elem _ a _) _)->a) 
+                          $ Prelude.filter (bindElem tag) content
+
+bindElem tag (CElem (Elem (N n) _ _) _) | n==tag = True
+bindElem _   _                                   = False
+
+hasElem tag content =
+  not . Prelude.null . Prelude.filter (bindElem tag) $ content
+
+unattr (AttValue as) = listToMaybe $ Prelude.concatMap left as
+    where left (Left x) = [x]
+          left _        = []
+
+astring (AttValue [Left s]) = [s]
+
+tagcontent tag content = Prelude.concatMap (\(CElem (Elem _ _ c) _)->c) 
+                              $ Prelude.filter (bindElem tag) content
+
+iqresult host id (Just rsrc) = L.unlines $
+    [ "<iq type='result' id='" <++> id <++> "'>"
+    , "<bind xmlns='urn:ietf:params:xml:ns:xmpp-bind'>"
+    , "<jid>" <++> id <++> "@" <++> host <++> "/" <++> rsrc <++> "</jid>"
+    , "</bind>"
+    , "</iq> "
+    ]
+iqresult host id Nothing = L.unlines $
+    [ "<iq type='result'"
+    , "    id='" <++> id <++> "'"
+    , "    from='" <++> host <++> "'"
+    , "    /> "
+    ]
+
+iqresult_info host id mjid = L.unlines $
+    [ "<iq type='result'"
+    , "    from='" <++> host <++> "'"
+    , case mjid of  Just jid -> "    to='" <++> jid <++> "'"
+                    Nothing  -> ""
+    , "    id='" <++> id <++> "'>"
+    , "  <query xmlns='http://jabber.org/protocol/disco#info'>"
+    , "    <identity"
+    , "       category='server'"
+    , "       type='im'"
+    , "       name='" <++> host <++> "'/>"
+    , "    <feature var='http://jabber.org/protocol/disco#info'/>"
+    , "    <feature var='http://jabber.org/protocol/disco#items'/>"
+    , "  </query>"
+    , "</iq>"
+    ]
+
+iqresponse host (Elem _ attrs content) = do
+    id <- fmap pack (lookup (N "id") attrs >>= unattr) 
+    typ <- fmap pack (lookup (N "type") attrs >>= unattr)
+    case typ of
+      "set" -> do
+        let string (CString _ s _) = [s]
+        mplus (do
+                rsrc <- listToMaybe . Prelude.concatMap string . tagcontent "resource" . tagcontent "bind" $ content
+                Just $ iqresult host id (Just (pack rsrc)) )
+              (do
+                guard (hasElem "session" content)
+                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)
+      _ -> Nothing
+    
+    
+
+doCon st elem cont = do
+        let h = hOccursFst st :: Handle 
+            host = "localhost"
+            hsend r = do
+                hPutStrLn h r
+                L.putStrLn $ "SENT:\n" <++> r
+ 
+        case elem of
+            OpenTag _ -> 
+                hsend (greet host)
+            Element e@(Elem (N "iq") _ _) -> 
+                case iqresponse host e of
+                    Nothing -> trace "no respones" $ return ()
+                    Just r -> hsend r
+            _ -> return () -- putStrLn $ "unhandled: "++show v
+
+        putStrLn (show elem)
+        cont ()
+
+instance Show Hax.ElemTag where
+    show _ = "elemtag"
+
+data XmppObject e i t c
+    = Element e
+    | ProcessingInstruction i
+    | OpenTag t
+    | CloseTag c
+ deriving Show
+
+streamName = QN (Namespace {nsPrefix= "stream" , nsURI="http://etherx.jabber.org/streams" }) "stream" 
+
+xmppParse ls =
+    case xmlParseWith element ls of
+        (Right e,rs) -> (Right (Element e), rs)
+        (Left _,_) -> 
+          case xmlParseWith elemOpenTag ls of
+            (Right e,rs) -> (Right (OpenTag e),rs)
+            (Left _,_) -> 
+              case xmlParseWith (elemCloseTag streamName) ls of
+                (Right e,rs) -> (Right (CloseTag e),rs)
+                (Left _,_) -> 
+                  case xmlParseWith processinginstruction ls of
+                    (Right e,rs) -> (Right (ProcessingInstruction e),rs)
+                    (Left err,rs) -> (Left err,rs)
+    
+
+
+listenForXmppClients port st = do
+    let (start,dopkt) = 
+            adaptServer ( xmlLex "stream" . unpack
+                        , xmppParse)
+                        (startCon,doCon)
+    doServer (port .*. st)
+             dopkt
+             start
+
+
diff --git a/Presence/main.hs b/Presence/main.hs
index 99f58ee4..1eb0c0ed 100644
--- a/Presence/main.hs
+++ b/Presence/main.hs
@@ -12,6 +12,7 @@ import Data.Maybe
 import System.INotify
 import UTmp
 import FGConsole
+import XMPPServer
 
 jid user host rsrc = user ++ "@" ++ host ++ "/" ++ rsrc