summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Presence/Control/Concurrent/STM/Util.hs21
-rw-r--r--Presence/Stanza/Parse.hs261
-rw-r--r--Presence/Stanza/Type.hs184
-rw-r--r--Presence/XMPPServer.hs433
-rw-r--r--dht-client.cabal3
5 files changed, 473 insertions, 429 deletions
diff --git a/Presence/Control/Concurrent/STM/Util.hs b/Presence/Control/Concurrent/STM/Util.hs
new file mode 100644
index 00000000..4be3cff5
--- /dev/null
+++ b/Presence/Control/Concurrent/STM/Util.hs
@@ -0,0 +1,21 @@
1module Control.Concurrent.STM.Util where
2
3import Control.Monad.IO.Class
4import Control.Concurrent.STM
5
6chanContents :: TChan x -> IO [x]
7chanContents ch = do
8 x <- atomically $ do
9 bempty <- isEmptyTChan ch
10 if bempty
11 then return Nothing
12 else fmap Just $ readTChan ch
13 maybe (return [])
14 (\x -> do
15 xs <- chanContents ch
16 return (x:xs))
17 x
18
19ioWriteChan :: MonadIO m => TChan a -> a -> m ()
20ioWriteChan c v = liftIO . atomically $ writeTChan c v
21
diff --git a/Presence/Stanza/Parse.hs b/Presence/Stanza/Parse.hs
new file mode 100644
index 00000000..50e1e25b
--- /dev/null
+++ b/Presence/Stanza/Parse.hs
@@ -0,0 +1,261 @@
1module Stanza.Parse (grokStanza,errorTagLocalName) where
2
3import Control.Concurrent.STM
4import Control.Monad
5import Data.Char
6import Data.Function
7import Data.Maybe
8import qualified Data.Text as Text (pack, unpack, words)
9 ;import Data.Text (Text)
10
11import Control.Monad.Catch (MonadThrow)
12import Control.Monad.IO.Class (MonadIO, liftIO)
13import qualified Data.Map as Map
14import Data.XML.Types as XML
15import qualified Text.XML.Stream.Parse as XML
16
17import Control.Concurrent.STM.Util
18import ControlMaybe (handleIO_, (<&>))
19import EventUtil
20import Nesting
21import Stanza.Type
22
23-- | Identify an XMPP stanza based on the open-tag.
24grokStanza :: Text -> XML.Event -> NestingXML o IO (Maybe StanzaType)
25grokStanza "jabber:server" stanzaTag =
26 case () of
27 _ | stanzaTag `isServerIQOf` "get" -> grokStanzaIQGet stanzaTag
28 _ | stanzaTag `isServerIQOf` "result" -> grokStanzaIQResult stanzaTag
29 _ | tagName stanzaTag == "{jabber:server}presence" -> grokPresence "jabber:server" stanzaTag
30 _ | tagName stanzaTag == "{jabber:server}message" -> grokMessage "jabber:server" stanzaTag
31 _ -> return $ Just Unrecognized
32
33grokStanza "jabber:client" stanzaTag =
34 case () of
35 _ | stanzaTag `isClientIQOf` "get" -> grokStanzaIQGet stanzaTag
36 _ | stanzaTag `isClientIQOf` "set" -> grokStanzaIQSet stanzaTag
37 _ | stanzaTag `isClientIQOf` "result" -> grokStanzaIQResult stanzaTag
38 _ | tagName stanzaTag == "{jabber:client}presence" -> grokPresence "jabber:client" stanzaTag
39 _ | tagName stanzaTag == "{jabber:client}message" -> grokMessage "jabber:client" stanzaTag
40 _ -> return $ Just Unrecognized
41
42grokStanzaIQGet :: Monad m => XML.Event -> NestingXML o m (Maybe StanzaType)
43grokStanzaIQGet stanza = do
44 mtag <- nextElement
45 forM mtag $ \tag -> do
46 case tagName tag of
47 "{urn:xmpp:ping}ping" -> return Ping
48 "{jabber:iq:roster}query" -> return RequestRoster
49 name -> return $ UnrecognizedQuery name
50
51grokStanzaIQResult :: XML.Event -> NestingXML o IO (Maybe StanzaType)
52grokStanzaIQResult stanza = do
53 mtag <- nextElement
54 fromMaybe (return $ Just Pong) $ mtag <&> \tag -> do
55 case tagName tag of
56 "{jabber:iq:version}query" | nameNamespace (tagName stanza)==Just "jabber:client"
57 -> parseClientVersion
58 _ -> return Nothing
59
60grokStanzaIQSet :: XML.Event -> NestingXML o IO (Maybe StanzaType)
61grokStanzaIQSet stanza = do
62 mtag <- nextElement
63 case tagName <$> mtag of
64 Just "{urn:ietf:params:xml:ns:xmpp-bind}bind"
65 -> do mchild <- nextElement
66 case tagName <$> mchild of
67 Just "{urn:ietf:params:xml:ns:xmpp-bind}resource"
68 -> do rsc <- XML.content -- TODO: MonadThrow???
69 return . Just $ RequestResource Nothing (Just rsc)
70 Just _ -> return Nothing
71 Nothing -> return . Just $ RequestResource Nothing Nothing
72 Just "{urn:ietf:params:xml:ns:xmpp-session}session"
73 -> return $ Just SessionRequest
74 _ -> return Nothing
75
76grokPresence
77 :: ( MonadThrow m
78 , MonadIO m
79 ) => Text -> XML.Event -> NestingXML o m (Maybe StanzaType)
80grokPresence ns stanzaTag = do
81 let typ = lookupAttrib "type" (tagAttrs stanzaTag)
82 case typ of
83 Nothing -> parsePresenceStatus ns stanzaTag
84 Just "unavailable" -> fmap (fmap (\p -> p {presenceShow=Offline}))
85 $ parsePresenceStatus ns stanzaTag
86 Just "error" -> return . Just $ PresenceInformError
87 Just "unsubscribed" -> return . Just $ PresenceInformSubscription False
88 Just "subscribed" -> return . Just $ PresenceInformSubscription True
89 Just "probe" -> return . Just $ PresenceRequestStatus
90 Just "unsubscribe" -> return . Just $ PresenceRequestSubscription False
91 Just "subscribe" -> return . Just $ PresenceRequestSubscription True
92 _ -> return Nothing
93
94grokMessage
95 :: ( MonadThrow m
96 , MonadIO m
97 ) => Text -> XML.Event -> NestingXML o m (Maybe StanzaType)
98grokMessage ns stanzaTag = do
99 let typ = lookupAttrib "type" (tagAttrs stanzaTag)
100 case typ of
101 Just "error" -> do
102 mb <- findErrorTag ns
103 return $ do
104 e <- mb
105 return $ Error e stanzaTag
106 _ -> do t <- parseMessage ns stanzaTag
107 return $ Just t
108
109parseClientVersion :: NestingXML o IO (Maybe StanzaType)
110parseClientVersion = parseit Nothing Nothing
111 where
112 reportit mname mver = return $ do
113 name <- mname
114 ver <- mver
115 return NotifyClientVersion { versionName=name, versionVersion=ver }
116 parseit :: Maybe Text -> Maybe Text -> NestingXML o IO (Maybe StanzaType)
117 parseit mname mver = do
118 mtag <- nextElement
119 fromMaybe (reportit mname mver) $ mtag <&> \tag -> do
120 case tagName tag of
121 "{jabber:iq:version}name" -> do
122 x <- XML.content
123 parseit (Just x) mver
124 "{jabber:iq:version}version" -> do
125 x <- XML.content
126 parseit mname (Just x)
127 _ -> parseit mname mver
128
129parsePresenceStatus
130 :: ( MonadThrow m
131 , MonadIO m
132 ) => Text -> XML.Event -> NestingXML o m (Maybe StanzaType)
133parsePresenceStatus ns stanzaTag = do
134
135 let toStat "away" = Away
136 toStat "xa" = ExtendedAway
137 toStat "dnd" = DoNotDisturb
138 toStat "chat" = Chatty
139
140 showv <- liftIO . atomically $ newTVar Available
141 priov <- liftIO . atomically $ newTVar Nothing
142 statusv <- liftIO . atomically $ newTChan
143 fix $ \loop -> do
144 mtag <- nextElement
145 forM_ mtag $ \tag -> do
146 when (nameNamespace (tagName tag) == Just ns) $ do
147 case nameLocalName (tagName tag) of
148 "show" -> do t <- XML.content
149 liftIO . atomically $ writeTVar showv (toStat t)
150 "priority" -> do t <- XML.content
151 liftIO . handleIO_ (return ()) $ do
152 prio <- readIO (Text.unpack t)
153 atomically $ writeTVar priov (Just prio)
154 "status" -> do t <- XML.content
155 lang <- xmlLang
156 ioWriteChan statusv (maybe "" id lang,t)
157 _ -> return ()
158 loop
159 show <- liftIO . atomically $ readTVar showv
160 prio <- liftIO . atomically $ readTVar priov
161 status <- liftIO $ chanContents statusv -- Could use unsafeInterleaveIO to
162 -- avoid multiple passes, but whatever.
163 let wlist = do
164 w <- maybeToList $ lookupAttrib "whitelist" (tagAttrs stanzaTag)
165 Text.words w
166 return . Just $ PresenceStatus { presenceShow = show
167 , presencePriority = prio
168 , presenceStatus = status
169 , presenceWhiteList = wlist
170 }
171parseMessage
172 :: ( MonadThrow m
173 , MonadIO m
174 ) => Text -> XML.Event -> NestingXML o m StanzaType
175parseMessage ns stanza = do
176 let bodytag = Name { nameNamespace = Just ns
177 , nameLocalName = "body"
178 , namePrefix = Nothing }
179 subjecttag = Name { nameNamespace = Just ns
180 , nameLocalName = "subject"
181 , namePrefix = Nothing }
182 threadtag = Name { nameNamespace = Just ns
183 , nameLocalName = "thread"
184 , namePrefix = Nothing }
185 let emptyMsg = LangSpecificMessage { msgBody=Nothing, msgSubject=Nothing }
186 parseChildren (th,cmap) = do
187 child <- nextElement
188 lvl <- nesting
189 xmllang <- xmlLang
190 let lang = maybe "" id xmllang
191 let c = maybe emptyMsg id (Map.lookup lang cmap)
192 -- log $ " child: "<> bshow child
193 case child of
194 Just tag | tagName tag==bodytag
195 -> do
196 txt <- XML.content
197 awaitCloser lvl
198 parseChildren (th,Map.insert lang (c { msgBody=Just txt }) cmap)
199 Just tag | tagName tag==subjecttag
200 -> do
201 txt <- XML.content
202 awaitCloser lvl
203 parseChildren (th,Map.insert lang (c { msgSubject=Just txt }) cmap)
204 Just tag | tagName tag==threadtag
205 -> do
206 txt <- XML.content
207 awaitCloser lvl
208 parseChildren (th {msgThreadContent=txt},cmap)
209 Just tag -> do
210 -- let nm = tagName tag
211 -- attrs = tagAttrs tag
212 -- -- elems = msgElements c
213 -- txt <- XML.content
214 awaitCloser lvl
215 parseChildren (th,Map.insert lang c cmap)
216 Nothing -> return (th,cmap)
217 (th,langmap) <- parseChildren ( MessageThread {msgThreadParent=Nothing, msgThreadContent=""}
218 , Map.empty )
219 return Message {
220 msgLangMap = Map.toList langmap,
221 msgThread = if msgThreadContent th/="" then Just th else Nothing
222 }
223
224findErrorTag :: Monad m => Text -> NestingXML o m (Maybe StanzaError)
225findErrorTag ns = do
226 x <- nextElement
227 fmap join $ forM x $ \x ->
228 case tagName x of
229 n | nameNamespace n==Just ns && nameLocalName n=="error"
230 -> do
231 mtag <- findConditionTag
232 return $ do
233 tag <- {- trace ("mtag = "++show mtag) -} mtag
234 let t = nameLocalName (tagName tag)
235 conditionFromText t
236 _ -> findErrorTag ns
237
238findConditionTag :: Monad m => NestingXML o m (Maybe XML.Event)
239findConditionTag = do
240 mx <- nextElement
241 fmap join $ forM mx $ \x -> do
242 case nameNamespace (tagName x) of
243 Just "urn:ietf:params:xml:ns:xmpp-stanzas" -> return (Just x)
244 _ -> findConditionTag
245
246conditionFromText :: Text -> Maybe StanzaError
247conditionFromText t = fmap fst $ listToMaybe ss
248 where
249 es = [BadRequest .. UnexpectedRequest]
250 ts = map (\e->(e,errorTagLocalName e)) es
251 ss = dropWhile ((/=t) . snd) ts
252
253-- | Converts a CamelCase constructor to a hyphenated lower-case name for use
254-- as an xml tag.
255errorTagLocalName :: StanzaError -> Text
256errorTagLocalName e = Text.pack . drop 1 $ do
257 c <- show e
258 if 'A' <= c && c <= 'Z'
259 then [ '-', chr( ord c - ord 'A' + ord 'a') ]
260 else return c
261
diff --git a/Presence/Stanza/Type.hs b/Presence/Stanza/Type.hs
new file mode 100644
index 00000000..1d8041a9
--- /dev/null
+++ b/Presence/Stanza/Type.hs
@@ -0,0 +1,184 @@
1{-# LANGUAGE FlexibleInstances #-}
2module Stanza.Type where
3
4import Control.Concurrent.STM
5import Data.Int
6import Data.Text
7import Data.XML.Types as XML
8
9import Connection (PeerAddress(..))
10import ConnectionKey (ClientAddress(..))
11import LockedChan
12import Nesting (Lang)
13
14type Stanza = StanzaWrap (LockedChan XML.Event)
15
16data StanzaWrap a = Stanza
17 { stanzaType :: StanzaType
18 , stanzaId :: Maybe Text
19 , stanzaTo :: Maybe Text
20 , stanzaFrom :: Maybe Text
21 , stanzaChan :: a
22 , stanzaClosers :: TVar (Maybe [XML.Event])
23 , stanzaInterrupt :: TMVar ()
24 , stanzaOrigin :: StanzaOrigin
25 }
26
27data StanzaOrigin = LocalPeer
28 | PeerOrigin PeerAddress (TChan Stanza)
29 | ClientOrigin ClientAddress (TChan Stanza)
30
31data StanzaType
32 = Unrecognized
33 | Ping
34 | Pong
35 | RequestResource (Maybe Text) (Maybe Text) -- ^ Client's name for this host followed by client's requested resource id.
36 | SetResource
37 | SessionRequest
38 | UnrecognizedQuery Name
39 | RequestRoster
40 | Roster
41 | RosterEvent { rosterEventType :: RosterEventType
42 , rosterUser :: Text
43 , rosterContact :: Text }
44 | Error StanzaError XML.Event
45 | PresenceStatus { presenceShow :: JabberShow
46 , presencePriority :: Maybe Int8
47 , presenceStatus :: [(Lang,Text)]
48 , presenceWhiteList :: [Text]
49 }
50 | PresenceInformError
51 | PresenceInformSubscription Bool
52 | PresenceRequestStatus
53 | PresenceRequestSubscription Bool
54 | Message { msgThread :: Maybe MessageThread
55 , msgLangMap :: [(Lang,LangSpecificMessage)]
56 }
57 | NotifyClientVersion { versionName :: Text
58 , versionVersion :: Text }
59 | InternalEnableHack ClientHack
60 | InternalCacheId Text
61 deriving (Show,Eq)
62
63data RosterEventType
64 = RequestedSubscription
65 | NewBuddy -- preceded by PresenceInformSubscription True
66 | RemovedBuddy -- preceded by PresenceInformSubscription False
67 | PendingSubscriber -- same as PresenceRequestSubscription
68 | NewSubscriber
69 | RejectSubscriber
70 deriving (Show,Read,Ord,Eq,Enum)
71
72data ClientHack = SimulatedChatErrors
73 deriving (Show,Read,Ord,Eq,Enum)
74
75
76data LangSpecificMessage =
77 LangSpecificMessage { msgBody :: Maybe Text
78 , msgSubject :: Maybe Text
79 }
80 deriving (Show,Eq)
81
82data MessageThread = MessageThread {
83 msgThreadParent :: Maybe Text,
84 msgThreadContent :: Text
85 }
86 deriving (Show,Eq)
87
88
89data JabberShow = Offline
90 | ExtendedAway
91 | Away
92 | DoNotDisturb
93 | Available
94 | Chatty
95 deriving (Show,Enum,Ord,Eq,Read)
96
97class StanzaFirstTag a where
98 stanzaFirstTag :: StanzaWrap a -> IO XML.Event
99instance StanzaFirstTag (TChan XML.Event) where
100 stanzaFirstTag stanza = do
101 e <-atomically $ peekTChan (stanzaChan stanza)
102 return e
103instance StanzaFirstTag (LockedChan XML.Event) where
104 stanzaFirstTag stanza = do
105 e <-atomically $ peekLChan (stanzaChan stanza)
106 return e
107instance StanzaFirstTag XML.Event where
108 stanzaFirstTag stanza = return (stanzaChan stanza)
109
110data StanzaError
111 = BadRequest
112 | Conflict
113 | FeatureNotImplemented
114 | Forbidden
115 | Gone
116 | InternalServerError
117 | ItemNotFound
118 | JidMalformed
119 | NotAcceptable
120 | NotAllowed
121 | NotAuthorized
122 | PaymentRequired
123 | RecipientUnavailable
124 | Redirect
125 | RegistrationRequired
126 | RemoteServerNotFound
127 | RemoteServerTimeout
128 | ResourceConstraint
129 | ServiceUnavailable
130 | SubscriptionRequired
131 | UndefinedCondition
132 | UnexpectedRequest
133 deriving (Show,Enum,Ord,Eq)
134
135xep0086 :: StanzaError -> (Text, Int)
136xep0086 e = case e of
137 BadRequest -> ("modify", 400)
138 Conflict -> ("cancel", 409)
139 FeatureNotImplemented -> ("cancel", 501)
140 Forbidden -> ("auth", 403)
141 Gone -> ("modify", 302)
142 InternalServerError -> ("wait", 500)
143 ItemNotFound -> ("cancel", 404)
144 JidMalformed -> ("modify", 400)
145 NotAcceptable -> ("modify", 406)
146 NotAllowed -> ("cancel", 405)
147 NotAuthorized -> ("auth", 401)
148 PaymentRequired -> ("auth", 402)
149 RecipientUnavailable -> ("wait", 404)
150 Redirect -> ("modify", 302)
151 RegistrationRequired -> ("auth", 407)
152 RemoteServerNotFound -> ("cancel", 404)
153 RemoteServerTimeout -> ("wait", 504)
154 ResourceConstraint -> ("wait", 500)
155 ServiceUnavailable -> ("cancel", 503)
156 SubscriptionRequired -> ("auth", 407)
157 UndefinedCondition -> ("", 500)
158 UnexpectedRequest -> ("wait", 400)
159
160errorText :: StanzaError -> Text
161errorText e = case e of
162 BadRequest -> "Bad request"
163 Conflict -> "Conflict"
164 FeatureNotImplemented -> "This feature is not implemented"
165 Forbidden -> "Forbidden"
166 Gone -> "Recipient can no longer be contacted"
167 InternalServerError -> "Internal server error"
168 ItemNotFound -> "Item not found"
169 JidMalformed -> "JID Malformed"
170 NotAcceptable -> "Message was rejected"
171 NotAllowed -> "Not allowed"
172 NotAuthorized -> "Not authorized"
173 PaymentRequired -> "Payment is required"
174 RecipientUnavailable -> "Recipient is unavailable"
175 Redirect -> "Redirect"
176 RegistrationRequired -> "Registration required"
177 RemoteServerNotFound -> "Recipient's server not found"
178 RemoteServerTimeout -> "Remote server timeout"
179 ResourceConstraint -> "The server is low on resources"
180 ServiceUnavailable -> "The service is unavailable"
181 SubscriptionRequired -> "A subscription is required"
182 UndefinedCondition -> "Undefined condition"
183 UnexpectedRequest -> "Unexpected request"
184
diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index 3327b523..11a27660 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -75,7 +75,6 @@ import Text.Printf
75import Data.ByteString (ByteString) 75import Data.ByteString (ByteString)
76import qualified Data.ByteString.Char8 as Strict8 76import qualified Data.ByteString.Char8 as Strict8
77-- import qualified Data.ByteString.Lazy.Char8 as Lazy8 77-- import qualified Data.ByteString.Lazy.Char8 as Lazy8
78import Data.Int (Int8)
79 78
80import Data.Conduit 79import Data.Conduit
81import qualified Data.Conduit.List as CL 80import qualified Data.Conduit.List as CL
@@ -85,8 +84,8 @@ import Data.Conduit.ByteString.Builder (builderToByteStringFlush)
85#else 84#else
86import Data.Conduit.Blaze (builderToByteStringFlush) 85import Data.Conduit.Blaze (builderToByteStringFlush)
87#endif 86#endif
88import Control.Monad.Catch (MonadThrow)
89 87
88import Control.Concurrent.STM.Util
90import DNSCache (withPort) 89import DNSCache (withPort)
91import qualified Text.XML.Stream.Render as XML hiding (content) 90import qualified Text.XML.Stream.Render as XML hiding (content)
92import qualified Text.XML.Stream.Parse as XML 91import qualified Text.XML.Stream.Parse as XML
@@ -94,8 +93,7 @@ import Data.XML.Types as XML
94import Data.Maybe 93import Data.Maybe
95import Data.Monoid ( (<>) ) 94import Data.Monoid ( (<>) )
96import Data.Text (Text) 95import Data.Text (Text)
97import qualified Data.Text as Text (pack,unpack,words,intercalate,drop) 96import qualified Data.Text as Text (pack,unpack,intercalate,drop)
98import Data.Char (chr,ord)
99import qualified Data.Map as Map 97import qualified Data.Map as Map
100import Data.Set (Set, (\\) ) 98import Data.Set (Set, (\\) )
101import qualified Data.Set as Set 99import qualified Data.Set as Set
@@ -104,6 +102,8 @@ import qualified System.Random
104import Data.Void (Void) 102import Data.Void (Void)
105import DPut 103import DPut
106import DebugTag 104import DebugTag
105import Stanza.Type
106import Stanza.Parse
107 107
108-- peerport :: PortNumber 108-- peerport :: PortNumber
109-- peerport = 5269 109-- peerport = 5269
@@ -113,87 +113,6 @@ import DebugTag
113my_uuid :: Text 113my_uuid :: Text
114my_uuid = "154ae29f-98f2-4af4-826d-a40c8a188574" 114my_uuid = "154ae29f-98f2-4af4-826d-a40c8a188574"
115 115
116data JabberShow = Offline
117 | ExtendedAway
118 | Away
119 | DoNotDisturb
120 | Available
121 | Chatty
122 deriving (Show,Enum,Ord,Eq,Read)
123
124data MessageThread = MessageThread {
125 msgThreadParent :: Maybe Text,
126 msgThreadContent :: Text
127 }
128 deriving (Show,Eq)
129
130data LangSpecificMessage =
131 LangSpecificMessage { msgBody :: Maybe Text
132 , msgSubject :: Maybe Text
133 }
134 deriving (Show,Eq)
135
136data RosterEventType
137 = RequestedSubscription
138 | NewBuddy -- preceded by PresenceInformSubscription True
139 | RemovedBuddy -- preceded by PresenceInformSubscription False
140 | PendingSubscriber -- same as PresenceRequestSubscription
141 | NewSubscriber
142 | RejectSubscriber
143 deriving (Show,Read,Ord,Eq,Enum)
144
145data ClientHack = SimulatedChatErrors
146 deriving (Show,Read,Ord,Eq,Enum)
147
148data StanzaType
149 = Unrecognized
150 | Ping
151 | Pong
152 | RequestResource (Maybe Text) (Maybe Text) -- ^ Client's name for this host followed by client's requested resource id.
153 | SetResource
154 | SessionRequest
155 | UnrecognizedQuery Name
156 | RequestRoster
157 | Roster
158 | RosterEvent { rosterEventType :: RosterEventType
159 , rosterUser :: Text
160 , rosterContact :: Text }
161 | Error StanzaError XML.Event
162 | PresenceStatus { presenceShow :: JabberShow
163 , presencePriority :: Maybe Int8
164 , presenceStatus :: [(Lang,Text)]
165 , presenceWhiteList :: [Text]
166 }
167 | PresenceInformError
168 | PresenceInformSubscription Bool
169 | PresenceRequestStatus
170 | PresenceRequestSubscription Bool
171 | Message { msgThread :: Maybe MessageThread
172 , msgLangMap :: [(Lang,LangSpecificMessage)]
173 }
174 | NotifyClientVersion { versionName :: Text
175 , versionVersion :: Text }
176 | InternalEnableHack ClientHack
177 | InternalCacheId Text
178 deriving (Show,Eq)
179
180data StanzaOrigin = LocalPeer
181 | PeerOrigin PeerAddress (TChan Stanza)
182 | ClientOrigin ClientAddress (TChan Stanza)
183
184
185data StanzaWrap a = Stanza
186 { stanzaType :: StanzaType
187 , stanzaId :: Maybe Text
188 , stanzaTo :: Maybe Text
189 , stanzaFrom :: Maybe Text
190 , stanzaChan :: a
191 , stanzaClosers :: TVar (Maybe [XML.Event])
192 , stanzaInterrupt :: TMVar ()
193 , stanzaOrigin :: StanzaOrigin
194 }
195
196type Stanza = StanzaWrap (LockedChan XML.Event)
197 116
198newtype Local a = Local a deriving (Eq,Ord,Show) 117newtype Local a = Local a deriving (Eq,Ord,Show)
199newtype Remote a = Remote a deriving (Eq,Ord,Show) 118newtype Remote a = Remote a deriving (Eq,Ord,Show)
@@ -434,9 +353,6 @@ conduitToStanza stype mid from to c = do
434 } 353 }
435 354
436 355
437ioWriteChan :: MonadIO m => TChan a -> a -> m ()
438ioWriteChan c v = liftIO . atomically $ writeTChan c v
439
440stanzaToConduit :: MonadIO m => Stanza -> ConduitM i Event m () 356stanzaToConduit :: MonadIO m => Stanza -> ConduitM i Event m ()
441stanzaToConduit stanza = do 357stanzaToConduit stanza = do
442 let xchan = stanzaChan stanza 358 let xchan = stanzaChan stanza
@@ -564,60 +480,6 @@ stanzaFromList stype reply = do
564 , stanzaOrigin = LocalPeer 480 , stanzaOrigin = LocalPeer
565 } 481 }
566 482
567grokStanzaIQGet :: Monad m => XML.Event -> NestingXML o m (Maybe StanzaType)
568grokStanzaIQGet stanza = do
569 mtag <- nextElement
570 forM mtag $ \tag -> do
571 case tagName tag of
572 "{urn:xmpp:ping}ping" -> return Ping
573 "{jabber:iq:roster}query" -> return RequestRoster
574 name -> return $ UnrecognizedQuery name
575
576parseClientVersion :: NestingXML o IO (Maybe StanzaType)
577parseClientVersion = parseit Nothing Nothing
578 where
579 reportit mname mver = return $ do
580 name <- mname
581 ver <- mver
582 return NotifyClientVersion { versionName=name, versionVersion=ver }
583 parseit :: Maybe Text -> Maybe Text -> NestingXML o IO (Maybe StanzaType)
584 parseit mname mver = do
585 mtag <- nextElement
586 fromMaybe (reportit mname mver) $ mtag <&> \tag -> do
587 case tagName tag of
588 "{jabber:iq:version}name" -> do
589 x <- XML.content
590 parseit (Just x) mver
591 "{jabber:iq:version}version" -> do
592 x <- XML.content
593 parseit mname (Just x)
594 _ -> parseit mname mver
595
596
597grokStanzaIQResult :: XML.Event -> NestingXML o IO (Maybe StanzaType)
598grokStanzaIQResult stanza = do
599 mtag <- nextElement
600 fromMaybe (return $ Just Pong) $ mtag <&> \tag -> do
601 case tagName tag of
602 "{jabber:iq:version}query" | nameNamespace (tagName stanza)==Just "jabber:client"
603 -> parseClientVersion
604 _ -> return Nothing
605
606grokStanzaIQSet :: XML.Event -> NestingXML o IO (Maybe StanzaType)
607grokStanzaIQSet stanza = do
608 mtag <- nextElement
609 case tagName <$> mtag of
610 Just "{urn:ietf:params:xml:ns:xmpp-bind}bind"
611 -> do mchild <- nextElement
612 case tagName <$> mchild of
613 Just "{urn:ietf:params:xml:ns:xmpp-bind}resource"
614 -> do rsc <- XML.content -- TODO: MonadThrow???
615 return . Just $ RequestResource Nothing (Just rsc)
616 Just _ -> return Nothing
617 Nothing -> return . Just $ RequestResource Nothing Nothing
618 Just "{urn:ietf:params:xml:ns:xmpp-session}session"
619 -> return $ Just SessionRequest
620 _ -> return Nothing
621 483
622 484
623{- 485{-
@@ -628,197 +490,7 @@ C->Unrecognized xmlns="jabber:client">
628C->Unrecognized <bind xmlns="urn:ietf:params:xml:ns:xmpp-bind"/> 490C->Unrecognized <bind xmlns="urn:ietf:params:xml:ns:xmpp-bind"/>
629C->Unrecognized </iq> 491C->Unrecognized </iq>
630-} 492-}
631chanContents :: TChan x -> IO [x]
632chanContents ch = do
633 x <- atomically $ do
634 bempty <- isEmptyTChan ch
635 if bempty
636 then return Nothing
637 else fmap Just $ readTChan ch
638 maybe (return [])
639 (\x -> do
640 xs <- chanContents ch
641 return (x:xs))
642 x
643
644
645parsePresenceStatus
646 :: ( MonadThrow m
647 , MonadIO m
648 ) => Text -> XML.Event -> NestingXML o m (Maybe StanzaType)
649parsePresenceStatus ns stanzaTag = do
650 493
651 let toStat "away" = Away
652 toStat "xa" = ExtendedAway
653 toStat "dnd" = DoNotDisturb
654 toStat "chat" = Chatty
655
656 showv <- liftIO . atomically $ newTVar Available
657 priov <- liftIO . atomically $ newTVar Nothing
658 statusv <- liftIO . atomically $ newTChan
659 fix $ \loop -> do
660 mtag <- nextElement
661 forM_ mtag $ \tag -> do
662 when (nameNamespace (tagName tag) == Just ns) $ do
663 case nameLocalName (tagName tag) of
664 "show" -> do t <- XML.content
665 liftIO . atomically $ writeTVar showv (toStat t)
666 "priority" -> do t <- XML.content
667 liftIO . handleIO_ (return ()) $ do
668 prio <- readIO (Text.unpack t)
669 atomically $ writeTVar priov (Just prio)
670 "status" -> do t <- XML.content
671 lang <- xmlLang
672 ioWriteChan statusv (maybe "" id lang,t)
673 _ -> return ()
674 loop
675 show <- liftIO . atomically $ readTVar showv
676 prio <- liftIO . atomically $ readTVar priov
677 status <- liftIO $ chanContents statusv -- Could use unsafeInterleaveIO to
678 -- avoid multiple passes, but whatever.
679 let wlist = do
680 w <- maybeToList $ lookupAttrib "whitelist" (tagAttrs stanzaTag)
681 Text.words w
682 return . Just $ PresenceStatus { presenceShow = show
683 , presencePriority = prio
684 , presenceStatus = status
685 , presenceWhiteList = wlist
686 }
687grokPresence
688 :: ( MonadThrow m
689 , MonadIO m
690 ) => Text -> XML.Event -> NestingXML o m (Maybe StanzaType)
691grokPresence ns stanzaTag = do
692 let typ = lookupAttrib "type" (tagAttrs stanzaTag)
693 case typ of
694 Nothing -> parsePresenceStatus ns stanzaTag
695 Just "unavailable" -> fmap (fmap (\p -> p {presenceShow=Offline}))
696 $ parsePresenceStatus ns stanzaTag
697 Just "error" -> return . Just $ PresenceInformError
698 Just "unsubscribed" -> return . Just $ PresenceInformSubscription False
699 Just "subscribed" -> return . Just $ PresenceInformSubscription True
700 Just "probe" -> return . Just $ PresenceRequestStatus
701 Just "unsubscribe" -> return . Just $ PresenceRequestSubscription False
702 Just "subscribe" -> return . Just $ PresenceRequestSubscription True
703 _ -> return Nothing
704
705parseMessage
706 :: ( MonadThrow m
707 , MonadIO m
708 ) => Text -> XML.Event -> NestingXML o m StanzaType
709parseMessage ns stanza = do
710 let bodytag = Name { nameNamespace = Just ns
711 , nameLocalName = "body"
712 , namePrefix = Nothing }
713 subjecttag = Name { nameNamespace = Just ns
714 , nameLocalName = "subject"
715 , namePrefix = Nothing }
716 threadtag = Name { nameNamespace = Just ns
717 , nameLocalName = "thread"
718 , namePrefix = Nothing }
719 let emptyMsg = LangSpecificMessage { msgBody=Nothing, msgSubject=Nothing }
720 parseChildren (th,cmap) = do
721 child <- nextElement
722 lvl <- nesting
723 xmllang <- xmlLang
724 let lang = maybe "" id xmllang
725 let c = maybe emptyMsg id (Map.lookup lang cmap)
726 -- log $ " child: "<> bshow child
727 case child of
728 Just tag | tagName tag==bodytag
729 -> do
730 txt <- XML.content
731 awaitCloser lvl
732 parseChildren (th,Map.insert lang (c { msgBody=Just txt }) cmap)
733 Just tag | tagName tag==subjecttag
734 -> do
735 txt <- XML.content
736 awaitCloser lvl
737 parseChildren (th,Map.insert lang (c { msgSubject=Just txt }) cmap)
738 Just tag | tagName tag==threadtag
739 -> do
740 txt <- XML.content
741 awaitCloser lvl
742 parseChildren (th {msgThreadContent=txt},cmap)
743 Just tag -> do
744 -- let nm = tagName tag
745 -- attrs = tagAttrs tag
746 -- -- elems = msgElements c
747 -- txt <- XML.content
748 awaitCloser lvl
749 parseChildren (th,Map.insert lang c cmap)
750 Nothing -> return (th,cmap)
751 (th,langmap) <- parseChildren ( MessageThread {msgThreadParent=Nothing, msgThreadContent=""}
752 , Map.empty )
753 return Message {
754 msgLangMap = Map.toList langmap,
755 msgThread = if msgThreadContent th/="" then Just th else Nothing
756 }
757
758findConditionTag :: Monad m => NestingXML o m (Maybe XML.Event)
759findConditionTag = do
760 mx <- nextElement
761 fmap join $ forM mx $ \x -> do
762 case nameNamespace (tagName x) of
763 Just "urn:ietf:params:xml:ns:xmpp-stanzas" -> return (Just x)
764 _ -> findConditionTag
765
766conditionFromText :: Text -> Maybe StanzaError
767conditionFromText t = fmap fst $ listToMaybe ss
768 where
769 es = [BadRequest .. UnexpectedRequest]
770 ts = map (\e->(e,errorTagLocalName e)) es
771 ss = dropWhile ((/=t) . snd) ts
772
773findErrorTag :: Monad m => Text -> NestingXML o m (Maybe StanzaError)
774findErrorTag ns = do
775 x <- nextElement
776 fmap join $ forM x $ \x ->
777 case tagName x of
778 n | nameNamespace n==Just ns && nameLocalName n=="error"
779 -> do
780 mtag <- findConditionTag
781 return $ do
782 tag <- {- trace ("mtag = "++show mtag) -} mtag
783 let t = nameLocalName (tagName tag)
784 conditionFromText t
785 _ -> findErrorTag ns
786
787grokMessage
788 :: ( MonadThrow m
789 , MonadIO m
790 ) => Text -> XML.Event -> NestingXML o m (Maybe StanzaType)
791grokMessage ns stanzaTag = do
792 let typ = lookupAttrib "type" (tagAttrs stanzaTag)
793 case typ of
794 Just "error" -> do
795 mb <- findErrorTag ns
796 return $ do
797 e <- mb
798 return $ Error e stanzaTag
799 _ -> do t <- parseMessage ns stanzaTag
800 return $ Just t
801
802
803
804grokStanza
805 :: Text -> XML.Event -> NestingXML o IO (Maybe StanzaType)
806grokStanza "jabber:server" stanzaTag =
807 case () of
808 _ | stanzaTag `isServerIQOf` "get" -> grokStanzaIQGet stanzaTag
809 _ | stanzaTag `isServerIQOf` "result" -> grokStanzaIQResult stanzaTag
810 _ | tagName stanzaTag == "{jabber:server}presence" -> grokPresence "jabber:server" stanzaTag
811 _ | tagName stanzaTag == "{jabber:server}message" -> grokMessage "jabber:server" stanzaTag
812 _ -> return $ Just Unrecognized
813
814grokStanza "jabber:client" stanzaTag =
815 case () of
816 _ | stanzaTag `isClientIQOf` "get" -> grokStanzaIQGet stanzaTag
817 _ | stanzaTag `isClientIQOf` "set" -> grokStanzaIQSet stanzaTag
818 _ | stanzaTag `isClientIQOf` "result" -> grokStanzaIQResult stanzaTag
819 _ | tagName stanzaTag == "{jabber:client}presence" -> grokPresence "jabber:client" stanzaTag
820 _ | tagName stanzaTag == "{jabber:client}message" -> grokMessage "jabber:client" stanzaTag
821 _ -> return $ Just Unrecognized
822 494
823mkname :: Text -> Text -> XML.Name 495mkname :: Text -> Text -> XML.Name
824mkname namespace name = (Name name (Just namespace) Nothing) 496mkname namespace name = (Name name (Just namespace) Nothing)
@@ -1547,108 +1219,11 @@ socketFromKey sv (ClientAddress addr) = do
1547 Nothing -> return oops 1219 Nothing -> return oops
1548 Just cd -> return $ either (const oops) id $ cdAddr $ cdata cd 1220 Just cd -> return $ either (const oops) id $ cdAddr $ cdata cd
1549 1221
1550class StanzaFirstTag a where
1551 stanzaFirstTag :: StanzaWrap a -> IO XML.Event
1552instance StanzaFirstTag (TChan XML.Event) where
1553 stanzaFirstTag stanza = do
1554 e <-atomically $ peekTChan (stanzaChan stanza)
1555 return e
1556instance StanzaFirstTag (LockedChan XML.Event) where
1557 stanzaFirstTag stanza = do
1558 e <-atomically $ peekLChan (stanzaChan stanza)
1559 return e
1560instance StanzaFirstTag XML.Event where
1561 stanzaFirstTag stanza = return (stanzaChan stanza)
1562
1563data StanzaError
1564 = BadRequest
1565 | Conflict
1566 | FeatureNotImplemented
1567 | Forbidden
1568 | Gone
1569 | InternalServerError
1570 | ItemNotFound
1571 | JidMalformed
1572 | NotAcceptable
1573 | NotAllowed
1574 | NotAuthorized
1575 | PaymentRequired
1576 | RecipientUnavailable
1577 | Redirect
1578 | RegistrationRequired
1579 | RemoteServerNotFound
1580 | RemoteServerTimeout
1581 | ResourceConstraint
1582 | ServiceUnavailable
1583 | SubscriptionRequired
1584 | UndefinedCondition
1585 | UnexpectedRequest
1586 deriving (Show,Enum,Ord,Eq)
1587
1588xep0086 :: StanzaError -> (Text, Int)
1589xep0086 e =
1590 case e of
1591 BadRequest -> ("modify", 400)
1592 Conflict -> ("cancel", 409)
1593 FeatureNotImplemented -> ("cancel", 501)
1594 Forbidden -> ("auth", 403)
1595 Gone -> ("modify", 302)
1596 InternalServerError -> ("wait", 500)
1597 ItemNotFound -> ("cancel", 404)
1598 JidMalformed -> ("modify", 400)
1599 NotAcceptable -> ("modify", 406)
1600 NotAllowed -> ("cancel", 405)
1601 NotAuthorized -> ("auth", 401)
1602 PaymentRequired -> ("auth", 402)
1603 RecipientUnavailable -> ("wait", 404)
1604 Redirect -> ("modify", 302)
1605 RegistrationRequired -> ("auth", 407)
1606 RemoteServerNotFound -> ("cancel", 404)
1607 RemoteServerTimeout -> ("wait", 504)
1608 ResourceConstraint -> ("wait", 500)
1609 ServiceUnavailable -> ("cancel", 503)
1610 SubscriptionRequired -> ("auth", 407)
1611 UndefinedCondition -> ("", 500)
1612 UnexpectedRequest -> ("wait", 400)
1613
1614errorText :: StanzaError -> Text
1615errorText e =
1616 case e of
1617 BadRequest -> "Bad request"
1618 Conflict -> "Conflict"
1619 FeatureNotImplemented -> "This feature is not implemented"
1620 Forbidden -> "Forbidden"
1621 Gone -> "Recipient can no longer be contacted"
1622 InternalServerError -> "Internal server error"
1623 ItemNotFound -> "Item not found"
1624 JidMalformed -> "JID Malformed"
1625 NotAcceptable -> "Message was rejected"
1626 NotAllowed -> "Not allowed"
1627 NotAuthorized -> "Not authorized"
1628 PaymentRequired -> "Payment is required"
1629 RecipientUnavailable -> "Recipient is unavailable"
1630 Redirect -> "Redirect"
1631 RegistrationRequired -> "Registration required"
1632 RemoteServerNotFound -> "Recipient's server not found"
1633 RemoteServerTimeout -> "Remote server timeout"
1634 ResourceConstraint -> "The server is low on resources"
1635 ServiceUnavailable -> "The service is unavailable"
1636 SubscriptionRequired -> "A subscription is required"
1637 UndefinedCondition -> "Undefined condition"
1638 UnexpectedRequest -> "Unexpected request"
1639
1640eventContent :: Maybe [Content] -> Text 1222eventContent :: Maybe [Content] -> Text
1641eventContent cs = maybe "" (foldr1 (<>) . map content1) cs 1223eventContent cs = maybe "" (foldr1 (<>) . map content1) cs
1642 where content1 (ContentText t) = t 1224 where content1 (ContentText t) = t
1643 content1 (ContentEntity t) = t 1225 content1 (ContentEntity t) = t
1644 1226
1645errorTagLocalName :: forall a. Show a => a -> Text
1646errorTagLocalName e = Text.pack . drop 1 $ do
1647 c <- show e
1648 if 'A' <= c && c <= 'Z'
1649 then [ '-', chr( ord c - ord 'A' + ord 'a') ]
1650 else return c
1651
1652makeErrorStanza :: StanzaFirstTag a => StanzaWrap a -> IO [XML.Event] 1227makeErrorStanza :: StanzaFirstTag a => StanzaWrap a -> IO [XML.Event]
1653makeErrorStanza stanza = do 1228makeErrorStanza stanza = do
1654 startTag <- stanzaFirstTag stanza 1229 startTag <- stanzaFirstTag stanza
diff --git a/dht-client.cabal b/dht-client.cabal
index 91171084..b8882b8f 100644
--- a/dht-client.cabal
+++ b/dht-client.cabal
@@ -122,6 +122,7 @@ library
122 ConsoleWriter 122 ConsoleWriter
123 Control.Concurrent.STM.StatusCache 123 Control.Concurrent.STM.StatusCache
124 Control.Concurrent.STM.UpdateStream 124 Control.Concurrent.STM.UpdateStream
125 Control.Concurrent.STM.Util
125 ControlMaybe 126 ControlMaybe
126 Data.BitSyntax 127 Data.BitSyntax
127 DNSCache 128 DNSCache
@@ -136,6 +137,8 @@ library
136 Connection.Tcp 137 Connection.Tcp
137 SockAddr 138 SockAddr
138 UTmp 139 UTmp
140 Stanza.Type
141 Stanza.Parse
139 XMPPServer 142 XMPPServer
140 Util 143 Util
141 Presence 144 Presence
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-22 13:26:35 +0000