From 42eb97f5574844d9899a42cf4b7c458c4a1b950e Mon Sep 17 00:00:00 2001 From: joe Date: Sat, 15 Jun 2013 21:00:14 -0400 Subject: Moved xmpp server into module --- Presence/XMPPServer.hs | 199 +++++++++++++++++++++++++++++++++++++++++++++++++ Presence/main.hs | 1 + 2 files changed, 200 insertions(+) create mode 100644 Presence/XMPPServer.hs (limited to 'Presence') 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 + [ "" + , "" + , "" + , " " + {- + -- , " " + , " " + -- , " DIGEST-MD5" + , " PLAIN" + , " " + -} + , "" + ] + +startCon st = do + let h = hOccursFst st :: Handle + return (ConnectionFinalizer (return ()) .*. st) + +iq_query_unavailable host id mjid xmlns = L.unlines $ + [ " " to='" <++> jid <++> "'" + Nothing -> "" + , " id='" <++> id <++> "'>" + , " " + , " " + , " " + , " " + , "" + ] + +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 $ + [ "" + , "" + , "" <++> id <++> "@" <++> host <++> "/" <++> rsrc <++> "" + , "" + , " " + ] +iqresult host id Nothing = L.unlines $ + [ " " + ] + +iqresult_info host id mjid = L.unlines $ + [ " " to='" <++> jid <++> "'" + Nothing -> "" + , " id='" <++> id <++> "'>" + , " " + , " " + , " " + , " " + , " " + , "" + ] + +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 -- cgit v1.2.3