summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Presence/XMPPServer.hs199
-rw-r--r--Presence/main.hs1
-rw-r--r--xmppserver.hs196
3 files changed, 202 insertions, 194 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 @@
1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE ScopedTypeVariables #-}
3{-# LANGUAGE ViewPatterns #-}
4module XMPPServer ( listenForXmppClients ) where
5
6import Data.HList.TypeEqGeneric1()
7import Data.HList.TypeCastGeneric1()
8import ByteStringOperators
9
10import Server
11import Data.ByteString.Lazy.Char8 as L
12 ( ByteString
13 , hPutStrLn
14 , unlines
15 , pack
16 , unpack
17 , init )
18import qualified Data.ByteString.Lazy.Char8 as L
19 ( putStrLn )
20import System.IO
21 ( Handle
22 )
23import Control.Concurrent (forkIO)
24import Control.Concurrent.Chan
25import Data.HList
26import AdaptServer
27import Text.XML.HaXml.Lex (xmlLex)
28import Text.XML.HaXml.Parse (xmlParseWith,element,doctypedecl,processinginstruction,elemOpenTag,elemCloseTag)
29import Text.XML.HaXml.Types as Hax (ElemTag,QName(..),Namespace(..),Element(..),Content(..),AttValue(..))
30import qualified Text.XML.HaXml.Types as Hax (Element)
31import Data.Maybe
32import Debug.Trace
33
34
35
36greet host = L.unlines
37 [ "<?xml version='1.0'?>"
38 , "<stream:stream"
39 , "from='" <++> host <++> "'"
40 , "id='someid'"
41 , "xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/streams' version='1.0'>"
42 , "<stream:features>"
43 , " <bind xmlns='urn:ietf:params:xml:ns:xmpp-bind'/>"
44 {-
45 -- , " <session xmlns='urn:ietf:params:xml:ns:xmpp-session'/>"
46 , " <mechanisms xmlns='urn:ietf:params:xml:ns:xmpp-sasl'>"
47 -- , " <mechanism>DIGEST-MD5</mechanism>"
48 , " <mechanism>PLAIN</mechanism>"
49 , " </mechanisms> "
50 -}
51 , "</stream:features>"
52 ]
53
54startCon st = do
55 let h = hOccursFst st :: Handle
56 return (ConnectionFinalizer (return ()) .*. st)
57
58iq_query_unavailable host id mjid xmlns = L.unlines $
59 [ "<iq type='error'"
60 , " from='" <++> host <++> "'"
61 , case mjid of Just jid -> " to='" <++> jid <++> "'"
62 Nothing -> ""
63 , " id='" <++> id <++> "'>"
64 , " <query xmlns='" <++> xmlns <++> "'/>"
65 , " <error type='cancel'>"
66 , " <service-unavailable"
67 , " xmlns='urn:ietf:params:xml:ns:xmpp-stanzas'/>"
68 , " </error>"
69 , "</iq>"
70 ]
71
72tagattrs tag content = Prelude.concatMap (\(CElem (Elem _ a _) _)->a)
73 $ Prelude.filter (bindElem tag) content
74
75bindElem tag (CElem (Elem (N n) _ _) _) | n==tag = True
76bindElem _ _ = False
77
78hasElem tag content =
79 not . Prelude.null . Prelude.filter (bindElem tag) $ content
80
81unattr (AttValue as) = listToMaybe $ Prelude.concatMap left as
82 where left (Left x) = [x]
83 left _ = []
84
85astring (AttValue [Left s]) = [s]
86
87tagcontent tag content = Prelude.concatMap (\(CElem (Elem _ _ c) _)->c)
88 $ Prelude.filter (bindElem tag) content
89
90iqresult host id (Just rsrc) = L.unlines $
91 [ "<iq type='result' id='" <++> id <++> "'>"
92 , "<bind xmlns='urn:ietf:params:xml:ns:xmpp-bind'>"
93 , "<jid>" <++> id <++> "@" <++> host <++> "/" <++> rsrc <++> "</jid>"
94 , "</bind>"
95 , "</iq> "
96 ]
97iqresult host id Nothing = L.unlines $
98 [ "<iq type='result'"
99 , " id='" <++> id <++> "'"
100 , " from='" <++> host <++> "'"
101 , " /> "
102 ]
103
104iqresult_info host id mjid = L.unlines $
105 [ "<iq type='result'"
106 , " from='" <++> host <++> "'"
107 , case mjid of Just jid -> " to='" <++> jid <++> "'"
108 Nothing -> ""
109 , " id='" <++> id <++> "'>"
110 , " <query xmlns='http://jabber.org/protocol/disco#info'>"
111 , " <identity"
112 , " category='server'"
113 , " type='im'"
114 , " name='" <++> host <++> "'/>"
115 , " <feature var='http://jabber.org/protocol/disco#info'/>"
116 , " <feature var='http://jabber.org/protocol/disco#items'/>"
117 , " </query>"
118 , "</iq>"
119 ]
120
121iqresponse host (Elem _ attrs content) = do
122 id <- fmap pack (lookup (N "id") attrs >>= unattr)
123 typ <- fmap pack (lookup (N "type") attrs >>= unattr)
124 case typ of
125 "set" -> do
126 let string (CString _ s _) = [s]
127 mplus (do
128 rsrc <- listToMaybe . Prelude.concatMap string . tagcontent "resource" . tagcontent "bind" $ content
129 Just $ iqresult host id (Just (pack rsrc)) )
130 (do
131 guard (hasElem "session" content)
132 Just (iqresult host id Nothing))
133
134 "get" -> trace ("iq-get "++show (attrs,content)) $ do
135 xmlns <- fmap pack $
136 lookup (N "xmlns") (tagattrs "query" content)
137 >>= listToMaybe . astring
138 Just (iq_query_unavailable host id Nothing xmlns)
139 _ -> Nothing
140
141
142
143doCon st elem cont = do
144 let h = hOccursFst st :: Handle
145 host = "localhost"
146 hsend r = do
147 hPutStrLn h r
148 L.putStrLn $ "SENT:\n" <++> r
149
150 case elem of
151 OpenTag _ ->
152 hsend (greet host)
153 Element e@(Elem (N "iq") _ _) ->
154 case iqresponse host e of
155 Nothing -> trace "no respones" $ return ()
156 Just r -> hsend r
157 _ -> return () -- putStrLn $ "unhandled: "++show v
158
159 putStrLn (show elem)
160 cont ()
161
162instance Show Hax.ElemTag where
163 show _ = "elemtag"
164
165data XmppObject e i t c
166 = Element e
167 | ProcessingInstruction i
168 | OpenTag t
169 | CloseTag c
170 deriving Show
171
172streamName = QN (Namespace {nsPrefix= "stream" , nsURI="http://etherx.jabber.org/streams" }) "stream"
173
174xmppParse ls =
175 case xmlParseWith element ls of
176 (Right e,rs) -> (Right (Element e), rs)
177 (Left _,_) ->
178 case xmlParseWith elemOpenTag ls of
179 (Right e,rs) -> (Right (OpenTag e),rs)
180 (Left _,_) ->
181 case xmlParseWith (elemCloseTag streamName) ls of
182 (Right e,rs) -> (Right (CloseTag e),rs)
183 (Left _,_) ->
184 case xmlParseWith processinginstruction ls of
185 (Right e,rs) -> (Right (ProcessingInstruction e),rs)
186 (Left err,rs) -> (Left err,rs)
187
188
189
190listenForXmppClients port st = do
191 let (start,dopkt) =
192 adaptServer ( xmlLex "stream" . unpack
193 , xmppParse)
194 (startCon,doCon)
195 doServer (port .*. st)
196 dopkt
197 start
198
199
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
12import System.INotify 12import System.INotify
13import UTmp 13import UTmp
14import FGConsole 14import FGConsole
15import XMPPServer
15 16
16jid user host rsrc = user ++ "@" ++ host ++ "/" ++ rsrc 17jid user host rsrc = user ++ "@" ++ host ++ "/" ++ rsrc
17 18
diff --git a/xmppserver.hs b/xmppserver.hs
index 4277d625..4bbb9ea4 100644
--- a/xmppserver.hs
+++ b/xmppserver.hs
@@ -1,198 +1,6 @@
1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE ScopedTypeVariables #-}
3{-# LANGUAGE ViewPatterns #-}
4 1
5import Data.HList.TypeEqGeneric1()
6import Data.HList.TypeCastGeneric1()
7import ByteStringOperators
8
9import Server
10import Data.ByteString.Lazy.Char8 as L
11 ( ByteString
12 , hPutStrLn
13 , unlines
14 , pack
15 , unpack
16 , init )
17import qualified Data.ByteString.Lazy.Char8 as L
18 ( putStrLn )
19import System.IO
20 ( Handle
21 )
22import Control.Concurrent (forkIO)
23import Control.Concurrent.Chan
24import Data.HList 2import Data.HList
25import AdaptServer 3import XMPPServer
26import Text.XML.HaXml.Lex (xmlLex)
27import Text.XML.HaXml.Parse (xmlParseWith,element,doctypedecl,processinginstruction,elemOpenTag,elemCloseTag)
28import Text.XML.HaXml.Types as Hax (ElemTag,QName(..),Namespace(..),Element(..),Content(..),AttValue(..))
29import qualified Text.XML.HaXml.Types as Hax (Element)
30import Data.Maybe
31import Debug.Trace
32
33
34
35greet host = L.unlines
36 [ "<?xml version='1.0'?>"
37 , "<stream:stream"
38 , "from='" <++> host <++> "'"
39 , "id='someid'"
40 , "xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/streams' version='1.0'>"
41 , "<stream:features>"
42 , " <bind xmlns='urn:ietf:params:xml:ns:xmpp-bind'/>"
43 {-
44 -- , " <session xmlns='urn:ietf:params:xml:ns:xmpp-session'/>"
45 , " <mechanisms xmlns='urn:ietf:params:xml:ns:xmpp-sasl'>"
46 -- , " <mechanism>DIGEST-MD5</mechanism>"
47 , " <mechanism>PLAIN</mechanism>"
48 , " </mechanisms> "
49 -}
50 , "</stream:features>"
51 ]
52
53startCon st = do
54 let h = hOccursFst st :: Handle
55 return (ConnectionFinalizer (return ()) .*. st)
56
57iq_query_unavailable host id mjid xmlns = L.unlines $
58 [ "<iq type='error'"
59 , " from='" <++> host <++> "'"
60 , case mjid of Just jid -> " to='" <++> jid <++> "'"
61 Nothing -> ""
62 , " id='" <++> id <++> "'>"
63 , " <query xmlns='" <++> xmlns <++> "'/>"
64 , " <error type='cancel'>"
65 , " <service-unavailable"
66 , " xmlns='urn:ietf:params:xml:ns:xmpp-stanzas'/>"
67 , " </error>"
68 , "</iq>"
69 ]
70
71tagattrs tag content = Prelude.concatMap (\(CElem (Elem _ a _) _)->a)
72 $ Prelude.filter (bindElem tag) content
73
74bindElem tag (CElem (Elem (N n) _ _) _) | n==tag = True
75bindElem _ _ = False
76
77hasElem tag content =
78 not . Prelude.null . Prelude.filter (bindElem tag) $ content
79
80unattr (AttValue as) = listToMaybe $ Prelude.concatMap left as
81 where left (Left x) = [x]
82 left _ = []
83
84astring (AttValue [Left s]) = [s]
85
86tagcontent tag content = Prelude.concatMap (\(CElem (Elem _ _ c) _)->c)
87 $ Prelude.filter (bindElem tag) content
88
89iqresult host id (Just rsrc) = L.unlines $
90 [ "<iq type='result' id='" <++> id <++> "'>"
91 , "<bind xmlns='urn:ietf:params:xml:ns:xmpp-bind'>"
92 , "<jid>" <++> id <++> "@" <++> host <++> "/" <++> rsrc <++> "</jid>"
93 , "</bind>"
94 , "</iq> "
95 ]
96iqresult host id Nothing = L.unlines $
97 [ "<iq type='result'"
98 , " id='" <++> id <++> "'"
99 , " from='" <++> host <++> "'"
100 , " /> "
101 ]
102
103iqresult_info host id mjid = L.unlines $
104 [ "<iq type='result'"
105 , " from='" <++> host <++> "'"
106 , case mjid of Just jid -> " to='" <++> jid <++> "'"
107 Nothing -> ""
108 , " id='" <++> id <++> "'>"
109 , " <query xmlns='http://jabber.org/protocol/disco#info'>"
110 , " <identity"
111 , " category='server'"
112 , " type='im'"
113 , " name='" <++> host <++> "'/>"
114 , " <feature var='http://jabber.org/protocol/disco#info'/>"
115 , " <feature var='http://jabber.org/protocol/disco#items'/>"
116 , " </query>"
117 , "</iq>"
118 ]
119
120iqresponse host (Elem _ attrs content) = do
121 id <- fmap pack (lookup (N "id") attrs >>= unattr)
122 typ <- fmap pack (lookup (N "type") attrs >>= unattr)
123 case typ of
124 "set" -> do
125 let string (CString _ s _) = [s]
126 mplus (do
127 rsrc <- listToMaybe . Prelude.concatMap string . tagcontent "resource" . tagcontent "bind" $ content
128 Just $ iqresult host id (Just (pack rsrc)) )
129 (do
130 guard (hasElem "session" content)
131 Just (iqresult host id Nothing))
132
133 "get" -> trace ("iq-get "++show (attrs,content)) $ do
134 xmlns <- fmap pack $
135 lookup (N "xmlns") (tagattrs "query" content)
136 >>= listToMaybe . astring
137 Just (iq_query_unavailable host id Nothing xmlns)
138 _ -> Nothing
139
140
141
142doCon st elem cont = do
143 let h = hOccursFst st :: Handle
144 host = "localhost"
145 hsend r = do
146 hPutStrLn h r
147 L.putStrLn $ "SENT:\n" <++> r
148
149 case elem of
150 OpenTag _ ->
151 hsend (greet host)
152 Element e@(Elem (N "iq") _ _) ->
153 case iqresponse host e of
154 Nothing -> trace "no respones" $ return ()
155 Just r -> hsend r
156 _ -> return () -- putStrLn $ "unhandled: "++show v
157
158 putStrLn (show elem)
159 cont ()
160
161instance Show Hax.ElemTag where
162 show _ = "elemtag"
163
164data XmppObject e i t c
165 = Element e
166 | ProcessingInstruction i
167 | OpenTag t
168 | CloseTag c
169 deriving Show
170
171streamName = QN (Namespace {nsPrefix= "stream" , nsURI="http://etherx.jabber.org/streams" }) "stream"
172
173xmppParse ls =
174 case xmlParseWith element ls of
175 (Right e,rs) -> (Right (Element e), rs)
176 (Left _,_) ->
177 case xmlParseWith elemOpenTag ls of
178 (Right e,rs) -> (Right (OpenTag e),rs)
179 (Left _,_) ->
180 case xmlParseWith (elemCloseTag streamName) ls of
181 (Right e,rs) -> (Right (CloseTag e),rs)
182 (Left _,_) ->
183 case xmlParseWith processinginstruction ls of
184 (Right e,rs) -> (Right (ProcessingInstruction e),rs)
185 (Left err,rs) -> (Left err,rs)
186
187
188 4
189main = do 5main = do
190 let (start,dopkt) = 6 listenForXmppClients 5222 HNil
191 adaptServer ( xmlLex "stream" . unpack
192 , xmppParse)
193 (startCon,doCon)
194 doServer (5222 .*. HNil)
195 dopkt
196 start
197
198
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-15 00:24:43 +0000