summaryrefslogtreecommitdiff
path: root/Presence
diff options
context:
space:
mode:
Diffstat (limited to 'Presence')
-rw-r--r--Presence/ByteStringOperators.hs50
-rw-r--r--Presence/ClientState.hs34
-rw-r--r--Presence/ConfigFiles.hs130
-rw-r--r--Presence/ConnectionKey.hs10
-rw-r--r--Presence/ConsoleWriter.hs411
-rw-r--r--Presence/ControlMaybe.hs29
-rw-r--r--Presence/DNSCache.hs261
-rw-r--r--Presence/EventUtil.hs83
-rw-r--r--Presence/FGConsole.hs62
-rw-r--r--Presence/GetHostByAddr.hs77
-rw-r--r--Presence/IDMangler.hs68
-rw-r--r--Presence/LocalPeerCred.hs213
-rw-r--r--Presence/LockedChan.hs78
-rw-r--r--Presence/Logging.hs25
-rw-r--r--Presence/Nesting.hs88
-rw-r--r--Presence/Paths.hs62
-rw-r--r--Presence/PeerResolve.hs39
-rw-r--r--Presence/Server.hs851
-rw-r--r--Presence/SockAddr.hs13
-rw-r--r--Presence/SocketLike.hs76
-rw-r--r--Presence/UTmp.hs249
-rw-r--r--Presence/XMPP.hs1461
-rw-r--r--Presence/XMPPServer.hs1829
-rw-r--r--Presence/monitortty.c173
24 files changed, 6372 insertions, 0 deletions
diff --git a/Presence/ByteStringOperators.hs b/Presence/ByteStringOperators.hs
new file mode 100644
index 00000000..4453aca0
--- /dev/null
+++ b/Presence/ByteStringOperators.hs
@@ -0,0 +1,50 @@
1{-# LANGUAGE CPP #-}
2module ByteStringOperators where
3
4import qualified Data.ByteString as S (ByteString)
5import Data.ByteString.Lazy.Char8 as L
6import Control.Applicative
7
8-- These two were imported to provide an NFData instance.
9import qualified Data.ByteString.Lazy.Internal as L (ByteString(..))
10import Control.DeepSeq
11
12
13(<++>) :: ByteString -> ByteString -> ByteString
14(<++.>) :: ByteString -> S.ByteString -> ByteString
15(<.++>) :: S.ByteString -> ByteString -> ByteString
16(<.++.>) :: S.ByteString -> S.ByteString -> ByteString
17a <++> b = L.append a b
18a <++.> b = L.append a (fromChunks [b])
19a <.++> b = L.append (fromChunks [a]) b
20a <.++.> b = fromChunks [a,b]
21infixr 5 <.++.>
22infixr 5 <.++>
23infixr 5 <++>
24infixr 5 <++.>
25
26a <++$> b = fmap (a<++>) b
27a <$++> b = fmap (<++>b) a
28a <$++$> b = liftA2 (<++>) a b
29infixr 6 <++$>
30infixr 6 <$++>
31infixr 6 <$++$>
32
33Nothing <?++> b = b
34Just a <?++> b = a <++> b
35infixr 5 <?++>
36
37a <++?> Nothing = a
38a <++?> Just b = a <++> b
39infixr 5 <++?>
40
41bshow :: Show a => a -> ByteString
42bshow = L.pack . show
43
44
45#if MIN_VERSION_bytestring(0,10,0)
46#else
47instance NFData L.ByteString where
48 rnf L.Empty = ()
49 rnf (L.Chunk _ b) = rnf b
50#endif
diff --git a/Presence/ClientState.hs b/Presence/ClientState.hs
new file mode 100644
index 00000000..30a53131
--- /dev/null
+++ b/Presence/ClientState.hs
@@ -0,0 +1,34 @@
1module ClientState where
2
3import Control.Concurrent.STM
4import Data.Text ( Text )
5import Data.Int ( Int8 )
6import Data.Bits ( (.&.) )
7
8import UTmp ( ProcessID )
9import XMPPServer ( Stanza )
10
11data ClientState = ClientState
12 { clientResource :: Text
13 , clientUser :: Text
14 , clientPid :: Maybe ProcessID
15 , clientStatus :: TVar (Maybe Stanza)
16 , clientFlags :: TVar Int8
17 }
18
19cf_available :: Int8
20cf_available = 0x1
21cf_interested :: Int8
22cf_interested = 0x2
23
24-- | True if the client has sent an initial presence
25clientIsAvailable :: ClientState -> STM Bool
26clientIsAvailable c = do
27 flgs <- readTVar (clientFlags c)
28 return $ flgs .&. cf_available /= 0
29
30-- | True if the client has requested a roster
31clientIsInterested :: ClientState -> STM Bool
32clientIsInterested c = do
33 flgs <- readTVar (clientFlags c)
34 return $ flgs .&. cf_interested /= 0
diff --git a/Presence/ConfigFiles.hs b/Presence/ConfigFiles.hs
new file mode 100644
index 00000000..808e6dd8
--- /dev/null
+++ b/Presence/ConfigFiles.hs
@@ -0,0 +1,130 @@
1{-# LANGUAGE OverloadedStrings #-}
2module ConfigFiles where
3
4import Data.ByteString.Lazy.Char8 as L
5import System.Posix.User
6import System.Posix.Files (fileExist)
7import System.FilePath
8import System.Directory
9import System.IO
10-- import System.IO.Strict
11import System.IO.Error
12import Control.Exception
13import Control.Monad
14import Control.DeepSeq
15import ByteStringOperators () -- For NFData instance
16import ControlMaybe
17import Data.List (partition)
18import Data.Maybe (catMaybes,isJust)
19
20type User = ByteString
21
22configDir = ".presence"
23buddyFile = "buddies"
24subscriberFile = "subscribers"
25otherFile = "others"
26pendingFile = "pending"
27solicitedFile = "solicited"
28
29
30configPath :: User -> String -> IO String
31configPath user filename = do
32 ue <- getUserEntryForName (unpack user)
33 return $ (++("/"++configDir++"/"++filename)) $ homeDirectory ue
34
35
36createConfigFile tag path = do
37 let dir = dropFileName path
38 doesDirectoryExist dir >>= flip unless (do
39 createDirectory dir
40 )
41 withFile path WriteMode $ \h -> do
42 L.hPutStrLn h tag
43
44addItem item tag path =
45 let doit = do
46 handle (\e -> when (isDoesNotExistError e)
47 (createConfigFile tag path >> doit))
48 $ do exists <- fileExist path
49 if exists
50 then withFile path AppendMode $ \h ->
51 L.hPutStrLn h item
52 else withFile path WriteMode $ \h -> do
53 L.hPutStrLn h tag
54 L.hPutStrLn h item
55 in doit
56
57
58modifyFile ::
59 (ByteString,FilePath)
60 -> ByteString
61 -> (ByteString -> IO (Maybe ByteString))
62 -> Maybe ByteString
63 -> IO Bool -- Returns True if test function ever returned Nothing
64modifyFile (tag,file) user test appending = configPath user file >>= doit
65 where
66 doit path = do
67 handle (\e -> if (isDoesNotExistError e)
68 then (createConfigFile tag path >> doit path)
69 else return False)
70 $ do exists <- fileExist path
71 if exists
72 then do
73 xs <- withFile path ReadMode $ \h -> do
74 contents <- L.hGetContents h
75 case L.lines contents of
76 x:xs -> mapM test xs
77 _ -> return []
78 let (keepers,deleted) = partition isJust xs
79 withFile path WriteMode $ \h -> do
80 L.hPutStrLn h tag
81 forM_ (catMaybes keepers) (L.hPutStrLn h)
82 withJust appending (L.hPutStrLn h)
83 return . not . Prelude.null $ deleted
84 else do
85 withFile path WriteMode $ \h -> do
86 L.hPutStrLn h tag
87 withJust appending (L.hPutStrLn h)
88 return False
89
90
91modifySolicited = modifyFile ("<? solicited ?>" , solicitedFile)
92modifyBuddies = modifyFile ("<? buddies ?>" , buddyFile)
93modifyOthers = modifyFile ("<? others ?>" , otherFile)
94modifyPending = modifyFile ("<? pending ?>" , pendingFile)
95modifySubscribers = modifyFile ("<? subscribers ?>", subscriberFile)
96
97addBuddy :: User -> ByteString -> IO ()
98addBuddy user buddy =
99 configPath user buddyFile >>= addItem buddy "<? buddies ?>"
100
101addSubscriber :: User -> ByteString -> IO ()
102addSubscriber user subscriber =
103 configPath user subscriberFile >>= addItem subscriber "<? subscribers ?>"
104
105addSolicited :: User -> ByteString -> IO ()
106addSolicited user solicited =
107 configPath user solicitedFile >>= addItem solicited "<? solicited ?>"
108
109
110getConfigList path =
111 handle (\e -> if isDoesNotExistError e then (return []) else throw e)
112 $ withFile path ReadMode $
113 L.hGetContents
114 >=> return . Prelude.tail . L.lines
115 >=> (\a -> seq (rnf a) (return a))
116
117getBuddies :: User -> IO [ByteString]
118getBuddies user = configPath user buddyFile >>= getConfigList
119
120getSubscribers :: User -> IO [ByteString]
121getSubscribers user = configPath user subscriberFile >>= getConfigList
122
123getOthers :: User -> IO [ByteString]
124getOthers user = configPath user otherFile >>= getConfigList
125
126getPending :: User -> IO [ByteString]
127getPending user = configPath user pendingFile >>= getConfigList
128
129getSolicited :: User -> IO [ByteString]
130getSolicited user = configPath user solicitedFile >>= getConfigList
diff --git a/Presence/ConnectionKey.hs b/Presence/ConnectionKey.hs
new file mode 100644
index 00000000..944f4f6f
--- /dev/null
+++ b/Presence/ConnectionKey.hs
@@ -0,0 +1,10 @@
1module ConnectionKey where
2
3import Network.Socket ( SockAddr(..) )
4import SockAddr ()
5
6data ConnectionKey
7 = PeerKey { callBackAddress :: SockAddr }
8 | ClientKey { localAddress :: SockAddr }
9 deriving (Show, Ord, Eq)
10
diff --git a/Presence/ConsoleWriter.hs b/Presence/ConsoleWriter.hs
new file mode 100644
index 00000000..e755b27f
--- /dev/null
+++ b/Presence/ConsoleWriter.hs
@@ -0,0 +1,411 @@
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE RankNTypes #-}
4module ConsoleWriter
5 ( ConsoleWriter(cwPresenceChan)
6 , newConsoleWriter
7 , writeActiveTTY
8 , writeAllPty
9 , cwClients
10 ) where
11
12import Control.Monad
13-- import Control.Applicative
14import Control.Concurrent
15import Control.Concurrent.STM
16import Data.Monoid
17import Data.Char
18import Data.Maybe
19import System.Environment hiding (setEnv)
20import System.Process ( rawSystem )
21import System.Exit ( ExitCode(ExitSuccess) )
22import System.Posix.Env ( setEnv )
23import System.Posix.Process ( forkProcess, exitImmediately, executeFile )
24import System.Posix.User ( setUserID, getUserEntryForName, userID )
25import System.Posix.Files ( getFileStatus, fileMode )
26import System.INotify ( initINotify, EventVariety(Modify), addWatch )
27import Data.Word ( Word8 )
28import Data.Text ( Text )
29import Data.Map ( Map )
30import Data.List ( foldl', groupBy )
31import Data.Bits ( (.&.) )
32import qualified Data.Map as Map
33import qualified Data.Traversable as Traversable
34import qualified Data.Text as Text
35-- import qualified Data.Text.IO as Text
36import qualified Network.BSD as BSD
37
38import UTmp ( users2, utmp_file, UtmpRecord(..), UT_Type(..) )
39import FGConsole ( monitorTTY )
40import XMPPServer ( Stanza, makePresenceStanza, JabberShow(..), stanzaType
41 , LangSpecificMessage(..), msgLangMap, cloneStanza, stanzaFrom )
42import ControlMaybe ( handleIO_ )
43import ClientState
44
45data ConsoleWriter = ConsoleWriter
46 { cwPresenceChan :: TMVar (ClientState,Stanza)
47 -- ^ tty switches and logins are announced on this mvar
48 , csActiveTTY :: TVar Word8
49 , csUtmp :: TVar (Map Text (TVar (Maybe UtmpRecord)))
50 , cwClients :: TVar (Map Text ClientState)
51 -- ^ This 'TVar' holds a map from resource id (tty name)
52 -- to ClientState for all active TTYs and PTYs.
53 }
54
55tshow :: forall a. Show a => a -> Text
56tshow x = Text.pack . show $ x
57
58retryWhen :: forall b. STM b -> (b -> Bool) -> STM b
59retryWhen var pred = do
60 value <- var
61 if pred value then retry
62 else return value
63
64
65onLogin ::
66 forall t.
67 ConsoleWriter
68 -> (STM (Word8, Maybe UtmpRecord)
69 -> TVar (Maybe UtmpRecord) -> IO ())
70 -> t
71 -> IO ()
72onLogin cs start = \e -> do
73 us <- UTmp.users2
74 let (m,cruft) =
75 foldl' (\(m,cruft) x ->
76 case utmpType x of
77 USER_PROCESS
78 -> (Map.insert (utmpTty x) x m,cruft)
79 DEAD_PROCESS | utmpPid x /= 0
80 -> (m,Map.insert (utmpTty x) x cruft)
81 _ -> (m,cruft))
82 (Map.empty,Map.empty)
83 us
84 forM_ (Map.elems cruft) $ \c -> do
85 putStrLn $ "cruft " ++ show (utmpTty c, utmpPid c,utmpHost c, utmpRemoteAddr c)
86 newborn <- atomically $ do
87 old <- readTVar (csUtmp cs) -- swapTVar (csUtmp cs) m
88 newborn <- flip Traversable.mapM (m Map.\\ old)
89 $ newTVar . Just
90 updated <- let upd v u = writeTVar v $ Just u
91 in Traversable.sequence $ Map.intersectionWith upd old m
92 let dead = old Map.\\ m
93 Traversable.mapM (flip writeTVar Nothing) dead
94 writeTVar (csUtmp cs) $ (old `Map.union` newborn) Map.\\ dead
95 return newborn
96 let getActive = do
97 tty <- readTVar $ csActiveTTY cs
98 utmp <- readTVar $ csUtmp cs
99 flip (maybe $ return (tty,Nothing))
100 (Map.lookup ("tty"<>tshow tty) utmp)
101 $ \tuvar -> do
102 tu <- readTVar tuvar
103 return (tty,tu)
104
105 forM_ (Map.elems newborn) $
106 forkIO . start getActive
107 -- forM_ (Map.elems dead ) $ putStrLn . ("gone: "++) . show
108
109-- | Sets up threads to monitor tty switches and logins that are
110-- written to the system utmp file and returns a 'ConsoleWriter'
111-- object for interacting with that information.
112newConsoleWriter :: IO ConsoleWriter
113newConsoleWriter = do
114 chan <- atomically $ newEmptyTMVar
115 cs <- atomically $ do
116 ttyvar <- newTVar 0
117 utmpvar <- newTVar Map.empty
118 clients <- newTVar Map.empty
119 return $ ConsoleWriter { cwPresenceChan = chan
120 , csActiveTTY = ttyvar
121 , csUtmp = utmpvar
122 , cwClients = clients
123 }
124 outvar <- atomically $ newTMVar ()
125 let logit outvar s = do
126 {-
127 atomically $ takeTMVar outvar
128 Text.putStrLn s
129 atomically $ putTMVar outvar ()
130 -}
131 return ()
132 onTTY outvar cs vtnum = do
133 logit outvar $ "switch: " <> tshow vtnum
134 atomically $ writeTVar (csActiveTTY cs) vtnum
135
136 inotify <- initINotify
137
138 -- get active tty
139 mtty <- monitorTTY (onTTY outvar cs)
140 atomically $ retryWhen (readTVar $ csActiveTTY cs) (==0)
141
142 -- read utmp
143 onLogin cs (newCon (logit outvar) cs) Modify
144
145 -- monitor utmp
146 wd <- addWatch
147 inotify
148 [Modify] -- [CloseWrite,Open,Close,Access,Modify,Move]
149 utmp_file
150 (onLogin cs (newCon (logit outvar) cs))
151 return cs
152
153-- Transforms a string of form language[_territory][.codeset][@modifier]
154-- typically used in LC_ locale variables into the BCP 47
155-- language codes used in xml:lang attributes.
156toBCP47 :: [Char] -> [Char]
157toBCP47 lang = map hyphen $ takeWhile (/='.') lang
158 where hyphen '_' = '-'
159 hyphen c = c
160
161#if MIN_VERSION_base(4,6,0)
162#else
163lookupEnv k = fmap (lookup k) getEnvironment
164#endif
165
166getPreferedLang :: IO Text
167getPreferedLang = do
168 lang <- do
169 lc_all <- lookupEnv "LC_ALL"
170 lc_messages <- lookupEnv "LC_MESSAGES"
171 lang <- lookupEnv "LANG"
172 return $ lc_all `mplus` lc_messages `mplus` lang
173 return $ maybe "en" (Text.pack . toBCP47) lang
174
175cimatch :: Text -> Text -> Bool
176cimatch w t = Text.toLower w == Text.toLower t
177
178cimatches :: Text -> [Text] -> [Text]
179cimatches w ts = dropWhile (not . cimatch w) ts
180
181-- rfc4647 lookup of best match language tag
182lookupLang :: [Text] -> [Text] -> Maybe Text
183lookupLang (w:ws) tags
184 | Text.null w = lookupLang ws tags
185 | otherwise = case cimatches w tags of
186 (t:_) -> Just t
187 [] -> lookupLang (reduce w:ws) tags
188 where
189 reduce w = Text.concat $ reverse nopriv
190 where
191 rparts = reverse . init $ Text.groupBy (\_ c -> c/='-') w
192 nopriv = dropWhile ispriv rparts
193 ispriv t = Text.length t == 2 && Text.head t == '-'
194
195lookupLang [] tags | "" `elem` tags = Just ""
196 | otherwise = listToMaybe $ tags
197
198
199messageText :: Stanza -> IO Text
200messageText msg = do
201 pref <- getPreferedLang
202 let m = msgLangMap (stanzaType msg)
203 key = lookupLang [pref] (map fst m)
204 choice = do
205 k <- key
206 lookup k m
207 flip (maybe $ return "") choice $ \choice -> do
208 let subj = fmap ("Subject: " <>) $ msgSubject choice
209 ts = catMaybes [subj, msgBody choice]
210 return $ Text.intercalate "\n\n" ts
211
212readEnvFile :: String -> FilePath -> IO (Maybe String)
213readEnvFile var file = fmap parse $ readFile file
214 where
215 parse xs = listToMaybe $ map (drop 1 . concat . drop 1) $ filter ofinterest bs
216 where
217 bs = map (groupBy (\_ x -> x/='=')) $ split (/='\0') xs
218 ofinterest (k:vs) | k==var = True
219 ofinterest _ = False
220
221 split pred xs = take 1 gs ++ map (drop 1) (drop 1 gs)
222 where
223 gs = groupBy (\_ x -> pred x) xs
224
225-- | Delivers an XMPP message stanza to the currently active
226-- tty. If that is a linux console, it will write to it similar
227-- to the manner of the BSD write command. If that is an X11
228-- display, it will attempt to notify the user via a libnotify
229-- interface.
230writeActiveTTY :: ConsoleWriter -> Stanza -> IO Bool
231writeActiveTTY cw msg = do
232 putStrLn $ "writeActiveTTY"
233 -- TODO: Do not deliver if the detination user does not own the active tty!
234 (tty, mbu) <- atomically $ do
235 num <- readTVar $ csActiveTTY cw
236 utmp <- readTVar $ csUtmp cw
237 mbu <- maybe (return Nothing) readTVar
238 $ Map.lookup ("tty"<>tshow num) utmp
239 return ( "/dev/tty" <> tshow num
240 , mbu )
241 flip (maybe $ return False) mbu $ \utmp -> do
242 display <- fmap (fmap Text.pack)
243 $ readEnvFile "DISPLAY" ("/proc/" ++ show (utmpPid utmp) ++ "/environ")
244 case fmap (==utmpHost utmp) display of
245 Just True -> deliverGUIMessage cw tty utmp msg
246 _ -> deliverTerminalMessage cw tty utmp msg
247
248deliverGUIMessage ::
249 forall t t1. t -> t1 -> UtmpRecord -> Stanza -> IO Bool
250deliverGUIMessage cw tty utmp msg = do
251 text <- do
252 t <- messageText msg
253 return $ Text.unpack
254 $ case stanzaFrom msg of
255 Just from -> from <> ": " <> t
256 Nothing -> t
257 putStrLn $ "deliverGUI: " ++ text
258 handleIO_ (return False) $ do
259 uentry <- getUserEntryForName (Text.unpack $ utmpUser utmp)
260 let display = Text.unpack $ utmpHost utmp
261 pid <- forkProcess $ do
262 setUserID (userID uentry)
263 setEnv "DISPLAY" display True
264 -- rawSystem "/usr/bin/notify-send" [text]
265 executeFile "/usr/bin/notify-send" False [text] (Just [("DISPLAY",display)])
266 exitImmediately ExitSuccess
267 return True
268
269crlf :: Text -> Text
270crlf t = Text.unlines $ map cr (Text.lines t)
271 where
272 cr t | Text.last t == '\r' = t
273 | otherwise = t <> "\r"
274
275deliverTerminalMessage ::
276 forall t t1. t -> Text -> t1 -> Stanza -> IO Bool
277deliverTerminalMessage cw tty utmp msg = do
278 mode <- fmap fileMode (getFileStatus $ Text.unpack tty)
279 let mesgy = mode .&. 0o020 /= 0 -- verify mode g+w
280 if not mesgy then return False else do
281 text <- do
282 t <- messageText msg
283 return $ Text.unpack
284 $ case stanzaFrom msg of
285 Just from -> "\r\n" <> from <> " says...\r\n" <> crlf t <> "\r\n"
286 Nothing -> crlf t <> "\r\n"
287 writeFile (Text.unpack tty) text
288 return True -- return True if a message was delivered
289
290-- | Deliver the given message to all a user's PTYs.
291writeAllPty :: ConsoleWriter -> Stanza -> IO Bool
292writeAllPty cw msg = do
293 -- TODO: filter only ptys owned by the destination user.
294 us <- atomically $ readTVar (csUtmp cw)
295 let ptys = Map.filterWithKey ispty us
296 ispty k _ = "pts/" `Text.isPrefixOf` k
297 && Text.all isDigit (Text.drop 4 k)
298 bs <- forM (Map.toList ptys) $ \(tty,utmp) -> do
299 deliverTerminalMessage cw ("/dev/" <> tty) utmp msg
300 return $ or bs
301
302resource :: UtmpRecord -> Text
303resource u =
304 case utmpTty u of
305 s | Text.take 3 s == "tty" -> s
306 s | Text.take 4 s == "pts/" -> "pty" <> Text.drop 4 s <> ":" <> utmpHost u
307 s -> escapeR s <> ":" <> utmpHost u
308 where
309 escapeR s = s
310
311textHostName :: IO Text
312textHostName = fmap Text.pack BSD.getHostName
313
314ujid :: UtmpRecord -> IO Text
315ujid u = do
316 h <- textHostName
317 return $ utmpUser u <> "@" <> h <> "/" <> resource u
318
319newCon :: (Text -> IO ())
320 -> ConsoleWriter
321 -> STM (Word8,Maybe UtmpRecord)
322 -> TVar (Maybe UtmpRecord)
323 -> IO ()
324newCon log cw activeTTY utmp = do
325 ((tty,tu),u) <- atomically $
326 liftM2 (,) activeTTY
327 (readTVar utmp)
328 flip (maybe $ return ()) u $ \u -> do
329 jid <- ujid u
330 log $ status (resource u) tty tu <> " " <> jid <> " pid=" <> tshow (utmpPid u)
331 <> (if istty (resource u)
332 then " host=" <> tshow (utmpHost u)
333 else "")
334 <> " session=" <> tshow (utmpSession u)
335 <> " addr=" <> tshow (utmpRemoteAddr u)
336 let r = resource u
337 stanza <- makePresenceStanza
338 "jabber:client"
339 (Just jid)
340 (jstatus r tty tu)
341 statusv <- atomically $ newTVar (Just stanza)
342 flgs <- atomically $ newTVar 0
343 let client = ClientState { clientResource = r
344 , clientUser = utmpUser u
345 , clientPid = Nothing
346 , clientStatus = statusv
347 , clientFlags = flgs }
348 atomically $ do
349 modifyTVar (cwClients cw) $ Map.insert r client
350 putTMVar (cwPresenceChan cw) (client,stanza)
351 loop client tty tu (Just u)
352 where
353 bstatus r ttynum mtu
354 = r == ttystr
355 || match mtu
356 where ttystr = "tty" <> tshow ttynum
357 searchstr mtu = maybe ttystr utmpHost $ do
358 tu <- mtu
359 guard (not $ Text.null $ utmpHost tu)
360 return tu
361 match mtu = searchstr mtu `Text.isInfixOf` Text.dropWhile (/=':') r
362 jstatus r ttynum tu =
363 if bstatus r ttynum tu
364 then Available
365 else Away
366 status r ttynum tu = tshow $ jstatus r ttynum tu
367
368 istty r = fst3 == "tty" && Text.all isDigit rst
369 where
370 (fst3,rst) = Text.splitAt 3 r
371
372 loop client tty tu u = do
373 what <- atomically $ foldr1 orElse
374 [ do (tty',tu') <- retryWhen activeTTY
375 (\ttyu -> bstatus r tty tu == uncurry (bstatus r) ttyu)
376 return $ ttyChanged tty' tu'
377 , do u' <- retryWhen (readTVar utmp) (==u)
378 return $ utmpChanged u'
379 ]
380 what
381 where
382 r = maybe "" resource u
383
384 ttyChanged tty' tu' = do
385 jid <- maybe (return "") ujid u
386 stanza <- makePresenceStanza
387 "jabber:client"
388 (Just jid)
389 (jstatus r tty' tu')
390 dup <- cloneStanza stanza
391 atomically $ do
392 writeTVar (clientStatus client) $ Just dup
393 putTMVar (cwPresenceChan cw) (client,stanza)
394 log $ status r tty' tu' <> " " <> jid
395 loop client tty' tu' u
396
397 utmpChanged u' = maybe dead changed u'
398 where
399 changed u' = do
400 jid0 <- maybe (return "") ujid u
401 jid <- ujid u'
402 log $ "changed: " <> jid0 <> " --> " <> jid
403 loop client tty tu (Just u')
404 dead = do
405 jid <- maybe (return "") ujid u
406 stanza <- makePresenceStanza "jabber:client" (Just jid) Offline
407 atomically $ do
408 modifyTVar (cwClients cw) $ Map.delete (clientResource client)
409 putTMVar (cwPresenceChan cw) (client,stanza)
410 log $ "Offline " <> jid
411
diff --git a/Presence/ControlMaybe.hs b/Presence/ControlMaybe.hs
new file mode 100644
index 00000000..659dab74
--- /dev/null
+++ b/Presence/ControlMaybe.hs
@@ -0,0 +1,29 @@
1{-# LANGUAGE ScopedTypeVariables #-}
2module ControlMaybe where
3
4-- import GHC.IO.Exception (IOException(..))
5import Control.Exception as Exception (IOException(..),catch)
6
7
8withJust :: Monad m => Maybe x -> (x -> m ()) -> m ()
9withJust (Just x) f = f x
10withJust Nothing f = return ()
11
12whenJust :: Monad m => m (Maybe x) -> (x -> m ()) -> m ()
13whenJust acn f = do
14 x <- acn
15 withJust x f
16
17
18catchIO_ :: IO a -> IO a -> IO a
19catchIO_ a h = Exception.catch a (\(_ :: IOException) -> h)
20
21catchIO :: IO a -> (IOException -> IO a) -> IO a
22catchIO body handler = Exception.catch body handler
23
24handleIO_ :: IO a -> IO a -> IO a
25handleIO_ = flip catchIO_
26
27
28handleIO :: (IOException -> IO a) -> IO a -> IO a
29handleIO = flip catchIO
diff --git a/Presence/DNSCache.hs b/Presence/DNSCache.hs
new file mode 100644
index 00000000..4a936d57
--- /dev/null
+++ b/Presence/DNSCache.hs
@@ -0,0 +1,261 @@
1-- | Both 'getAddrInfo' and 'getHostByAddr' have hard-coded timeouts for
2-- waiting upon network queries that can be a little too long for some use
3-- cases. This module wraps both of them so that they block for at most one
4-- second. It caches late-arriving results so that they can be returned by
5-- repeated timed-out queries.
6--
7-- In order to achieve the shorter timeout, it is likely that the you will need
8-- to build with GHC's -threaded option. Otherwise, if the wrapped FFI calls
9-- to resolve the address will block Haskell threads. Note: I didn't verify
10-- this.
11{-# LANGUAGE TupleSections #-}
12{-# LANGUAGE RankNTypes #-}
13module DNSCache
14 ( DNSCache
15 , reverseResolve
16 , forwardResolve
17 , newDNSCache
18 , parseAddress
19 , strip_brackets
20 , withPort
21 ) where
22
23import Control.Concurrent
24import Control.Concurrent.STM
25import Data.Text ( Text )
26import Network.Socket ( SockAddr(..), AddrInfoFlag(..), defaultHints, getAddrInfo, AddrInfo(..) )
27import Data.Time.Clock ( UTCTime, getCurrentTime, diffUTCTime )
28import System.IO.Error ( isDoesNotExistError )
29import System.Endian ( fromBE32, toBE32 )
30import Control.Exception ( handle, ErrorCall(..) )
31import Data.Map ( Map )
32import qualified Data.Map as Map
33import qualified Network.BSD as BSD
34import qualified Data.Text as Text
35import Control.Monad
36import Data.Function
37import Data.List
38import Data.Ord
39import Data.Maybe
40
41import SockAddr ()
42import ControlMaybe ( handleIO_ )
43import GetHostByAddr ( getHostByAddr )
44
45type TimeStamp = UTCTime
46
47data DNSCache =
48 DNSCache
49 { fcache :: TVar (Map Text [(TimeStamp, SockAddr)])
50 , rcache :: TVar (Map SockAddr [(TimeStamp, Text)])
51 }
52
53
54newDNSCache :: IO DNSCache
55newDNSCache = do
56 fcache <- newTVarIO Map.empty
57 rcache <- newTVarIO Map.empty
58 return DNSCache { fcache=fcache, rcache=rcache }
59
60updateCache :: Eq x =>
61 Bool -> TimeStamp -> [x] -> Maybe [(TimeStamp,x)] -> Maybe [(TimeStamp,x)]
62updateCache withScrub utc xs mys = do
63 let ys = maybe [] id mys
64 ys' = filter scrub ys
65 ys'' = map (utc,) xs ++ ys'
66 minute = 60
67 scrub (t,x) | withScrub && diffUTCTime utc t < minute = False
68 scrub (t,x) | x `elem` xs = False
69 scrub _ = True
70 guard $ not (null ys'')
71 return ys''
72
73dnsObserve :: DNSCache -> Bool -> TimeStamp -> [(Text,SockAddr)] -> STM ()
74dnsObserve dns withScrub utc obs = do
75 f <- readTVar $ fcache dns
76 r <- readTVar $ rcache dns
77 let obs' = map (\(n,a)->(n,a `withPort` 0)) obs
78 gs = do
79 g <- groupBy ((==) `on` fst) $ sortBy (comparing fst) obs'
80 (n,_) <- take 1 g
81 return (n,map snd g)
82 f' = foldl' updatef f gs
83 hs = do
84 h <- groupBy ((==) `on` snd) $ sortBy (comparing snd) obs'
85 (_,a) <- take 1 h
86 return (a,map fst h)
87 r' = foldl' updater r hs
88 writeTVar (fcache dns) f'
89 writeTVar (rcache dns) r'
90 where
91 updatef f (n,addrs) = Map.alter (updateCache withScrub utc addrs) n f
92 updater r (a,ns) = Map.alter (updateCache withScrub utc ns) a r
93
94make6mapped4 :: SockAddr -> SockAddr
95make6mapped4 addr@(SockAddrInet6 {}) = addr
96make6mapped4 addr@(SockAddrInet port a) = SockAddrInet6 port 0 (0,0,0xFFFF,fromBE32 a) 0
97
98-- Attempt to resolve the given domain name. Returns an empty list if the
99-- resolve operation takes longer than the timeout, but the 'DNSCache' will be
100-- updated when the resolve completes.
101--
102-- When the resolve operation does complete, any entries less than a minute old
103-- will be overwritten with the new results. Older entries are allowed to
104-- persist for reasons I don't understand as of this writing. (See 'updateCache')
105rawForwardResolve ::
106 DNSCache -> (Text -> IO ()) -> Int -> Text -> IO [SockAddr]
107rawForwardResolve dns fail timeout addrtext = do
108 r <- atomically newEmptyTMVar
109 mvar <- atomically newEmptyTMVar
110 rt <- forkOS $ resolver r mvar
111 -- TODO: System.Timeout.timeout might be more appropriate than this
112 -- hack involving throwTo (ErrorCall "Interrupteddelay").
113 tt <- forkIO $ timer (fail addrtext) timeout r rt
114 atomically $ putTMVar mvar tt
115 atomically $ readTMVar r
116 where
117 resolver r mvar = do
118 xs <- handle (\e -> let _ = isDoesNotExistError e in return [])
119 $ do fmap (nub . map (make6mapped4 . addrAddress)) $
120 getAddrInfo (Just $ defaultHints { addrFlags = [ AI_CANONNAME, AI_V4MAPPED ]})
121 (Just $ Text.unpack $ strip_brackets addrtext)
122 (Just "5269")
123 did <- atomically $ tryPutTMVar r xs
124 when did $ do
125 tt <- atomically $ readTMVar mvar
126 throwTo tt (ErrorCall "Interrupted delay")
127 utc <- getCurrentTime
128 atomically $ dnsObserve dns True utc $ map (addrtext,) xs
129 return ()
130
131strip_brackets :: Text -> Text
132strip_brackets s =
133 case Text.uncons s of
134 Just ('[',t) -> Text.takeWhile (/=']') t
135 _ -> s
136
137
138reportTimeout :: forall a. Show a => a -> IO ()
139reportTimeout addrtext = do
140 putStrLn $ "timeout resolving: "++show addrtext
141 -- killThread rt
142
143timer :: forall t a. IO () -> Int -> TMVar [a] -> t -> IO ()
144timer fail timeout r rt = do
145 handle (\(ErrorCall _)-> return ()) $ do
146 threadDelay timeout
147 did <- atomically $ tryPutTMVar r []
148 when did fail
149
150unmap6mapped4 :: SockAddr -> SockAddr
151unmap6mapped4 addr@(SockAddrInet6 port _ (0,0,0xFFFF,a) _) =
152 SockAddrInet port (toBE32 a)
153unmap6mapped4 addr = addr
154
155rawReverseResolve ::
156 DNSCache -> (SockAddr -> IO ()) -> Int -> SockAddr -> IO [Text]
157rawReverseResolve dns fail timeout addr = do
158 r <- atomically newEmptyTMVar
159 mvar <- atomically newEmptyTMVar
160 rt <- forkOS $ resolver r mvar
161 tt <- forkIO $ timer (fail addr) timeout r rt
162 atomically $ putTMVar mvar tt
163 atomically $ readTMVar r
164 where
165 resolver r mvar =
166 handleIO_ (return ()) $ do
167 ent <- getHostByAddr (unmap6mapped4 addr) -- AF_UNSPEC addr
168 let names = BSD.hostName ent : BSD.hostAliases ent
169 xs = map Text.pack $ nub names
170 forkIO $ do
171 utc <- getCurrentTime
172 atomically $ dnsObserve dns False utc $ map (,addr) xs
173 atomically $ putTMVar r xs
174
175-- Returns expired (older than a minute) cached reverse-dns results
176-- and removes them from the cache.
177expiredReverse :: DNSCache -> SockAddr -> IO [Text]
178expiredReverse dns addr = do
179 utc <- getCurrentTime
180 addr <- return $ addr `withPort` 0
181 es <- atomically $ do
182 r <- readTVar $ rcache dns
183 let ns = maybe [] id $ Map.lookup addr r
184 minute = 60 -- seconds
185 -- XXX: Is this right? flip diffUTCTime utc returns the age of the
186 -- cache entry?
187 (es0,ns') = partition ( (>=minute) . flip diffUTCTime utc . fst ) ns
188 es = map snd es0
189 modifyTVar' (rcache dns) $ Map.insert addr ns'
190 f <- readTVar $ fcache dns
191 let f' = foldl' (flip $ Map.alter (expire utc)) f es
192 expire utc Nothing = Nothing
193 expire utc (Just as) = if null as' then Nothing else Just as'
194 where as' = filter ( (<minute) . flip diffUTCTime utc . fst) as
195 writeTVar (fcache dns) f'
196 return es
197 return es
198
199cachedReverse :: DNSCache -> SockAddr -> IO [Text]
200cachedReverse dns addr = do
201 utc <- getCurrentTime
202 addr <- return $ addr `withPort` 0
203 atomically $ do
204 r <- readTVar (rcache dns)
205 let ns = maybe [] id $ Map.lookup addr r
206 {-
207 ns' = filter ( (<minute) . flip diffUTCTime utc . fst) ns
208 minute = 60 -- seconds
209 modifyTVar' (rcache dns) $ Map.insert addr ns'
210 return $ map snd ns'
211 -}
212 return $ map snd ns
213
214-- Returns any dns query results for the given name that were observed less
215-- than a minute ago and updates the forward-cache to remove any results older
216-- than that.
217cachedForward :: DNSCache -> Text -> IO [SockAddr]
218cachedForward dns n = do
219 utc <- getCurrentTime
220 atomically $ do
221 f <- readTVar (fcache dns)
222 let as = maybe [] id $ Map.lookup n f
223 as' = filter ( (<minute) . flip diffUTCTime utc . fst) as
224 minute = 60 -- seconds
225 modifyTVar' (fcache dns) $ Map.insert n as'
226 return $ map snd as'
227
228-- Reverse-resolves an address to a domain name. Returns both the result of a
229-- new query and any freshly cached results. Cache entries older than a minute
230-- will not be returned, but will be refreshed in spawned threads so that they
231-- may be available for the next call.
232reverseResolve :: DNSCache -> SockAddr -> IO [Text]
233reverseResolve dns addr = do
234 expired <- expiredReverse dns addr
235 forM_ expired $ \n -> forkIO $ do
236 rawForwardResolve dns (const $ return ()) 1000000 n
237 return ()
238 xs <- rawReverseResolve dns (const $ return ()) 1000000 addr
239 cs <- cachedReverse dns addr
240 return $ xs ++ filter (not . flip elem xs) cs
241
242-- Resolves a name, if there's no result within one second, then any cached
243-- results that are less than a minute old are returned.
244forwardResolve :: DNSCache -> Text -> IO [SockAddr]
245forwardResolve dns n = do
246 as <- rawForwardResolve dns (const $ return ()) 1000000 n
247 if null as
248 then cachedForward dns n
249 else return as
250
251parseAddress :: Text -> IO (Maybe SockAddr)
252parseAddress addr_str = do
253 info <- getAddrInfo (Just $ defaultHints { addrFlags = [ AI_NUMERICHOST ] })
254 (Just . Text.unpack $ addr_str)
255 (Just "0")
256 return . listToMaybe $ map addrAddress info
257
258
259withPort :: SockAddr -> Int -> SockAddr
260withPort (SockAddrInet _ a) port = SockAddrInet (toEnum port) a
261withPort (SockAddrInet6 _ a b c) port = SockAddrInet6 (toEnum port) a b c
diff --git a/Presence/EventUtil.hs b/Presence/EventUtil.hs
new file mode 100644
index 00000000..908e09e0
--- /dev/null
+++ b/Presence/EventUtil.hs
@@ -0,0 +1,83 @@
1{-# LANGUAGE OverloadedStrings #-}
2module EventUtil where
3
4import Control.Monad
5import Data.XML.Types as XML
6import qualified Data.List as List
7import Data.Text (Text)
8
9-- getStreamName (EventBeginElement name _) = name
10
11isEventBeginElement :: Event -> Bool
12isEventBeginElement (EventBeginElement {}) = True
13isEventBeginElement _ = False
14
15isEventEndElement :: Event -> Bool
16isEventEndElement (EventEndElement {}) = True
17isEventEndElement _ = False
18
19-- Note: This function ignores name space qualification
20elementAttrs ::
21 MonadPlus m =>
22 Text -> Event -> m [(Name, [Content])]
23elementAttrs expected (EventBeginElement name attrs)
24 | nameLocalName name==expected
25 = return attrs
26elementAttrs _ _ = mzero
27
28streamP :: Text -> Name
29streamP name = Name name (Just "http://etherx.jabber.org/streams") (Just "stream")
30
31attr :: Name -> Text -> (Name,[Content])
32attr name value = (name,[ContentText value])
33
34isServerIQOf :: Event -> Text -> Bool
35isServerIQOf (EventBeginElement name attrs) testType
36 | name=="{jabber:server}iq"
37 && matchAttrib "type" testType attrs
38 = True
39isServerIQOf _ _ = False
40
41isClientIQOf :: Event -> Text -> Bool
42isClientIQOf (EventBeginElement name attrs) testType
43 | name=="{jabber:client}iq"
44 && matchAttrib "type" testType attrs
45 = True
46isClientIQOf _ _ = False
47
48matchAttrib :: Name -> Text -> [(Name, [Content])] -> Bool
49matchAttrib name value attrs =
50 case List.find ( (==name) . fst) attrs of
51 Just (_,[ContentText x]) | x==value -> True
52 Just (_,[ContentEntity x]) | x==value -> True
53 _ -> False
54
55lookupAttrib :: Name -> [(Name, [Content])] -> Maybe Text
56lookupAttrib name attrs =
57 case List.find ( (==name) . fst) attrs of
58 Just (_,[ContentText x]) -> Just x
59 Just (_,[ContentEntity x]) -> Just x
60 _ -> Nothing
61
62tagAttrs :: Event -> [(Name, [Content])]
63tagAttrs (EventBeginElement _ xs) = xs
64tagAttrs _ = []
65
66
67{-
68iqTypeSet = "set"
69iqTypeGet = "get"
70iqTypeResult = "result"
71iqTypeError = "error"
72-}
73
74
75tagName :: Event -> Name
76tagName (EventBeginElement n _) = n
77tagName _ = ""
78
79closerFor :: Event -> Event
80closerFor (EventBeginElement n _) = EventEndElement n
81closerFor _ = error "closerFor: unsupported event"
82
83
diff --git a/Presence/FGConsole.hs b/Presence/FGConsole.hs
new file mode 100644
index 00000000..623fb493
--- /dev/null
+++ b/Presence/FGConsole.hs
@@ -0,0 +1,62 @@
1{-# LANGUAGE ForeignFunctionInterface #-}
2{-# LANGUAGE ScopedTypeVariables #-}
3module FGConsole where
4
5import Data.Word
6import System.Posix.IO
7import System.Posix.Types
8import Control.Concurrent
9-- import GHC.IO.Handle
10import Unsafe.Coerce
11import Control.Exception as E
12-- import Prelude as E
13import Control.Monad
14import Foreign.C.Error
15import Foreign.C
16
17import Logging
18import System.Posix.Signals
19
20-- c_monitorTTY fd = trace "c_monitorTTY" (return ()) -- (trace "WTF" todo)
21
22foreign import ccall "monitorTTY" c_monitorTTY :: Fd -> IO ()
23foreign import ccall "closeTTY" c_closeTTY :: IO ()
24
25monitorTTY :: (Word8 -> IO ()) -> IO (Fd,ThreadId)
26monitorTTY handler = do
27 (rfd,wfd) <- createPipe
28 thread <- forkIO $ do
29 let cleanup = do
30 trace "quitting monitorTTY thread." (return ())
31 closeFd wfd `E.catch` \(e::IOException) -> return ()
32 closeFd rfd `E.catch` \(e::IOException) -> return ()
33 c_closeTTY
34 -- rh <- fdToHandle rfd
35 c_monitorTTY wfd
36 let monitor =
37 (do
38 threadWaitRead rfd
39 (cs,cnt) <- fdRead rfd 1
40 forM_ cs (handler . unsafeCoerce {- . trace "read byte" -})
41 monitor)
42 `E.catch`
43 \(e :: IOException) -> do
44 err <- getErrno
45 case () of
46 _ | err==eAGAIN -> monitor
47 _ | otherwise -> cleanup
48 `E.catch`
49 \(e :: AsyncException) -> cleanup
50 monitor
51 return (rfd,thread)
52
53unmonitorTTY :: (Fd, ThreadId) -> IO ()
54unmonitorTTY (rfd,thread) = do
55 closeFd rfd
56 yield
57 killThread thread
58 raiseSignal sigUSR1
59 -- threadDelay 1000000
60
61
62-- vim:ft=haskell:
diff --git a/Presence/GetHostByAddr.hs b/Presence/GetHostByAddr.hs
new file mode 100644
index 00000000..45bca5e9
--- /dev/null
+++ b/Presence/GetHostByAddr.hs
@@ -0,0 +1,77 @@
1{-# LANGUAGE ForeignFunctionInterface #-}
2module GetHostByAddr where
3
4import Network.BSD
5import Foreign.Ptr
6import Foreign.C.Types
7import Foreign.Storable (Storable(..))
8import Foreign.Marshal.Utils (with)
9import Foreign.Marshal.Alloc
10import Control.Concurrent
11import System.IO.Unsafe
12import System.IO.Error (ioeSetErrorString, mkIOError)
13import Network.Socket
14import GHC.IO.Exception
15
16
17throwNoSuchThingIfNull :: String -> String -> IO (Ptr a) -> IO (Ptr a)
18throwNoSuchThingIfNull loc desc act = do
19 ptr <- act
20 if (ptr == nullPtr)
21 then ioError (ioeSetErrorString (mkIOError NoSuchThing loc Nothing Nothing) desc)
22 else return ptr
23
24{-# NOINLINE lock #-}
25lock :: MVar ()
26lock = unsafePerformIO $ newMVar ()
27
28withLock :: IO a -> IO a
29withLock act = withMVar lock (\_ -> act)
30
31trySysCall :: IO a -> IO a
32trySysCall act = act
33
34{-
35-- The locking of gethostbyaddr is similar to gethostbyname.
36-- | Get a 'HostEntry' corresponding to the given address and family.
37-- Note that only IPv4 is currently supported.
38getHostByAddr :: Family -> SockAddr -> IO HostEntry
39getHostByAddr family addr = do
40 withSockAddr addr $ \ ptr_addr len -> withLock $ do
41 throwNoSuchThingIfNull "getHostByAddr" "no such host entry"
42 $ trySysCall $ c_gethostbyaddr ptr_addr (fromIntegral len) (packFamily family)
43 >>= peek
44-}
45
46
47-- The locking of gethostbyaddr is similar to gethostbyname.
48-- | Get a 'HostEntry' corresponding to the given address and family.
49-- Note that only IPv4 is currently supported.
50-- getHostByAddr :: Family -> HostAddress -> IO HostEntry
51-- getHostByAddr family addr = do
52getHostByAddr :: SockAddr -> IO HostEntry
53getHostByAddr (SockAddrInet port addr ) = do
54 let family = AF_INET
55 with addr $ \ ptr_addr -> withLock $ do
56 throwNoSuchThingIfNull "getHostByAddr" "no such host entry"
57 $ trySysCall $ c_gethostbyaddr ptr_addr (fromIntegral (sizeOf addr)) (packFamily family)
58 >>= peek
59getHostByAddr (SockAddrInet6 port flow (a,b,c,d) scope) = do
60 let family = AF_INET6
61 allocaBytes 16 $ \ ptr_addr -> do
62 pokeElemOff ptr_addr 0 a
63 pokeElemOff ptr_addr 1 b
64 pokeElemOff ptr_addr 2 c
65 pokeElemOff ptr_addr 3 d
66 withLock $ do
67 throwNoSuchThingIfNull "getHostByAddr" "no such host entry"
68 $ trySysCall $ c_gethostbyaddr ptr_addr 16 (packFamily family)
69 >>= peek
70
71
72foreign import ccall safe "gethostbyaddr"
73 c_gethostbyaddr :: Ptr a -> CInt -> CInt -> IO (Ptr HostEntry)
74
75
76
77-- vim:ft=haskell:
diff --git a/Presence/IDMangler.hs b/Presence/IDMangler.hs
new file mode 100644
index 00000000..664d4f54
--- /dev/null
+++ b/Presence/IDMangler.hs
@@ -0,0 +1,68 @@
1---------------------------------------------------------------------------
2-- |
3-- Module : IDMangler
4--
5-- This library is useful for generating id attributes for use in an XMPP
6-- application. It conveniently encodes a key value for looking up context and
7-- an original id attribute in case of forwarded messages.
8--
9-- For example, an id attribute with an embedded 'XMPPServer.ConnectionKey'
10-- for a forwarded message with an original id attribute of \"purplecfa6168a\"
11-- might look something like this:
12--
13-- > AAAAAAAAAAIBksnqOQiYmtmupcLxbXakI9zcmUl4:purplecfa6168a
14--
15{-# LANGUAGE OverloadedStrings #-}
16module IDMangler
17 ( IDMangler
18 , newIDMangler
19 , generateUniqueID
20 , unmangleId
21 ) where
22
23import Control.Monad.STM
24import Control.Concurrent.STM
25import Data.Text (Text)
26import qualified Data.Text as Text
27import qualified Data.ByteString.Lazy as LazyByteString
28import Data.Binary
29import qualified Codec.Binary.Base64 as Base64
30import Control.Monad
31import Data.Monoid ( (<>) )
32
33
34data IDMangler k
35 = IDMangler { idmCounter :: TVar Int }
36
37newIDMangler :: IO (IDMangler k)
38newIDMangler = do
39 nv <- atomically $ newTVar 0
40 return $ IDMangler nv
41
42-- | Use the given state and optional data to generate a unique id attribute
43-- suitable for xml. To recover the optional encoded data, see 'unmangleId'.
44generateUniqueID :: Binary k =>
45 IDMangler k -- ^ the state (a counter) for ensuring uniqueness
46 -> Maybe k -- ^ optional recoverable key for context
47 -> Maybe Text -- ^ optional recoverable auxilary id attribute
48 -> IO Text -- ^ unique id attribute with encoded data
49generateUniqueID mangler mkey mid = do
50 n <- atomically $ do
51 modifyTVar' (idmCounter mangler) (+1)
52 readTVar (idmCounter mangler)
53 let bs = encode (n,mkey)
54 base64 = Base64.encode (LazyByteString.unpack bs)
55 suf = maybe "" (":" <>) mid
56 return $ Text.pack base64 <> suf
57
58-- | Recover data from an encoded id attribute.
59unmangleId :: Binary k => Text -> (Maybe k, Maybe Text)
60unmangleId encoded = (k,mid)
61 where
62 (e,postcolon) = Text.span (/=':') encoded
63 bytes = Base64.decode (Text.unpack e)
64 decoded = fmap (decode . LazyByteString.pack) bytes
65 k = decoded >>= (\(n,k) -> let _ = n :: Int in k)
66 mid = do guard (not . Text.null $ postcolon)
67 return $ Text.drop 1 postcolon
68
diff --git a/Presence/LocalPeerCred.hs b/Presence/LocalPeerCred.hs
new file mode 100644
index 00000000..6f7735dd
--- /dev/null
+++ b/Presence/LocalPeerCred.hs
@@ -0,0 +1,213 @@
1{-# LANGUAGE ViewPatterns #-}
2{-# LANGUAGE TupleSections #-}
3module LocalPeerCred where
4
5import System.Endian
6import qualified Data.ByteString.Lazy.Char8 as L
7 -- hiding (map,putStrLn,tail,splitAt,tails,filter)
8 -- import qualified Data.ByteString.Lazy.Char8 as L (splitAt)
9import qualified Data.ByteString.Lazy as W8
10import Data.List as List (tails,groupBy)
11import System.IO ( withFile, IOMode(..))
12import System.Directory
13import Control.Arrow (first)
14import Data.Char
15import Data.Maybe
16import Data.Binary
17import Data.Bits
18import System.Posix.Types
19import System.Posix.Files
20import Logging
21import SocketLike
22import ControlMaybe
23
24xs ?? n | n < 0 = Nothing
25[] ?? _ = Nothing
26(x:_) ?? 0 = Just x
27(_:xs) ?? n = xs ?? (n-1)
28
29parseHex bs = L.concat . parseHex' $ bs
30 where
31 parseHex' bs =
32 let (dnib,ts) = L.splitAt 2 bs
33 parseNibble x = W8.pack $ group2 toW8 (W8.unpack $ W8.map hexDigit x)
34 hexDigit d = d - (if d>0x39 then 0x37 else 0x30)
35 group2 f (x:y:ys) = f x y : group2 f ys
36 group2 _ _ = []
37 toW8 a b = shift a 4 .|. b
38 in parseNibble dnib :
39 if L.null ts
40 then []
41 else parseHex' ts
42
43getLocalPeerCred' (unmap6mapped4 -> SockAddrInet portn host) = do
44 let port = fromEnum portn
45 {- trace ("tcp4 "++show(port,host)) $ -}
46 withFile "/proc/net/tcp" ReadMode (parseProcNet port host)
47
48getLocalPeerCred' (unmap6mapped4 -> SockAddrInet6 portn flow host scope) = do
49 let port = fromEnum portn
50 (a,b,c,d) = host
51 host' = (toBE32 a, toBE32 b, toBE32 c, toBE32 d)
52 withFile "/proc/net/tcp6" ReadMode (parseProcNet port host')
53
54getLocalPeerCred' (unmap6mapped4 -> addr@(SockAddrUnix _)) =
55 -- TODO: parse /proc/net/unix
56 -- see also: Network.Socket.getPeerCred
57 return Nothing
58
59getLocalPeerCred sock = do
60 addr <- getPeerName sock
61 muid <- getLocalPeerCred' addr
62 case muid of
63 Just (uid,inode) -> return (Just uid)
64 Nothing -> trace "proc failed." $ fmap (validate . CUid . fromIntegral . sndOf3) (getPeerCred sock)
65 where sndOf3 (pid,uid,gid) = uid
66 where
67 validate uid = Just uid -- TODO
68
69from16 :: Word16 -> Int
70from16 = fromEnum
71
72as16 :: Word16 -> Word16
73as16 = id
74
75parseProcNet port host h = do
76 tcp <- L.hGetContents h -- Failed: tcp <- hFileSize h >>= hGet h . fromIntegral
77 let u = do
78 ls <- listToMaybe . tail . tails . L.lines $ tcp
79 let ws = map L.words ls
80 let rs = ( catMaybes . flip map ws $ \xs -> do
81 let ys = snd (Prelude.splitAt 1 xs)
82 localaddr <- listToMaybe ys
83 let zs = L.splitWith (==':') localaddr
84 addr <- fmap parseHex $ listToMaybe zs
85 port <- fmap (fromIntegral . as16 . decode . parseHex) $ listToMaybe $ snd (Prelude.splitAt 1 zs)
86 let ys' = snd (Prelude.splitAt 5 (tail ys))
87 ys'' = snd (Prelude.splitAt 2 ys')
88 uid <- listToMaybe ys'
89 inode <- listToMaybe ys''
90 let peer = (port,decode addr)
91 user = toEnum (read (L.unpack uid) ::Int) ::UserID -- CUid . fromIntegral $ (read (unpack uid)::Int)
92 return $ {-trace ("peer:"++show(peer,user,inode))-} (peer,(user,inode))
93 )
94 fmap snd . listToMaybe $ filter ((==(port,host)).fst) rs
95 {- trace ("found: "++show u) -}
96 u `seq` return u
97 {-
98 where
99 a === b = let r= a==b in trace ("Comparing "++show (a,b)++"-->"++show r) r
100 -}
101
102
103-- PEER NAME: [::ffff:127.0.0.1]:34307
104unmap6mapped4 addr@(SockAddrInet6 port _ (0,0,0xFFFF,a) _) = SockAddrInet port (toBE32 a)
105unmap6mapped4 addr = addr
106
107identifyTTY ::
108 [(W8.ByteString, ProcessID)]
109 -> UserID -> W8.ByteString -> IO (Maybe W8.ByteString, Maybe CPid)
110identifyTTY tty_pids uid inode = do
111 pid <- scanProc (show uid) (L.unpack inode)
112 -- putStrLn $ "scanProc --> "++show pid
113 flip (maybe (return (Nothing,Nothing))) pid $ \(pid,ttydev) -> do
114 tty <- ttyOrDisplay pid ttydev
115 -- putStrLn $ "users = " ++ show tty_pids
116 dts <- ttyToXorgs tty_pids
117 -- putStrLn $ "displays = " ++ show dts
118 -- putStrLn $ "tty = " ++ show tty
119 -- -- displays = [(":5",Chunk "tty7" Empty)]
120 let tty' = if take 3 tty=="tty"
121 then Just (L.pack tty)
122 else lookup (parseTty tty) (map (first parseTty) dts)
123 return (tty',Just pid)
124 where
125 parseTty :: String -> Float
126 parseTty = read . tail . dropWhile (/=':')
127
128ttyToXorgs :: Show a => [(t, a)] -> IO [([Char], t)]
129ttyToXorgs tty_pids = do
130 dts' <- flip mapM tty_pids $ \(tty,pid) -> do
131 cmd' <- readFile $ "/proc/"++show pid++"/cmdline"
132 case listToMaybe . words . takeWhile (/='\0') $ cmd' of
133 Nothing -> return Nothing
134 Just cmd -> do
135 if notElem cmd ["gdm-session-worker"]
136 then return Nothing
137 else do
138 display <- readDisplayVariable pid
139 return (fmap ( (,tty) . snd ) display)
140 let dts = catMaybes dts'
141 return dts
142
143
144scanProc uid inode = do
145 contents <- getDirectoryContents "/proc" `catchIO_` return []
146 let pids = reverse $ filter (\n -> not (null n) && isDigit (head n)) contents
147 let searchPids [] = return Nothing
148 searchPids (pid:pids) = do
149 loginuid <- fmap makeUidStr $ readFile $ "/proc/"++pid++"/loginuid"
150 if False -- (uid/=loginuid) -- this check proved bad when mcabber ran on tty3
151 then searchPids pids
152 else do
153 -- putStrLn $ "pid "++show pid ++ " --> uid "++show loginuid
154 let loop [] = return Nothing
155 loop ("0":fds) = loop fds
156 loop (fd:fds) = do
157 handleIO_ (loop fds) $ do
158 what <- readSymbolicLink $ "/proc/"++pid++"/fd/"++fd
159 -- putStrLn $ " what= "++show what
160 if (what=="socket:["++inode++"]")
161 then do
162 tty <- readSymbolicLink $ "/proc/"++pid++"/fd/0"
163 return (Just (pid,tty))
164 else loop fds
165 -- requires root (or same user as for pid)...
166 fds <- getDirectoryContents ("/proc/"++pid++"/fd") `catchIO_` return []
167 mb <- loop fds
168 maybe (searchPids pids) (return . Just) mb
169
170 fmap (fmap (first (read :: String -> CPid))) $ searchPids pids
171
172ttyOrDisplay pid ttydev = do
173 ptty <- searchParentsForTTY (show pid) ttydev
174 case ptty of
175 Just tty -> return tty
176 Nothing -> do
177 display <- readDisplayVariable pid
178 -- putStrLn $ "display = " ++ show display
179 case display of
180 Just (_,disp) -> return disp
181 _ -> return ttydev
182
183
184readDisplayVariable pid = do
185 env <- handleIO_ (return "")
186 . readFile $ "/proc/"++show pid++"/environ"
187 let vs = unzero $ List.groupBy (\_ c->c/='\0') env
188 unzero [] = []
189 unzero (v:vs) = v:map tail vs
190 keyvalue xs = (key,value)
191 where
192 (key,ys) = break (=='=') xs
193 value = case ys of { [] -> []; (_:ys') -> ys' }
194 display = listToMaybe
195 . filter ((=="DISPLAY").fst)
196 . map keyvalue
197 $ vs
198 return display
199
200
201makeUidStr "4294967295" = "invalid"
202makeUidStr uid = uid
203
204
205searchParentsForTTY pid ttydev | take 8 ttydev == "/dev/tty" = return . Just $ drop 5 ttydev
206searchParentsForTTY "1" ttydev | otherwise = return Nothing
207searchParentsForTTY pid ttydev = do
208 stat <- handleIO_ (return "") . readFile $ "/proc/"++pid++"/stat"
209 case words stat ?? 3 of
210 Nothing -> return Nothing
211 Just ppid -> do
212 tty <- handleIO_ (return "") $ readSymbolicLink $ "/proc/"++ppid++"/fd/0"
213 searchParentsForTTY ppid tty
diff --git a/Presence/LockedChan.hs b/Presence/LockedChan.hs
new file mode 100644
index 00000000..eac2b5ad
--- /dev/null
+++ b/Presence/LockedChan.hs
@@ -0,0 +1,78 @@
1{-# LANGUAGE CPP #-}
2module LockedChan
3 ( LockedChan
4 , cloneLChan
5 , newLockedChan
6 , peekLChan
7 , unlockChan
8 , writeLChan )
9 where
10
11
12import Control.Monad.STM
13import Control.Concurrent.STM
14
15data LockedChan a = LockedChan
16 { lock :: TVar Bool
17 , chan :: TChan a
18 }
19
20unlockChan :: LockedChan a -> IO (TChan a)
21unlockChan c = do
22 waslocked <- atomically $ swapTVar (lock c) False
23 if waslocked
24 then return (chan c)
25 else error "Attempt to read unlocked channel"
26
27writeLChan :: LockedChan a -> a -> STM ()
28writeLChan c a = writeTChan (chan c) a
29
30-- This one blocks rather than throwing an exception...
31-- todo: probably this should be changed to conform to the rest
32-- of the api.
33peekLChan :: LockedChan a -> STM a
34peekLChan c = do
35 readTVar (lock c) >>= check
36 peekTChan (chan c)
37
38newLockedChan :: STM (LockedChan a)
39newLockedChan = do
40 lock <- newTVar True
41 chan <- newTChan
42 return $ LockedChan lock chan
43
44cloneLChan :: LockedChan a -> IO (LockedChan a)
45cloneLChan c = do
46 mchan <- atomically $ do
47 locked <- readTVar (lock c)
48 if locked
49 then fmap Just $ do
50 c2 <- cloneTChan (chan c)
51 l2 <- newTVar True
52 return $ LockedChan l2 c2
53 else return Nothing
54 maybe (do putStrLn "LockedChan: Attempt to clone unlocked channel"
55 error "Attempt to clone unlocked channel")
56 return
57 mchan
58
59#if MIN_VERSION_stm(2,4,0)
60#else
61-- |Clone a 'TChan': similar to dupTChan, but the cloned channel starts with the
62-- same content available as the original channel.
63--
64-- Terrible inefficient implementation provided to build against older libraries.
65cloneTChan :: TChan a -> STM (TChan a)
66cloneTChan chan = do
67 contents <- chanContents' chan
68 chan2 <- dupTChan chan
69 mapM_ (writeTChan chan) contents
70 return chan2
71 where
72 chanContents' chan = do
73 b <- isEmptyTChan chan
74 if b then return [] else do
75 x <- readTChan chan
76 xs <- chanContents' chan
77 return (x:xs)
78#endif
diff --git a/Presence/Logging.hs b/Presence/Logging.hs
new file mode 100644
index 00000000..b997d341
--- /dev/null
+++ b/Presence/Logging.hs
@@ -0,0 +1,25 @@
1{-# LANGUAGE RankNTypes #-}
2module Logging where
3
4import qualified Data.ByteString.Lazy.Char8 as L
5import qualified Data.ByteString.Char8 as S
6import qualified Data.Text.IO as Text
7import qualified Data.Text as Text
8import qualified Debug.Trace as Debug
9
10debugL :: L.ByteString -> IO ()
11debugS :: S.ByteString -> IO ()
12debugStr :: String -> IO ()
13debugText :: Text.Text -> IO ()
14trace :: forall a. String -> a -> a
15
16
17debugStr str = putStrLn str
18
19debugL bs = L.putStrLn bs
20
21debugS bs = S.putStrLn bs
22
23debugText text = Text.putStrLn text
24
25trace str a = Debug.trace str a
diff --git a/Presence/Nesting.hs b/Presence/Nesting.hs
new file mode 100644
index 00000000..720237fd
--- /dev/null
+++ b/Presence/Nesting.hs
@@ -0,0 +1,88 @@
1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE FlexibleContexts #-}
3module Nesting where
4
5import Data.Conduit
6import Data.Conduit.Lift
7import Data.XML.Types
8import qualified Data.Text as S
9import Control.Monad.State.Strict
10import qualified Data.List as List
11
12type Lang = S.Text
13
14data StrictList a = a :! !(StrictList a) | StrictNil
15
16data XMLState = XMLState {
17 nestingLevel :: Int,
18 langStack :: StrictList (Int,Lang)
19}
20
21type NestingXML o m a = ConduitM Event o (StateT XMLState m) a
22
23doNestingXML :: Monad m => NestingXML o m r -> ConduitM Event o m r
24doNestingXML m =
25 evalStateC (XMLState 0 StrictNil) (trackNesting =$= m)
26
27nesting :: Monad m => NestingXML o m Int
28nesting = lift $ (return . nestingLevel) =<< get
29
30xmlLang :: Monad m => NestingXML o m (Maybe Lang)
31xmlLang = fmap (fmap snd . top . langStack) (lift get)
32 where
33 top ( a :! _as ) = Just a
34 top _ = Nothing
35
36trackNesting :: Monad m => Conduit Event (StateT XMLState m) Event
37trackNesting = awaitForever doit
38 where
39 doit xml = do
40 XMLState lvl langs <- lift get
41 lift . put $ case xml of
42 EventBeginElement _ attrs ->
43 case lookupLang attrs of
44 Nothing -> XMLState (lvl+1) langs
45 Just lang -> XMLState (lvl+1) ( (lvl+1,lang) :! langs)
46 EventEndElement _ ->
47 case langs of
48 (llvl,_) :! ls | llvl==lvl -> XMLState (lvl-1) ls
49 _ | otherwise -> XMLState (lvl-1) langs
50 _ -> XMLState lvl langs
51 yield xml
52
53
54lookupLang :: [(Name, [Content])] -> Maybe S.Text
55lookupLang attrs =
56 case List.find ( (=="xml:lang") . fst) attrs of
57 Just (_,[ContentText x]) -> Just x
58 Just (_,[ContentEntity x]) -> Just x
59 _ -> Nothing
60
61
62awaitCloser :: Monad m => Int -> NestingXML o m ()
63awaitCloser lvl =
64 fix $ \loop -> do
65 lvl' <- nesting
66 when (lvl' >= lvl) $ do
67 xml <- await
68 maybe (return ()) (const loop) xml
69
70withXML ::
71 Monad m =>
72 (i -> ConduitM i o m ()) -> ConduitM i o m ()
73withXML f = await >>= maybe (return ()) f
74
75nextElement :: Monad m => NestingXML o m (Maybe Event)
76nextElement = do
77 lvl <- nesting
78 fix $ \loop -> do
79 xml <- await
80 case xml of
81 Nothing -> return Nothing
82 Just (EventBeginElement _ _) -> return xml
83 Just _ -> do
84 lvl' <- nesting
85 if (lvl'>=lvl) then loop
86 else return Nothing
87
88
diff --git a/Presence/Paths.hs b/Presence/Paths.hs
new file mode 100644
index 00000000..9d51b66e
--- /dev/null
+++ b/Presence/Paths.hs
@@ -0,0 +1,62 @@
1{-# LANGUAGE CPP #-}
2module Paths where
3
4#include <paths.h>
5
6bshell :: String
7console :: String
8cshell :: String
9devdb :: String
10devnull :: String
11drum :: String
12gshadow :: String
13klog :: String
14kmem :: String
15lastlog :: String
16maildir :: String
17man :: String
18mem :: String
19mnttab :: String
20mounted :: String
21nologin :: String
22preserve :: String
23rwhodir :: String
24sendmail :: String
25shadow :: String
26shells :: String
27tty :: String
28unix :: String
29utmp :: String
30vi :: String
31wtmp :: String
32
33
34
35bshell = _PATH_BSHELL
36console = _PATH_CONSOLE
37cshell = _PATH_CSHELL
38devdb = _PATH_DEVDB
39devnull = _PATH_DEVNULL
40drum = _PATH_DRUM
41gshadow = _PATH_GSHADOW
42klog = _PATH_KLOG
43kmem = _PATH_KMEM
44lastlog = _PATH_LASTLOG
45maildir = _PATH_MAILDIR
46man = _PATH_MAN
47mem = _PATH_MEM
48mnttab = _PATH_MNTTAB
49mounted = _PATH_MOUNTED
50nologin = _PATH_NOLOGIN
51preserve = _PATH_PRESERVE
52rwhodir = _PATH_RWHODIR
53sendmail = _PATH_SENDMAIL
54shadow = _PATH_SHADOW
55shells = _PATH_SHELLS
56tty = _PATH_TTY
57unix = _PATH_UNIX
58utmp = _PATH_UTMP
59vi = _PATH_VI
60wtmp = _PATH_WTMP
61
62
diff --git a/Presence/PeerResolve.hs b/Presence/PeerResolve.hs
new file mode 100644
index 00000000..0854b365
--- /dev/null
+++ b/Presence/PeerResolve.hs
@@ -0,0 +1,39 @@
1module PeerResolve
2 ( peerKeyToResolvedNames
3 , resolvePeer
4 , parseAddress
5 , strip_brackets
6 , withPort
7 ) where
8
9import Data.List ( nub )
10import Data.Text ( Text )
11import Network.Socket ( SockAddr(..) )
12import System.Endian ( fromBE32, toBE32 )
13import System.IO.Error ( isDoesNotExistError )
14import Control.Exception ( handle, ErrorCall(..) )
15import qualified Network.BSD as BSD
16import qualified Data.Text as Text
17import Control.Concurrent
18import Control.Concurrent.STM
19import Control.Monad
20import Data.Maybe
21import System.IO.Unsafe
22
23import GetHostByAddr
24import DNSCache
25import ConnectionKey
26import ControlMaybe
27
28{-# NOINLINE global_dns_cache #-}
29global_dns_cache :: DNSCache
30global_dns_cache = unsafePerformIO $ newDNSCache
31
32resolvePeer :: Text -> IO [SockAddr]
33resolvePeer addrtext = forwardResolve global_dns_cache addrtext
34
35peerKeyToResolvedNames :: ConnectionKey -> IO [Text]
36peerKeyToResolvedNames k@(ClientKey { localAddress=addr }) = return []
37peerKeyToResolvedNames k@(PeerKey { callBackAddress=addr }) = do
38 reverseResolve global_dns_cache addr
39
diff --git a/Presence/Server.hs b/Presence/Server.hs
new file mode 100644
index 00000000..f7f99907
--- /dev/null
+++ b/Presence/Server.hs
@@ -0,0 +1,851 @@
1{-# OPTIONS_HADDOCK prune #-}
2{-# LANGUAGE CPP #-}
3{-# LANGUAGE StandaloneDeriving #-}
4{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE TupleSections #-}
6{-# LANGUAGE FlexibleInstances #-}
7-----------------------------------------------------------------------------
8-- |
9-- Module : Server
10--
11-- Maintainer : joe@jerkface.net
12-- Stability : experimental
13--
14-- A TCP client/server library.
15--
16-- TODO: XXX: A newer version of this code is in the server.git repo. XXX
17--
18-- * interface tweaks
19--
20{-# LANGUAGE DoAndIfThenElse #-}
21module Server where
22
23import Data.ByteString (ByteString,hGetNonBlocking)
24import qualified Data.ByteString.Char8 as S -- ( hPutStrLn, hPutStr, pack)
25#if MIN_VERSION_containers(0,5,0)
26import qualified Data.Map.Strict as Map
27import Data.Map.Strict (Map)
28#else
29import qualified Data.Map as Map
30import Data.Map (Map)
31#endif
32import Data.Monoid ( (<>) )
33import Control.Concurrent
34import Control.Concurrent.STM
35-- import Control.Concurrent.STM.TMVar
36-- import Control.Concurrent.STM.TChan
37-- import Control.Concurrent.STM.Delay
38import Control.Exception ({-evaluate,-}handle,SomeException(..),bracketOnError,ErrorCall(..))
39import Control.Monad
40import Control.Monad.Fix
41-- import Control.Monad.STM
42import Control.Monad.Trans.Resource
43import Control.Monad.IO.Class (MonadIO (liftIO))
44import System.IO.Error (ioeGetErrorType,isDoesNotExistError)
45import System.IO
46 ( IOMode(..)
47 , hSetBuffering
48 , BufferMode(..)
49 , hWaitForInput
50 , hClose
51 , hIsEOF
52 , stderr
53 , stdout
54 , Handle
55 , hFlush
56 )
57import Network.Socket
58import Network.BSD
59 ( getProtocolNumber
60 )
61import Debug.Trace
62import Data.Time.Clock (UTCTime,getCurrentTime,diffUTCTime)
63import Data.Time.Format (formatTime)
64import SockAddr ()
65-- import System.Locale (defaultTimeLocale)
66
67todo = error "unimplemented"
68
69type Microseconds = Int
70type Miliseconds = Int
71type TimeOut = Miliseconds
72type PingInterval = Miliseconds
73
74-- | This object is passed with the 'Listen' and 'Connect'
75-- instructions in order to control the behavior of the
76-- connections that are established. It is parameterized
77-- by a user-suplied type @conkey@ that is used as a lookup
78-- key for connections.
79data ConnectionParameters conkey u =
80 ConnectionParameters
81 { pingInterval :: PingInterval
82 -- ^ The miliseconds of idle to allow before a 'RequiresPing'
83 -- event is signaled.
84 , timeout :: TimeOut
85 -- ^ The miliseconds of idle after 'RequiresPing' is signaled
86 -- that are necessary for the connection to be considered
87 -- lost and signalling 'EOF'.
88 , makeConnKey :: (Socket,SockAddr) -> IO (conkey,u)
89 -- ^ This action creates a lookup key for a new connection. If 'duplex'
90 -- is 'True' and the result is already assocatied with an established
91 -- connection, then an 'EOF' will be forced before the the new
92 -- connection becomes active.
93 --
94 , duplex :: Bool
95 -- ^ If True, then the connection will be treated as a normal
96 -- two-way socket. Otherwise, a readable socket is established
97 -- with 'Listen' and a writable socket is established with
98 -- 'Connect' and they are associated when 'makeConnKey' yields
99 -- same value for each.
100 }
101
102-- | Use this function to select appropriate default values for
103-- 'ConnectionParameters' other than 'makeConnKey'.
104--
105-- Current defaults:
106--
107-- * 'pingInterval' = 28000
108--
109-- * 'timeout' = 2000
110--
111-- * 'duplex' = True
112--
113connectionDefaults
114 :: ((Socket, SockAddr) -> IO (conkey,u)) -> ConnectionParameters conkey u
115connectionDefaults f = ConnectionParameters
116 { pingInterval = 28000
117 , timeout = 2000
118 , makeConnKey = f
119 , duplex = True
120 }
121
122-- | Instructions for a 'Server' object
123--
124-- To issue a command, put it into the 'serverCommand' TMVar.
125data ServerInstruction conkey u
126 = Quit
127 -- ^ kill the server. This command is automatically issued when
128 -- the server is released.
129 | Listen PortNumber (ConnectionParameters conkey u)
130 -- ^ listen for incomming connections
131 | Connect SockAddr (ConnectionParameters conkey u)
132 -- ^ connect to addresses
133 | ConnectWithEndlessRetry SockAddr
134 (ConnectionParameters conkey u)
135 Miliseconds
136 -- ^ keep retrying the connection
137 | Ignore PortNumber
138 -- ^ stop listening on specified port
139 | Send conkey ByteString
140 -- ^ send bytes to an established connection
141
142#ifdef TEST
143deriving instance Show conkey => Show (ServerInstruction conkey)
144instance Show (a -> b) where show _ = "<function>"
145deriving instance Show conkey => Show (ConnectionParameters conkey)
146#endif
147
148-- | This type specifies which which half of a half-duplex
149-- connection is of interest.
150data InOrOut = In | Out
151 deriving (Enum,Eq,Ord,Show,Read)
152
153-- | These events may be read from 'serverEvent' TChannel.
154--
155data ConnectionEvent b
156 = Got b
157 -- ^ Arrival of data from a socket
158 | Connection (STM Bool) (IO (Maybe ByteString)) (ByteString -> IO Bool)
159 -- ^ A new connection was established
160 | ConnectFailure SockAddr
161 -- ^ A 'Connect' command failed.
162 | HalfConnection InOrOut
163 -- ^ Half of a half-duplex connection is avaliable.
164 | EOF
165 -- ^ A connection was terminated
166 | RequiresPing
167 -- ^ 'pingInterval' miliseconds of idle was experienced
168
169#ifdef TEST
170instance Show (IO a) where show _ = "<IO action>"
171instance Show (STM a) where show _ = "<STM action>"
172instance Eq (ByteString -> IO Bool) where (==) _ _ = True
173instance Eq (IO (Maybe ByteString)) where (==) _ _ = True
174instance Eq (STM Bool) where (==) _ _ = True
175deriving instance Show b => Show (ConnectionEvent b)
176deriving instance Eq b => Eq (ConnectionEvent b)
177#endif
178
179-- | This is the per-connection state.
180data ConnectionRecord u
181 = ConnectionRecord { ckont :: TMVar (STM (IO ())) -- ^ used to pass a continuation to update the eof-handler
182 , cstate :: ConnectionState -- ^ used to send/receive data to the connection
183 , cdata :: u -- ^ user data, stored in the connection map for convenience
184 }
185
186-- | This object accepts commands and signals events and maintains
187-- the list of currently listening ports and established connections.
188data Server a u
189 = Server { serverCommand :: TMVar (ServerInstruction a u)
190 , serverEvent :: TChan ((a,u), ConnectionEvent ByteString)
191 , serverReleaseKey :: ReleaseKey
192 , conmap :: TVar (Map a (ConnectionRecord u))
193 , listenmap :: TVar (Map PortNumber (ThreadId,Socket))
194 , retrymap :: TVar (Map SockAddr (TVar Bool,InterruptableDelay))
195 }
196
197control sv = atomically . putTMVar (serverCommand sv)
198
199-- | Construct a 'Server' object. Use 'Control.Monad.Trans.Resource.ResourceT'
200-- to ensure proper cleanup. For example,
201--
202-- > import Server
203-- > import Control.Monad.Trans.Resource (runResourceT)
204-- > import Control.Monad.IO.Class (liftIO)
205-- > import Control.Monad.STM (atomically)
206-- > import Control.Concurrent.STM.TMVar (putTMVar)
207-- > import Control.Concurrent.STM.TChan (readTChan)
208-- >
209-- > main = runResourceT $ do
210-- > sv <- server
211-- > let params = connectionDefaults (return . snd)
212-- > liftIO . atomically $ putTMVar (serverCommand sv) (Listen 2942 params)
213-- > let loop = do
214-- > (_,event) <- atomically $ readTChan (serverEvent sv)
215-- > case event of
216-- > Got bytes -> putStrLn $ "got: " ++ show bytes
217-- > _ -> return ()
218-- > case event of EOF -> return ()
219-- > _ -> loop
220-- > liftIO loop
221server :: (Show a,Ord a, MonadIO m, MonadResource m) => m (Server a u)
222server = do
223 (key,cmds) <- allocate (atomically newEmptyTMVar)
224 (atomically . flip putTMVar Quit)
225 server <- liftIO . atomically $ do
226 tchan <- newTChan
227 conmap <- newTVar Map.empty
228 listenmap<- newTVar Map.empty
229 retrymap <- newTVar Map.empty
230 return Server { serverCommand = cmds
231 , serverEvent = tchan
232 , serverReleaseKey = key
233 , conmap = conmap
234 , listenmap = listenmap
235 , retrymap = retrymap
236 }
237 liftIO $ do
238 forkIO $ fix $ \loop -> do
239 instr <- atomically $ takeTMVar cmds
240 -- warn $ "instr = " <> bshow instr
241 let again = do doit server instr
242 -- warn $ "finished " <> bshow instr
243 loop
244 case instr of Quit -> closeAll server
245 _ -> again
246 return server
247 where
248 closeAll server = liftIO $ do
249 listening <- atomically . readTVar $ listenmap server
250 mapM_ killListener (Map.elems listening)
251 let stopRetry (v,d) = do atomically $ writeTVar v False
252 interruptDelay d
253 retriers <- atomically $ do
254 rmap <- readTVar $ retrymap server
255 writeTVar (retrymap server) Map.empty
256 return rmap
257 mapM_ stopRetry (Map.elems retriers)
258 cons <- atomically . readTVar $ conmap server
259 atomically $ mapM_ (connClose . cstate) (Map.elems cons)
260 atomically $ mapM_ (connWait . cstate) (Map.elems cons)
261 atomically $ writeTVar (conmap server) Map.empty
262
263
264 doit server (Listen port params) = liftIO $ do
265
266 listening <- Map.member port
267 `fmap` atomically (readTVar $ listenmap server)
268 when (not listening) $ do
269
270 let family = AF_INET6
271
272 sock <- socket family Stream 0
273 setSocketOption sock ReuseAddr 1
274 let address =
275 case family of
276 AF_INET -> SockAddrInet port iNADDR_ANY
277 AF_INET6 -> SockAddrInet6 port 0 iN6ADDR_ANY 0
278 fix $ \loop -> do
279 handle (\(SomeException e)-> do
280 warn $ "BIND-ERROR:"<>bshow address <> " " <> bshow e
281 threadDelay 5000000
282 loop)
283 $ bindSocket sock address
284 listen sock 2
285 thread <- forkIO $ acceptLoop server params sock
286 atomically $ listenmap server `modifyTVar'` Map.insert port (thread,sock)
287
288 doit server (Ignore port) = liftIO $ do
289 mb <- atomically $ do
290 map <- readTVar $ listenmap server
291 modifyTVar' (listenmap server) $ Map.delete port
292 return $ Map.lookup port map
293 maybe (return ()) killListener $ mb
294
295 doit server (Send con bs) = liftIO $ do -- . void . forkIO $ do
296 map <- atomically $ readTVar (conmap server)
297 let post False = (trace ("cant send: "++show bs) $ return ())
298 post True = return ()
299 maybe (post False)
300 (post <=< flip connWrite bs . cstate)
301 $ Map.lookup con map
302
303 doit server (Connect addr params) = liftIO $ do
304 mb <- atomically $ do
305 rmap <- readTVar (retrymap server)
306 return $ Map.lookup addr rmap
307 maybe forkit
308 (\(v,d) -> do b <- atomically $ readTVar v
309 interruptDelay d
310 when (not b) forkit)
311 mb
312 where
313 forkit = void . forkIO $ do
314 proto <- getProtocolNumber "tcp"
315 sock <- socket (socketFamily addr) Stream proto
316 handle (\e -> do -- let t = ioeGetErrorType e
317 when (isDoesNotExistError e) $ return () -- warn "GOTCHA"
318 -- warn $ "connect-error: " <> bshow e
319 (conkey,u) <- makeConnKey params (sock,addr) -- XXX: ?
320 sClose sock
321 atomically
322 $ writeTChan (serverEvent server)
323 $ ((conkey,u),ConnectFailure addr))
324 $ do
325 connect sock addr
326 me <- getSocketName sock
327 (conkey,u) <- makeConnKey params (sock,me)
328 h <- socketToHandle sock ReadWriteMode
329 newConnection server params conkey u h Out
330 return ()
331
332 doit server (ConnectWithEndlessRetry addr params interval) = liftIO $ do
333 proto <- getProtocolNumber "tcp"
334 void . forkIO $ do
335 resultVar <- atomically newEmptyTMVar
336 timer <- interruptableDelay
337 (retryVar,action) <- atomically $ do
338 let noop = return ()
339 map <- readTVar (retrymap server)
340 let mb = Map.lookup addr map
341 action <-
342 maybe (return noop)
343 (\(v,d) -> do writeTVar v False
344 return $ interruptDelay d)
345 mb
346 v <- newTVar True
347 writeTVar (retrymap server) (Map.insert addr (v,timer) map)
348 return (v,action)
349 action
350 fix $ \retryLoop -> do
351 utc <- getCurrentTime
352 forkIO $ do
353 sock <- socket (socketFamily addr) Stream proto
354 handle (\e -> do -- let t = ioeGetErrorType e
355 when (isDoesNotExistError e) $ return () -- warn "GOTCHA"
356 -- warn $ "connect-error: " <> bshow e
357 -- Weird hack: puting the would-be peer address
358 -- instead of local socketName
359 (conkey,u) <- makeConnKey params (sock,addr) -- XXX: ?
360 sClose sock
361 atomically $ do
362 writeTChan (serverEvent server)
363 $ ((conkey,u),ConnectFailure addr)
364 retry <- readTVar retryVar
365 putTMVar resultVar retry)
366 $ do
367 connect sock addr
368 me <- getSocketName sock
369 (conkey,u) <- makeConnKey params (sock,me)
370 h <- socketToHandle sock ReadWriteMode
371 threads <- newConnection server params conkey u h Out
372 atomically $ do threadsWait threads
373 retry <- readTVar retryVar
374 putTMVar resultVar retry
375 retry <- atomically $ takeTMVar resultVar
376 fin_utc <- getCurrentTime
377 when retry $ do
378 let elapsed = 1000.0 * (fin_utc `diffUTCTime` utc)
379 expected = fromIntegral interval
380 when (retry && elapsed < expected) $ do
381 debugNoise $ "Waiting to retry " <> bshow addr
382 void $ startDelay timer (round $ 1000 * (expected-elapsed))
383 debugNoise $ "retry " <> bshow (retry,addr)
384 when retry $ retryLoop
385
386
387-- INTERNAL ----------------------------------------------------------
388
389{-
390hWriteUntilNothing h outs =
391 fix $ \loop -> do
392 mb <- atomically $ takeTMVar outs
393 case mb of Just bs -> do S.hPutStrLn h bs
394 warn $ "wrote " <> bs
395 loop
396 Nothing -> do warn $ "wrote Nothing"
397 hClose h
398
399-}
400connRead :: ConnectionState -> IO (Maybe ByteString)
401connRead (WriteOnlyConnection w) = do
402 -- atomically $ discardContents (threadsChannel w)
403 return Nothing
404connRead conn = do
405 c <- atomically $ getThreads
406 threadsRead c
407 where
408 getThreads =
409 case conn of SaneConnection c -> return c
410 ReadOnlyConnection c -> return c
411 ConnectionPair c w -> do
412 -- discardContents (threadsChannel w)
413 return c
414
415socketFamily (SockAddrInet _ _) = AF_INET
416socketFamily (SockAddrInet6 _ _ _ _) = AF_INET6
417socketFamily (SockAddrUnix _) = AF_UNIX
418
419killListener (thread,sock) = do sClose sock
420 -- killThread thread
421
422
423conevent con = Connection pingflag read write
424 where
425 pingflag = swapTVar (pingFlag (connPingTimer con)) False
426 read = connRead con
427 write = connWrite con
428
429newConnection server params conkey u h inout = do
430 hSetBuffering h NoBuffering
431 let (forward,idle_ms,timeout_ms) =
432 case (inout,duplex params) of
433 (Out,False) -> ( const $ return ()
434 , 0
435 , 0 )
436 _ -> ( announce . ((conkey,u),) . Got
437 , pingInterval params
438 , timeout params )
439
440 new <- do pinglogic <- pingMachine idle_ms timeout_ms
441 connectionThreads h pinglogic
442 started <- atomically $ newEmptyTMVar
443 kontvar <- atomically newEmptyTMVar
444 forkIO $ do
445 getkont <- atomically $ takeTMVar kontvar
446 kont <- atomically getkont
447 kont
448
449 atomically $ do
450 current <- fmap (Map.lookup conkey) $ readTVar (conmap server)
451 case current of
452 Nothing -> do
453 (newCon,e) <- return $
454 if duplex params
455 then let newcon = SaneConnection new
456 in ( newcon, ((conkey,u), conevent newcon) )
457 else ( case inout of
458 In -> ReadOnlyConnection new
459 Out -> WriteOnlyConnection new
460 , ((conkey,u), HalfConnection inout) )
461 modifyTVar' (conmap server) $ Map.insert conkey
462 ConnectionRecord { ckont = kontvar
463 , cstate = newCon
464 , cdata = u }
465 announce e
466 putTMVar kontvar $ return $ do
467 atomically $ putTMVar started ()
468 handleEOF conkey u kontvar newCon
469 Just what@ConnectionRecord { ckont =mvar }-> do
470 putTMVar kontvar $ return $ return ()
471 putTMVar mvar $ do
472 kont <- updateConMap conkey u new what
473 putTMVar started ()
474 return kont
475#ifdef TEST
476 -- enable this for 'Got' events
477 forkIO $ do -- inout==In || duplex params then forkIO $ do
478 warn $ "waiting gots thread: " <> bshow (conkey,inout)
479 atomically $ takeTMVar started
480 -- pingBump pinglogic -- start the ping timer
481 fix $ \loop -> do
482 -- warn $ "read thread: " <> bshow (conkey,inout)
483 mb <- threadsRead new
484 -- pingBump pinglogic
485 warn $ "got: " <> bshow (mb,(conkey,inout))
486 maybe (return ())
487 (atomically . forward >=> const loop)
488 mb
489 warn $ "quit-gots: " <> bshow (conkey,inout)
490#endif
491 return new
492 where
493
494 announce e = writeTChan (serverEvent server) e
495
496 handleEOF conkey u mvar newCon = do
497 action <- atomically . foldr1 orElse $
498 [ takeTMVar mvar >>= id -- passed continuation
499 , connWait newCon >> return eof
500 , connWaitPing newCon >>= return . sendPing
501 -- , pingWait pingTimer >>= return . sendPing
502 ]
503 action :: IO ()
504 where
505 eof = do
506 -- warn $ "EOF " <>bshow conkey
507 connCancelPing newCon
508 atomically $ do connFlush newCon
509 announce ((conkey,u),EOF)
510 modifyTVar' (conmap server)
511 $ Map.delete conkey
512 -- warn $ "fin-EOF "<>bshow conkey
513
514 sendPing PingTimeOut = do
515 {-
516 utc <- getCurrentTime
517 let utc' = formatTime defaultTimeLocale "%s" utc
518 warn $ "ping:TIMEOUT " <> bshow utc'
519 -}
520 atomically (connClose newCon)
521 eof
522
523 sendPing PingIdle = do
524 {-
525 utc <- getCurrentTime
526 let utc' = formatTime defaultTimeLocale "%s" utc
527 -- warn $ "ping:IDLE " <> bshow utc'
528 -}
529 atomically $ announce ((conkey,u),RequiresPing)
530 handleEOF conkey u mvar newCon
531
532
533 updateConMap conkey u new (ConnectionRecord { ckont=mvar, cstate=replaced, cdata=u0 }) = do
534 new' <-
535 if duplex params then do
536 announce ((conkey,u),EOF)
537 connClose replaced
538 let newcon = SaneConnection new
539 announce $ ((conkey,u),conevent newcon)
540 return $ newcon
541 else
542 case replaced of
543 WriteOnlyConnection w | inout==In ->
544 do let newcon = ConnectionPair new w
545 announce ((conkey,u),conevent newcon)
546 return newcon
547 ReadOnlyConnection r | inout==Out ->
548 do let newcon = ConnectionPair r new
549 announce ((conkey,u),conevent newcon)
550 return newcon
551 _ -> do -- connFlush todo
552 announce ((conkey,u0), EOF)
553 connClose replaced
554 announce ((conkey,u), HalfConnection inout)
555 return $ case inout of
556 In -> ReadOnlyConnection new
557 Out -> WriteOnlyConnection new
558 modifyTVar' (conmap server) $ Map.insert conkey
559 ConnectionRecord { ckont = mvar
560 , cstate = new'
561 , cdata = u }
562 return $ handleEOF conkey u mvar new'
563
564acceptLoop server params sock = handle (acceptException server params sock) $ do
565 con <- accept sock
566 (conkey,u) <- makeConnKey params con
567 h <- socketToHandle (fst con) ReadWriteMode
568 newConnection server params conkey u h In
569 acceptLoop server params sock
570
571acceptException server params sock ioerror = do
572 sClose sock
573 case show (ioeGetErrorType ioerror) of
574 "resource exhausted" -> do -- try again
575 warn ("acceptLoop: resource exhasted")
576 threadDelay 500000
577 acceptLoop server params sock
578 "invalid argument" -> do -- quit on closed socket
579 return ()
580 message -> do -- unexpected exception
581 warn ("acceptLoop: "<>bshow message)
582 return ()
583
584
585
586getPacket h = do hWaitForInput h (-1)
587 hGetNonBlocking h 1024
588
589
590
591-- | 'ConnectionThreads' is an interface to a pair of threads
592-- that are reading and writing a 'Handle'.
593data ConnectionThreads = ConnectionThreads
594 { threadsWriter :: TMVar (Maybe ByteString)
595 , threadsChannel :: TChan ByteString
596 , threadsWait :: STM () -- ^ waits for a 'ConnectionThreads' object to close
597 , threadsPing :: PingMachine
598 }
599
600-- | This spawns the reader and writer threads and returns a newly
601-- constructed 'ConnectionThreads' object.
602connectionThreads :: Handle -> PingMachine -> IO ConnectionThreads
603connectionThreads h pinglogic = do
604
605 (donew,outs) <- atomically $ liftM2 (,) newEmptyTMVar newEmptyTMVar
606
607 (doner,incomming) <- atomically $ liftM2 (,) newEmptyTMVar newTChan
608 readerThread <- forkIO $ do
609 let finished e = do
610 hClose h
611 -- warn $ "finished read: " <> bshow (fmap ioeGetErrorType e)
612 -- let _ = fmap ioeGetErrorType e -- type hint
613 let _ = fmap what e where what (SomeException _) = undefined
614 atomically $ do tryTakeTMVar outs
615 putTMVar outs Nothing -- quit writer
616 putTMVar doner ()
617 handle (finished . Just) $ do
618 pingBump pinglogic -- start the ping timer
619 fix $ \loop -> do
620 packet <- getPacket h
621 -- warn $ "read: " <> S.take 60 packet
622 atomically $ writeTChan incomming packet
623 pingBump pinglogic
624 -- warn $ "bumped: " <> S.take 60 packet
625 isEof <- liftIO $ hIsEOF h
626 if isEof then finished Nothing else loop
627
628 writerThread <- forkIO . fix $ \loop -> do
629 let finished = do -- warn $ "finished write"
630 -- hClose h -- quit reader
631 throwTo readerThread (ErrorCall "EOF")
632 atomically $ putTMVar donew ()
633 mb <- atomically $ readTMVar outs
634 case mb of Just bs -> handle (\(SomeException e)->finished)
635 (do -- warn $ "writing: " <> S.take 60 bs
636 S.hPutStr h bs
637 -- warn $ "wrote: " <> S.take 60 bs
638 atomically $ takeTMVar outs
639 loop)
640 Nothing -> finished
641
642 let wait = do readTMVar donew
643 readTMVar doner
644 return ()
645 return ConnectionThreads { threadsWriter = outs
646 , threadsChannel = incomming
647 , threadsWait = wait
648 , threadsPing = pinglogic }
649
650
651-- | 'threadsWrite' writes the given 'ByteString' to the
652-- 'ConnectionThreads' object. It blocks until the ByteString
653-- is written and 'True' is returned, or the connection is
654-- interrupted and 'False' is returned.
655threadsWrite :: ConnectionThreads -> ByteString -> IO Bool
656threadsWrite c bs = atomically $
657 orElse (const False `fmap` threadsWait c)
658 (const True `fmap` putTMVar (threadsWriter c) (Just bs))
659
660-- | 'threadsClose' signals for the 'ConnectionThreads' object
661-- to quit and close the associated 'Handle'. This operation
662-- is non-blocking, follow it with 'threadsWait' if you want
663-- to wait for the operation to complete.
664threadsClose :: ConnectionThreads -> STM ()
665threadsClose c = do
666 let mvar = threadsWriter c
667 v <- tryReadTMVar mvar
668 case v of
669 Just Nothing -> return () -- already closed
670 _ -> putTMVar mvar Nothing
671
672-- | 'threadsRead' blocks until a 'ByteString' is available which
673-- is returned to the caller, or the connection is interrupted and
674-- 'Nothing' is returned.
675threadsRead :: ConnectionThreads -> IO (Maybe ByteString)
676threadsRead c = atomically $
677 orElse (const Nothing `fmap` threadsWait c)
678 (Just `fmap` readTChan (threadsChannel c))
679
680-- | A 'ConnectionState' is an interface to a single 'ConnectionThreads'
681-- or to a pair of 'ConnectionThreads' objects that are considered as one
682-- connection.
683data ConnectionState =
684 SaneConnection ConnectionThreads
685 -- ^ ordinary read/write connection
686 | WriteOnlyConnection ConnectionThreads
687 | ReadOnlyConnection ConnectionThreads
688 | ConnectionPair ConnectionThreads ConnectionThreads
689 -- ^ Two 'ConnectionThreads' objects, read operations use the
690 -- first, write operations use the second.
691
692
693
694connWrite :: ConnectionState -> ByteString -> IO Bool
695connWrite (ReadOnlyConnection _) bs = return False
696connWrite conn bs = threadsWrite c bs
697 where
698 c = case conn of SaneConnection c -> c
699 WriteOnlyConnection c -> c
700 ConnectionPair _ c -> c
701
702
703mapConn :: Bool ->
704 (ConnectionThreads -> STM ()) -> ConnectionState -> STM ()
705mapConn both action c =
706 case c of
707 SaneConnection rw -> action rw
708 ReadOnlyConnection r -> action r
709 WriteOnlyConnection w -> action w
710 ConnectionPair r w -> do
711 rem <- orElse (const w `fmap` action r)
712 (const r `fmap` action w)
713 when both $ action rem
714
715connClose :: ConnectionState -> STM ()
716connClose c = mapConn True threadsClose c
717
718connWait :: ConnectionState -> STM ()
719connWait c = doit -- mapConn False threadsWait c
720 where
721 action = threadsWait
722 doit =
723 case c of
724 SaneConnection rw -> action rw
725 ReadOnlyConnection r -> action r
726 WriteOnlyConnection w -> action w
727 ConnectionPair r w -> do
728 rem <- orElse (const w `fmap` action r)
729 (const r `fmap` action w)
730 threadsClose rem
731
732connPingTimer c =
733 case c of
734 SaneConnection rw -> threadsPing rw
735 ReadOnlyConnection r -> threadsPing r
736 WriteOnlyConnection w -> threadsPing w -- should be disabled.
737 ConnectionPair r w -> threadsPing r
738
739connCancelPing c = pingCancel (connPingTimer c)
740connWaitPing c = pingWait (connPingTimer c)
741
742
743connFlush c =
744 case c of
745 SaneConnection rw -> waitChan rw
746 ReadOnlyConnection r -> waitChan r
747 WriteOnlyConnection w -> return ()
748 ConnectionPair r w -> waitChan r
749 where
750 waitChan t = do
751 b <- isEmptyTChan (threadsChannel t)
752 when (not b) retry
753
754bshow e = S.pack . show $ e
755warn str = S.hPutStrLn stderr str >> hFlush stderr
756debugNoise str = return ()
757
758
759data PingEvent = PingIdle | PingTimeOut
760
761data PingMachine = PingMachine
762 { pingFlag :: TVar Bool
763 , pingInterruptable :: InterruptableDelay
764 , pingEvent :: TMVar PingEvent
765 , pingStarted :: TMVar Bool
766 }
767
768pingMachine :: PingInterval -> TimeOut -> IO PingMachine
769pingMachine idle timeout = do
770 d <- interruptableDelay
771 flag <- atomically $ newTVar False
772 canceled <- atomically $ newTVar False
773 event <- atomically newEmptyTMVar
774 started <- atomically $ newEmptyTMVar
775 when (idle/=0) $ void . forkIO $ do
776 (>>=) (atomically (readTMVar started)) $ flip when $ do
777 fix $ \loop -> do
778 atomically $ writeTVar flag False
779 fin <- startDelay d (1000*idle)
780 (>>=) (atomically (readTMVar started)) $ flip when $ do
781 if (not fin) then loop
782 else do
783 -- Idle event
784 atomically $ do
785 tryTakeTMVar event
786 putTMVar event PingIdle
787 writeTVar flag True
788 fin <- startDelay d (1000*timeout)
789 (>>=) (atomically (readTMVar started)) $ flip when $ do
790 me <- myThreadId
791 if (not fin) then loop
792 else do
793 -- Timeout event
794 atomically $ do
795 tryTakeTMVar event
796 writeTVar flag False
797 putTMVar event PingTimeOut
798 return PingMachine
799 { pingFlag = flag
800 , pingInterruptable = d
801 , pingEvent = event
802 , pingStarted = started
803 }
804
805pingCancel :: PingMachine -> IO ()
806pingCancel me = do
807 atomically $ do tryTakeTMVar (pingStarted me)
808 putTMVar (pingStarted me) False
809 interruptDelay (pingInterruptable me)
810
811pingBump :: PingMachine -> IO ()
812pingBump me = do
813 atomically $ do
814 b <- tryReadTMVar (pingStarted me)
815 when (b/=Just False) $ do
816 tryTakeTMVar (pingStarted me)
817 putTMVar (pingStarted me) True
818 interruptDelay (pingInterruptable me)
819
820pingWait :: PingMachine -> STM PingEvent
821pingWait me = takeTMVar (pingEvent me)
822
823
824data InterruptableDelay = InterruptableDelay
825 { delayThread :: TMVar ThreadId
826 }
827
828interruptableDelay :: IO InterruptableDelay
829interruptableDelay = do
830 fmap InterruptableDelay
831 $ atomically newEmptyTMVar
832
833startDelay :: InterruptableDelay -> Microseconds -> IO Bool
834startDelay d interval = do
835 thread <- myThreadId
836 handle (\(ErrorCall _)-> do
837 debugNoise $ "delay interrupted"
838 return False) $ do
839 atomically $ putTMVar (delayThread d) thread
840 threadDelay interval
841 void . atomically $ takeTMVar (delayThread d)
842 return True
843
844interruptDelay :: InterruptableDelay -> IO ()
845interruptDelay d = do
846 mthread <- atomically $ do
847 tryTakeTMVar (delayThread d)
848 flip (maybe $ return ()) mthread $ \thread -> do
849 throwTo thread (ErrorCall "Interrupted delay")
850
851
diff --git a/Presence/SockAddr.hs b/Presence/SockAddr.hs
new file mode 100644
index 00000000..91a03870
--- /dev/null
+++ b/Presence/SockAddr.hs
@@ -0,0 +1,13 @@
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE StandaloneDeriving #-}
3module SockAddr () where
4
5import Network.Socket ( SockAddr(..) )
6
7#if MIN_VERSION_network(2,4,0)
8#else
9deriving instance Ord SockAddr
10#endif
11
12
13
diff --git a/Presence/SocketLike.hs b/Presence/SocketLike.hs
new file mode 100644
index 00000000..af0249ae
--- /dev/null
+++ b/Presence/SocketLike.hs
@@ -0,0 +1,76 @@
1{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2module SocketLike
3 ( SocketLike
4 , getSocketName
5 , getPeerName
6 , getPeerCred
7 , socketPort
8 , sIsConnected
9 , sIsBound
10 , sIsListening
11 , sIsReadable
12 , sIsWritable
13 , sClose
14 , RestrictedSocket
15 , restrictSocket
16 , restrictHandleSocket
17 , PortNumber
18 , SockAddr(..)
19 , CUInt
20 ) where
21
22import Network.Socket
23 ( PortNumber
24 , SockAddr
25 )
26import Foreign.C.Types ( CUInt )
27
28import qualified Network.Socket as NS
29import System.IO (Handle,hClose)
30
31class SocketLike sock where
32 getSocketName :: sock -> IO SockAddr
33 getPeerName :: sock -> IO SockAddr
34 getPeerCred :: sock -> IO (CUInt, CUInt, CUInt)
35 socketPort :: sock -> IO PortNumber
36 sIsConnected :: sock -> IO Bool
37 sIsBound :: sock -> IO Bool
38 sIsListening :: sock -> IO Bool
39 sIsReadable :: sock -> IO Bool
40 sIsWritable :: sock -> IO Bool
41 sClose :: sock -> IO ()
42
43instance SocketLike NS.Socket where
44 getSocketName = NS.getSocketName
45 getPeerName = NS.getPeerName
46 getPeerCred = NS.getPeerCred
47 socketPort = NS.socketPort
48 sIsConnected = NS.sIsConnected -- warning: this is always False if the socket
49 -- was converted to a Handle
50 sIsBound = NS.sIsBound
51 sIsListening = NS.sIsListening
52 sIsReadable = NS.sIsReadable
53 sIsWritable = NS.sIsWritable
54
55 sClose = NS.sClose
56
57-- newtype RestrictedSocket = Restricted NS.Socket deriving (SocketLike,Show)
58data RestrictedSocket = Restricted (Maybe Handle) NS.Socket deriving Show
59
60instance SocketLike RestrictedSocket where
61 getSocketName (Restricted mb sock) = NS.getSocketName sock
62 getPeerName (Restricted mb sock) = NS.getPeerName sock
63 getPeerCred (Restricted mb sock) = NS.getPeerCred sock
64 socketPort (Restricted mb sock) = NS.socketPort sock
65 sIsConnected (Restricted mb sock) = NS.sIsConnected sock
66 sIsBound (Restricted mb sock) = NS.sIsBound sock
67 sIsListening (Restricted mb sock) = NS.sIsListening sock
68 sIsReadable (Restricted mb sock) = NS.sIsReadable sock
69 sIsWritable (Restricted mb sock) = NS.sIsWritable sock
70 sClose (Restricted mb sock) = maybe (NS.sClose sock) (\h -> hClose h >> NS.sClose sock) mb
71
72restrictSocket :: NS.Socket -> RestrictedSocket
73restrictSocket socket = Restricted Nothing socket
74
75restrictHandleSocket :: Handle -> NS.Socket -> RestrictedSocket
76restrictHandleSocket h socket = Restricted (Just h) socket
diff --git a/Presence/UTmp.hs b/Presence/UTmp.hs
new file mode 100644
index 00000000..b43278da
--- /dev/null
+++ b/Presence/UTmp.hs
@@ -0,0 +1,249 @@
1{-# LANGUAGE TemplateHaskell #-}
2{-# LANGUAGE RankNTypes #-}
3module UTmp
4 ( users
5 , users2
6 , utmp_file
7 , UserName
8 , Tty
9 , ProcessID
10 , UtmpRecord(..)
11 , UT_Type(..)
12 ) where
13
14import qualified Data.ByteString as S
15import qualified Data.ByteString.Char8 as C
16import qualified Data.ByteString.Lazy.Char8 as L
17import Data.BitSyntax
18import Data.Functor.Identity
19import Data.Maybe
20import System.Posix.Signals
21import System.Posix.Types
22import Control.Monad
23import Data.Word
24import Data.Int
25import Control.Monad.Error.Class
26import System.IO.Error
27import qualified Paths
28import Data.Text ( Text )
29import Unsafe.Coerce ( unsafeCoerce )
30import Network.Socket ( SockAddr(..) )
31import qualified Data.Text.Encoding as Text
32import SockAddr ()
33
34
35utmp_file :: String
36utmp_file = Paths.utmp -- "/var/run/utmp"
37
38utmp_bs :: IO C.ByteString
39utmp_bs = S.readFile utmp_file
40
41decode_utmp_bytestring ::
42 C.ByteString
43 -> (Word32,
44 Word32,
45 C.ByteString,
46 C.ByteString,
47 C.ByteString,
48 C.ByteString,
49 Word16,
50 Word16,
51 Word32,
52 C.ByteString,
53 Word32,
54 Word32,
55 Word32,
56 Word32)
57decode_utmp_bytestring =
58 runIdentity
59 . $(bitSyn [ UnsignedLE 4 -- type
60 , UnsignedLE 4 -- pid
61 , Fixed 32 -- tty
62 , Fixed 4 -- inittab id
63 , Fixed 32 -- username
64 , Fixed 256 -- remote host
65 , UnsignedLE 2 -- termination status
66 , UnsignedLE 2 -- exit status (int)
67 , UnsignedLE 4 -- session id (int)
68 , Fixed 8 -- time entry was made
69 , Unsigned 4 -- remote addr v6 addr[0]
70 , Unsigned 4 -- remote addr v6 addr[1]
71 , Unsigned 4 -- remote addr v6 addr[2]
72 , Unsigned 4 -- remote addr v6 addr[3]
73 , Skip 20 -- reserved
74 ])
75
76utmp_size :: Int
77utmp_size = 384 -- 768
78
79
80utmp_records :: C.ByteString -> [C.ByteString]
81utmp_records bs | S.length bs >= utmp_size
82 = u:utmp_records us
83 where
84 (u,us) = S.splitAt utmp_size bs
85
86utmp_records bs = [bs]
87
88utmp ::
89 IO
90 [(Word32,
91 Word32,
92 C.ByteString,
93 C.ByteString,
94 C.ByteString,
95 C.ByteString,
96 Word16,
97 Word16,
98 Word32,
99 C.ByteString,
100 Word32,
101 Word32,
102 Word32,
103 Word32)]
104utmp = fmap (map decode_utmp_bytestring . utmp_records) utmp_bs
105
106toStr :: C.ByteString -> [Char]
107toStr = takeWhile (/='\0') . C.unpack
108
109interp_utmp_record ::
110 forall t t1 t2 t3 t4 t5 t6 t7 t8 a.
111 Integral a =>
112 (a,
113 Word32,
114 C.ByteString,
115 t,
116 C.ByteString,
117 C.ByteString,
118 t1,
119 t2,
120 t3,
121 t4,
122 t5,
123 t6,
124 t7,
125 t8)
126 -> (UT_Type, [Char], [Char], CPid, [Char])
127interp_utmp_record (typ,pid,tty,inittab,user,hostv4,term,exit,session,time
128 ,addr0,addr1,addr2,addr3) =
129 ( (toEnum . fromIntegral) typ :: UT_Type
130 , toStr user, toStr tty, processId pid, toStr hostv4 )
131 where
132 processId = CPid . coerceToSigned
133
134coerceToSigned :: Word32 -> Int32
135coerceToSigned = unsafeCoerce
136
137
138data UT_Type
139 = EMPTY -- No valid user accounting information. */
140
141 | RUN_LVL -- The system's runlevel. */
142 | BOOT_TIME -- Time of system boot. */
143 | NEW_TIME -- Time after system clock changed. */
144 | OLD_TIME -- Time when system clock changed. */
145
146 | INIT_PROCESS -- Process spawned by the init process. */
147 | LOGIN_PROCESS -- Session leader of a logged in user. */
148 | USER_PROCESS -- Normal process. */
149 | DEAD_PROCESS -- Terminated process. */
150
151 | ACCOUNTING
152
153 deriving (Enum,Show,Eq,Ord,Read)
154
155processAlive :: ProcessID -> IO Bool
156processAlive pid = do
157 catchError (do { signalProcess nullSignal pid ; return True })
158 $ \e -> do { return (not ( isDoesNotExistError e)); }
159
160type UserName = L.ByteString
161type Tty = L.ByteString
162
163users :: IO [(UserName, Tty, ProcessID)]
164users = fmap (map only3) $ do
165 us <- utmp
166 let us' = map interp_utmp_record us
167 us'' = mapMaybe user_proc us'
168 user_proc (USER_PROCESS, u,tty,pid, hostv4)
169 = Just (L.pack u,L.pack tty,pid,hostv4)
170 user_proc _ = Nothing
171 onThrd f (_,_,pid,_) = f pid
172 us3 <- filterM (onThrd processAlive) us''
173 return us3
174
175only3 :: forall t t1 t2 t3. (t1, t2, t3, t) -> (t1, t2, t3)
176only3 (a,b,c,_) = (a,b,c)
177
178data UtmpRecord = UtmpRecord
179 { utmpType :: UT_Type
180 , utmpUser :: Text
181 , utmpTty :: Text
182 , utmpPid :: CPid
183 , utmpHost :: Text
184 , utmpSession :: Int32
185 , utmpRemoteAddr :: Maybe SockAddr
186 }
187 deriving ( Show, Eq, Ord )
188
189toText :: C.ByteString -> Text
190toText bs = Text.decodeUtf8 $ C.takeWhile (/='\0') bs
191
192interp_utmp_record2 ::
193 forall t t1 t2 t3 a.
194 Integral a =>
195 (a,
196 Word32,
197 C.ByteString,
198 t,
199 C.ByteString,
200 C.ByteString,
201 t1,
202 t2,
203 Word32,
204 t3,
205 Word32,
206 Word32,
207 Word32,
208 Word32)
209 -> UtmpRecord
210interp_utmp_record2 (typ,pid,tty,inittab,user,hostv4
211 ,term,exit,session,time,addr0,addr1,addr2,addr3) =
212 UtmpRecord
213 { utmpType = toEnum (fromIntegral typ) :: UT_Type
214 , utmpUser = toText user
215 , utmpTty = toText tty
216 , utmpPid = processId pid
217 , utmpHost = toText hostv4
218 , utmpSession = coerceToSigned session
219 , utmpRemoteAddr =
220 if all (==0) [addr1,addr2,addr3]
221 then do guard (addr0/=0)
222 Just $ SockAddrInet6 0 0 (0,0,0xFFFF,addr0) 0
223 else Just $ SockAddrInet6 0 0 (addr0,addr1,addr2,addr3) 0
224 }
225 where
226 processId = CPid . coerceToSigned
227
228users2 :: IO [UtmpRecord]
229users2 = do
230 us <- utmp
231 let us' = map interp_utmp_record2 us
232 us3 <- filterM (processAlive . utmpPid) us'
233 return us3
234
235{-
236 - This is how the w command reports idle time:
237/* stat the device file to get an idle time */
238static time_t idletime(const char *restrict const tty)
239{
240 struct stat sbuf;
241 if (stat(tty, &sbuf) != 0)
242 return 0;
243 return time(NULL) - sbuf.st_atime;
244}
245 - THis might be useful fo rimplementing
246 - xep-0012 Last Activity
247 - iq get {jabber:iq:last}query
248 -
249 -}
diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs
new file mode 100644
index 00000000..eab57da5
--- /dev/null
+++ b/Presence/XMPP.hs
@@ -0,0 +1,1461 @@
1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE ViewPatterns #-}
4{-# LANGUAGE TypeFamilies #-}
5{-# LANGUAGE CPP #-}
6module XMPP
7 ( module XMPPTypes
8 , listenForXmppClients
9 , listenForRemotePeers
10 , newServerConnections
11 , seekRemotePeers
12 , quitListening
13 , OutBoundMessage(..)
14 , OutgoingConnections
15 , CachedMessages
16 , toPeer
17 , newOutgoingConnections
18 , sendMessage
19 ) where
20
21import ServerC
22import XMPPTypes
23import ByteStringOperators
24import ControlMaybe
25import XMLToByteStrings
26import SendMessage
27import Logging
28import Todo
29
30import Data.Maybe (catMaybes)
31import Data.HList hiding (hHead)
32import Network.Socket ( Family )
33import Control.Concurrent.STM
34import Control.Concurrent.STM.Delay
35import Data.Conduit
36import Data.Maybe
37import Data.ByteString (ByteString)
38import qualified Data.ByteString.Lazy.Char8 as L
39 ( fromChunks
40 )
41import Control.Concurrent.Async
42import Control.Exception as E ( finally )
43import System.IO.Error (isDoesNotExistError)
44import Control.Monad.IO.Class
45import Control.Monad.Trans.Class
46import Control.Monad.Trans.Maybe
47import Text.XML.Stream.Parse (def,parseBytes,content)
48import Data.XML.Types as XML
49import qualified Data.Text as S (Text,takeWhile)
50import Data.Text.Encoding as S (decodeUtf8,encodeUtf8)
51import Data.Text.Lazy.Encoding as L (decodeUtf8)
52import Data.Text.Lazy (toStrict)
53import qualified Data.Sequence as Seq
54import Data.Foldable (toList)
55import Data.List (find)
56import qualified Text.Show.ByteString as L
57import NestingXML
58import Data.Set as Set (Set,(\\))
59import qualified Data.Set as Set
60import qualified Data.Map as Map
61import Data.Map as Map (Map)
62
63#if MIN_VERSION_HList(0,3,0)
64#define HCONS HCons'
65#else
66#define HCONS HCons
67#endif
68
69hHead (HCONS x _) = x
70
71textToByteString x = L.fromChunks [S.encodeUtf8 x]
72
73
74
75xmlifyPresenceForClient :: Presence -> IO [XML.Event]
76xmlifyPresenceForClient (Presence jid stat) = do
77 let n = name jid
78 rsc = resource jid
79 names <- getNamesForPeer (peer jid)
80 let tostr p = L.decodeUtf8 $ n <$++> "@" <?++> L.fromChunks [p] <++?> "/" <++$> rsc
81 jidstrs = fmap (toStrict . tostr) names
82 return (concatMap presenceEvents jidstrs)
83 where
84 presenceEvents jidstr =
85 [ EventBeginElement "{jabber:client}presence" (("from",[ContentText jidstr]):typ stat) ]
86 ++ ( shw stat >>= jabberShow ) ++
87 [ EventEndElement "{jabber:client}presence" ]
88 typ Offline = [("type",[ContentText "unavailable"])]
89 typ _ = []
90 shw ExtendedAway = ["xa"]
91 shw Chatty = ["chat"]
92 shw Away = ["away"]
93 shw DoNotDisturb = ["dnd"]
94 shw _ = []
95 jabberShow stat =
96 [ EventBeginElement "{jabber:client}show" []
97 , EventContent (ContentText stat)
98 , EventEndElement "{jabber:client}show" ]
99
100prefix ## name = Name name Nothing (Just prefix)
101
102streamP name = Name name (Just "http://etherx.jabber.org/streams") (Just "stream")
103
104greet host =
105 [ EventBeginDocument
106 , EventBeginElement (streamP "stream")
107 [("from",[ContentText host])
108 ,("id",[ContentText "someid"])
109 ,("xmlns",[ContentText "jabber:client"])
110 ,("xmlns:stream",[ContentText "http://etherx.jabber.org/streams"])
111 ,("version",[ContentText "1.0"])
112 ]
113 , EventBeginElement (streamP "features") []
114 , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-bind}bind" []
115 , EventEndElement "{urn:ietf:params:xml:ns:xmpp-bind}bind"
116
117 {-
118 -- , " <session xmlns='urn:ietf:params:xml:ns:xmpp-session'/>"
119 , " <mechanisms xmlns='urn:ietf:params:xml:ns:xmpp-sasl'>"
120 -- , " <mechanism>DIGEST-MD5</mechanism>"
121 , " <mechanism>PLAIN</mechanism>"
122 , " </mechanisms> "
123 -}
124
125 , EventEndElement (streamP "features")
126 ]
127
128
129-- type Consumer i m r = forall o. ConduitM i o m r
130mawait :: Monad m => MaybeT (ConduitM i o m) i
131mawait = MaybeT await
132
133-- Note: This function ignores name space qualification
134elementAttrs expected (EventBeginElement name attrs)
135 | nameLocalName name==expected
136 = return attrs
137elementAttrs _ _ = mzero
138
139eventIsBeginElement (EventBeginElement _ _) = True
140eventIsBeginElement _ = False
141
142eventIsEndElement (EventEndElement _) = True
143eventIsEndElement _ = False
144
145filterMapElement::
146 (Monad m, MonadPlus mp) =>
147 (Event -> mp a) -> Event -> mp a -> MaybeT (ConduitM Event o m) (mp a)
148filterMapElement ret opentag empty = loop (empty `mplus` ret opentag) 1
149 where
150 loop ts 0 = return ts
151 loop ts cnt = do
152 tag <- mawait
153 let ts' = mplus ts (ret tag)
154 case () of
155 _ | eventIsEndElement tag -> loop ts' (cnt-1)
156 _ | eventIsBeginElement tag -> loop ts' (cnt+1)
157 _ -> loop ts' cnt
158
159gatherElement ::
160 (Monad m, MonadPlus mp) =>
161 Event -> mp Event -> NestingXML o m (mp Event)
162gatherElement opentag empty = loop (empty `mplus` return opentag) 1
163 where
164 loop ts 0 = return ts
165 loop ts cnt = do
166 maybeXML (return ts) $ \tag -> do
167 let ts' = mplus ts (return tag)
168 case () of
169 _ | eventIsEndElement tag -> loop ts' (cnt-1)
170 _ | eventIsBeginElement tag -> loop ts' (cnt+1)
171 _ -> loop ts' cnt
172
173
174voidMaybeT body = (>> return ()) . runMaybeT $ body
175fixMaybeT f = (>> return ()) . runMaybeT . fix $ f
176
177iq_bind_reply id jid =
178 [ EventBeginElement "{jabber:client}iq" [("type",[ContentText "result"]),("id",[ContentText id])]
179
180 , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-bind}bind"
181 [("xmlns",[ContentText "urn:ietf:params:xml:ns:xmpp-bind"])]
182 , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-bind}jid" []
183 , EventContent (ContentText jid)
184 , EventEndElement "{urn:ietf:params:xml:ns:xmpp-bind}jid"
185 , EventEndElement "{urn:ietf:params:xml:ns:xmpp-bind}bind"
186 , EventEndElement "{jabber:client}iq"
187 ]
188
189uncontent cs = head $ map getText cs
190 where
191 getText (ContentText x) = x
192 getText (ContentEntity x ) = x
193
194tagAttrs (EventBeginElement _ xs) = xs
195tagAttrs _ = []
196
197tagName (EventBeginElement n _) = n
198tagName _ = ""
199
200handleIQSetBind session cmdChan stanza_id = do
201 mchild <- nextElement
202 rsc <- case mchild of
203 Just child -> do
204 let unhandledBind = do
205 liftIO $ debugStr $ "unhandled-bind: "++show child
206 return ""
207 case tagName child of
208 "{urn:ietf:params:xml:ns:xmpp-bind}resource"
209 -> do
210 rsc <- lift content
211 return . textToByteString $ rsc
212 _ -> unhandledBind
213 Nothing -> do
214 liftIO $ debugStr $ "empty bind request!"
215 return ""
216 liftIO $ do
217 debugL $ "iq-set-bind-resource " <++> rsc
218 setResource session rsc
219 jid <- getJID session
220 atomically $ do
221 writeTChan cmdChan (Send $ iq_bind_reply stanza_id (toStrict $ L.decodeUtf8 $ L.show jid) )
222 writeTChan cmdChan BoundToResource
223 forCachedPresence session $ \presence -> do
224 xs <- xmlifyPresenceForClient presence
225 atomically . writeTChan cmdChan . Send $ xs
226
227
228iq_session_reply host stanza_id =
229 [ EventBeginElement "{jabber:client}iq"
230 [("id",[ContentText stanza_id])
231 ,("from",[ContentText host])
232 ,("type",[ContentText "result"])
233 ]
234 , EventEndElement "{jabber:client}iq"
235 ]
236
237handleIQSetSession session cmdChan stanza_id = do
238 host <- liftIO $ do
239 jid <- getJID session
240 names <- getNamesForPeer (peer jid)
241 return (S.decodeUtf8 . head $ names)
242 liftIO . atomically . writeTChan cmdChan . Send $ iq_session_reply host stanza_id
243
244handleIQSet session cmdChan tag = do
245 withJust (lookupAttrib "id" (tagAttrs tag)) $ \stanza_id -> do
246 whenJust nextElement $ \child -> do
247 let unhandledSet = liftIO $ debugStr ("iq-set: "++show (stanza_id,child))
248 case tagName child of
249 "{urn:ietf:params:xml:ns:xmpp-bind}bind"
250 -> handleIQSetBind session cmdChan stanza_id
251 "{urn:ietf:params:xml:ns:xmpp-session}session"
252 -> handleIQSetSession session cmdChan stanza_id
253 _ -> unhandledSet
254
255matchAttrib name value attrs =
256 case find ( (==name) . fst) attrs of
257 Just (_,[ContentText x]) | x==value -> True
258 Just (_,[ContentEntity x]) | x==value -> True
259 _ -> False
260
261lookupAttrib name attrs =
262 case find ( (==name) . fst) attrs of
263 Just (_,[ContentText x]) -> Just x
264 Just (_,[ContentEntity x]) -> Just x
265 _ -> Nothing
266
267iqTypeSet = "set"
268iqTypeGet = "get"
269iqTypeResult = "result"
270iqTypeError = "error"
271
272isIQOf (EventBeginElement name attrs) testType
273 | name=="{jabber:client}iq"
274 && matchAttrib "type" testType attrs
275 = True
276isIQOf _ _ = False
277
278isServerIQOf (EventBeginElement name attrs) testType
279 | name=="{jabber:server}iq"
280 && matchAttrib "type" testType attrs
281 = True
282isServerIQOf _ _ = False
283
284iq_service_unavailable host iq_id mjid req =
285 [ EventBeginElement "{jabber:client}iq"
286 [("type",[ContentText "error"])
287 ,("id",[ContentText iq_id])
288 -- , TODO: set "from" if isJust mjid
289 ]
290 , EventBeginElement req []
291 , EventEndElement req
292 , EventBeginElement "{jabber:client}error" [("type",[ContentText "cancel"])]
293 , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-stanzas}service-unavailable" []
294 , EventEndElement "{urn:ietf:params:xml:ns:xmpp-stanzas}service-unavailable"
295 , EventEndElement "{jabber:client}error"
296 , EventEndElement "{jabber:client}iq"
297 ]
298
299attr name value = (name,[ContentText value])
300attrbs name value = (name,[ContentText (toStrict . L.decodeUtf8 $ value)])
301
302
303getRoster session iqid = do
304 let getlist f = do
305 bs <- f session
306 -- js <- mapM parseHostNameJID bs
307 return (Set.fromList bs) -- js)
308 buddies <- getlist getMyBuddies
309 subscribers <- getlist getMySubscribers
310 solicited <- getlist getMySolicited
311 subnone0 <- getlist getMyOthers
312 let subnone = subnone0 \\ (Set.union buddies subscribers)
313 let subto = buddies \\ subscribers
314 let subfrom = subscribers \\ buddies
315 let subboth = Set.intersection buddies subscribers
316 -- solicited -> ask='subscribe'
317 jid <- getJID session
318 let dest = toStrict . L.decodeUtf8 . bshow $ jid
319 let items= (xmlify solicited "to" subto)
320 ++(xmlify solicited "from" subfrom)
321 ++(xmlify solicited "both" subboth)
322 ++(xmlify solicited "none" subnone)
323 openiq = [EventBeginElement "{jabber:client}iq"
324 [ attr "id" iqid
325 , attr "to" dest
326 , attr "type" "result" ]
327 ,EventBeginElement "{jabber:iq:roster}query"
328 [] -- todo: ver?
329 ]
330 closeiq = [EventEndElement "{jabber:iq:roster}query"
331 ,EventEndElement "{jabber:client}iq"]
332 return $ openiq ++ items ++ closeiq
333 where
334 xmlify solicited stype set = flip concatMap (Set.toList set)
335 $ \jid ->
336 [ EventBeginElement "item"
337 ([ attr "jid" (toStrict . L.decodeUtf8 $ jid)
338 , attr "subscription" stype
339 ]++if Set.member jid solicited
340 then [attr "ask" "subscribe"]
341 else [] )
342 , EventEndElement "item"
343 ]
344
345handleIQGet session cmdChan tag = do
346 withJust (lookupAttrib "id" (tagAttrs tag)) $ \stanza_id -> do
347 whenJust nextElement $ \child -> do
348 host <- liftIO $ do
349 jid <- getJID session
350 names <- getNamesForPeer (peer jid)
351 return (S.decodeUtf8 . head $ names)
352 let unhandledGet req = do
353 liftIO $ debugStr ("iq-get: "++show (stanza_id,child))
354 liftIO . atomically . writeTChan cmdChan . Send $ iq_service_unavailable host stanza_id Nothing req
355 case tagName child of
356 -- "{http://jabber.org/protocol/disco#items}query" -> liftIO $ debugStr "iq-get-query-items"
357 "{urn:xmpp:ping}ping" -> liftIO $ do
358 let mjid = lookupAttrib "from" (tagAttrs tag)
359 let pong = [ EventBeginElement "{jabber:client}iq"
360 $ (case mjid of
361 Just jid -> (attr "to" jid :)
362 _ -> id )
363 [ attr "type" "result"
364 , attr "id" stanza_id
365 , attr "from" host
366 ]
367 , EventEndElement "{jabber:client}iq"
368 ]
369 atomically . writeTChan cmdChan . Send $ pong
370 "{jabber:iq:roster}query" -> liftIO $ do
371 debugStr $ "REQUESTED ROSTER " ++ show tag
372 roster <- getRoster session stanza_id
373 atomically $ do
374 writeTChan cmdChan InterestedInRoster
375 writeTChan cmdChan . Send $ roster
376 sendPending session
377 req -> unhandledGet req
378
379
380handleClientPresence session stanza = do
381 -- online (Available or Away)
382 let log = liftIO . debugL . ("(C) " <++>)
383 log $ "handleClientPresence "<++>bshow stanza
384 jid <- liftIO $ getJID session
385 -- cjid <- liftIO $ parseAddressJID (textToByteString jid)
386 let parseChildren stat = do
387 child <- nextElement
388 log $ " child: "<++> bshow child
389 case child of
390 Just tag | tagName tag=="{jabber:client}show"
391 -> fmap toStat (lift content)
392 Just tag | otherwise -> parseChildren stat
393 Nothing -> return stat
394 toStat "away" = Away
395 toStat "xa" = ExtendedAway
396 toStat "dnd" = DoNotDisturb
397 toStat "chat" = Chatty
398
399 stat' <- parseChildren Available
400 liftIO $ setPresence session stat'
401 log $ "requesting presence: "<++>bshow stat'
402 return ()
403
404
405fromClient :: (MonadThrow m,MonadIO m, JabberClientSession session) =>
406 session -> TChan ClientCommands -> Sink XML.Event m ()
407fromClient session cmdChan = doNestingXML $ do
408 let log = liftIO . debugL . ("(C) " <++>)
409 send = liftIO . atomically . writeTChan cmdChan . Send
410 withXML $ \begindoc -> do
411 when (begindoc==EventBeginDocument) $ do
412 log "begin-doc"
413 withXML $ \xml -> do
414 withJust (elementAttrs "stream" xml) $ \stream_attrs -> do
415 log $ "stream atributes: " <++> bshow stream_attrs
416 host <- liftIO $ do
417 jid <- getJID session
418 names <- getNamesForPeer (peer jid)
419 return (S.decodeUtf8 . head $ names)
420 send $ greet host
421
422 fix $ \loop -> do
423 log "waiting for stanza."
424 whenJust nextElement $ \stanza -> do
425 stanza_lvl <- nesting
426
427 liftIO . debugStr $ "stanza: "++show stanza
428
429 let unhandledStanza = do
430 xs <- gatherElement stanza Seq.empty
431 prettyPrint "unhandled-C: " (toList xs)
432 case () of
433 _ | stanza `isIQOf` iqTypeSet -> handleIQSet session cmdChan stanza
434 _ | stanza `isIQOf` iqTypeGet -> handleIQGet session cmdChan stanza
435 _ | stanza `isClientPresenceOf` presenceTypeSubscribe
436 -> clientRequestsSubscription session cmdChan stanza
437 _ | stanza `isClientPresenceOf` presenceTypeSubscribed
438 -> clientApprovesSubscription session stanza
439 _ | stanza `isClientPresenceOf` presenceTypeUnsubscribed
440 -> clientRejectsSubscription session stanza
441 _ | stanza `isClientPresenceOf` presenceTypeOnline
442 -> handleClientPresence session stanza
443 _ | isMessageStanza stanza -> handleClientMessage session stanza
444 _ | otherwise -> unhandledStanza
445
446 awaitCloser stanza_lvl
447 loop
448
449 log $ "end of stream"
450 withXML $ \xml -> do
451 log $ "end-of-document: " <++> bshow xml
452
453
454rosterPush to contact attrs = do
455 let n = name to
456 rsc = resource to
457 names <- getNamesForPeer (peer to)
458 let tostr p = L.decodeUtf8 $ n <$++> "@" <?++> L.fromChunks [p] <++?> "/" <++$> rsc
459 jidstrs = fmap (toStrict . tostr) names
460 tojid = head jidstrs
461 return
462 [ EventBeginElement "{jabber:client}iq"
463 [ attr "to" tojid
464 , attr "id" "someid"
465 , attr "type" "set"
466 ]
467 , EventBeginElement "{jabber:iq:roster}query" []
468 , EventBeginElement "{jabber:iq:roster}item" (attr "jid" contact : attrs)
469 , EventEndElement "{jabber:iq:roster}item"
470 , EventEndElement "{jabber:iq:roster}query"
471 , EventEndElement "{jabber:client}iq"
472 ]
473
474data EventsForClient = CmdChan ClientCommands
475 | PChan Presence
476 | RChan RosterEvent
477
478toClient :: (MonadIO m, JabberClientSession session ) =>
479 session -> TChan Presence -> TChan ClientCommands -> TChan RosterEvent -> Source m [XML.Event]
480toClient session pchan cmdChan rchan = toClient' False False
481 where
482 toClient' isBound isInterested = do
483 let loop = toClient' isBound isInterested
484 send xs = yield xs >> prettyPrint ">C: " xs
485 event <- liftIO . atomically $
486 foldr1 orElse [fmap CmdChan $ readTChan cmdChan
487 ,fmap RChan $ readTChan rchan
488 ,fmap PChan $ readTChan pchan
489 ]
490 case event of
491 CmdChan QuitThread -> return ()
492 CmdChan (Send xs) -> send xs >> loop
493 CmdChan BoundToResource -> toClient' True isInterested
494 CmdChan InterestedInRoster -> do
495 liftIO . debugStr $ "Roster: interested"
496 toClient' isBound True
497 CmdChan (Chat msg) -> do
498 xs <- liftIO $ xmlifyMessageForClient msg
499 send xs
500 loop
501 -- CmdChan cmd -> liftIO (debugStr $ "unhandled event: "++show cmd) >> loop
502 RChan (RequestedSubscription who contact) -> do
503 jid <- liftIO $ getJID session
504 when (isInterested && Just who==name jid) $ do
505 r <- liftIO $ rosterPush jid (toStrict . L.decodeUtf8 $ contact) [attr "ask" "subscribe"]
506 send r
507 loop
508 RChan (NewBuddy who contact) -> do
509 liftIO . debugStr $ "Roster push: NewBuddy "++show (isInterested,who,contact)
510 (jid,me) <- liftIO $ do
511 jid <- getJID session
512 me <- asHostNameJID jid
513 return (jid,me)
514 withJust me $ \me -> do
515 when (isInterested && Just who==name jid) $ do
516 send [ EventBeginElement "{jabber:client}presence"
517 [ attrbs "from" contact
518 , attrbs "to" me
519 , attr "type" "subscribed"
520 ]
521 , EventEndElement "{jabber:client}presence" ]
522 let f True = "both"
523 f False = "to"
524 subscription <- fmap f (liftIO $ isSubscribed session contact)
525 r <- liftIO . handleIO (\e -> debugStr ("Roster NewBuddy error: "++show e) >> return []) $ do
526 rosterPush jid
527 (toStrict . L.decodeUtf8 $ contact)
528 [attr "subscription" subscription]
529 send r
530 loop
531 RChan (RemovedBuddy who contact) -> do
532 liftIO . debugStr $ "Roster push: RemovedBuddy "++show (isInterested,who,contact)
533 (jid,me) <- liftIO $ do
534 jid <- getJID session
535 me <- asHostNameJID jid
536 return (jid,me)
537 withJust me $ \me -> do
538 when (isInterested && Just who==name jid) $ do
539 send [ EventBeginElement "{jabber:client}presence"
540 [ attrbs "from" contact
541 , attrbs "to" me
542 , attr "type" "unsubscribed"
543 ]
544 , EventEndElement "{jabber:client}presence" ]
545 let f True = "from"
546 f False = "none"
547 subscription <- fmap f (liftIO $ isSubscribed session contact)
548 r <- liftIO . handleIO (\e -> debugStr ("Roster RemovedBuddy error: "++show e) >> return []) $ do
549 rosterPush jid
550 (toStrict . L.decodeUtf8 $ contact)
551 [attr "subscription" subscription]
552 send r
553 loop
554 RChan (NewSubscriber who contact) -> do
555 liftIO . debugStr $ "Roster push: NewSubscriber "++show (isInterested,who,contact)
556 (jid,me) <- liftIO $ do
557 jid <- getJID session
558 me <- asHostNameJID jid
559 return (jid,me)
560 withJust me $ \me -> do
561 when (isInterested && Just who==name jid) $ do
562 let f True = "both"
563 f False = "from"
564 subscription <- fmap f (liftIO $ isBuddy session contact)
565 r <- liftIO . handleIO (\e -> debugStr ("Roster NewSubscriber error: "++show e) >> return []) $ do
566 rosterPush jid
567 (toStrict . L.decodeUtf8 $ contact)
568 [attr "subscription" subscription]
569 send r
570 loop
571 RChan (RejectSubscriber who contact) -> do
572 liftIO . debugStr $ "Roster push: RejectSubscriber "++show (isInterested,who,contact)
573 (jid,me) <- liftIO $ do
574 jid <- getJID session
575 me <- asHostNameJID jid
576 return (jid,me)
577 withJust me $ \me -> do
578 when (isInterested && Just who==name jid) $ do
579 let f True = "to"
580 f False = "none"
581 subscription <- fmap f (liftIO $ isBuddy session contact)
582 r <- liftIO . handleIO (\e -> debugStr ("Roster RejectSubscriber error: "++show e) >> return []) $ do
583 rosterPush jid
584 (toStrict . L.decodeUtf8 $ contact)
585 [attr "subscription" subscription]
586 send r
587 loop
588 RChan (PendingSubscriber who contact) -> do
589 liftIO . debugStr $ "Roster: Pending buddy "++show (isInterested,who,contact)
590 (jid,me) <- liftIO $ do
591 jid <- getJID session
592 me <- asHostNameJID jid
593 return (jid,me)
594 withJust me $ \me -> do
595 when (isInterested && Just who==name jid) $ do
596 send [ EventBeginElement "{jabber:client}presence"
597 [ attrbs "from" contact
598 , attrbs "to" me
599 , attr "type" "subscribe"
600 ]
601 , EventEndElement "{jabber:client}presence" ]
602 loop
603 PChan presence -> do
604 when isBound $ do
605 xs <- liftIO $ xmlifyPresenceForClient presence
606 send xs
607 loop
608
609
610{-
611handleClient
612 :: (SocketLike sock, HHead l (XMPPClass session),
613 JabberClientSession session) =>
614 HCONS sock (HCONS t l) -> Source IO ByteString -> Sink ByteString IO () -> IO ()
615-}
616handleClient st src snk = do
617#if MIN_VERSION_HList(0,3,0)
618 let HCons' sock (HCons' _ st') = st
619#else
620 let HCons sock (HCons _ st') = st
621#endif
622 session_factory = hHead st'
623 pname <- getPeerName sock
624 session <- newSession session_factory sock
625 debugStr $ "PEER NAME: "++Prelude.show pname
626 pchan <- subscribe session Nothing
627 rchan <- subscribeToRoster session
628 let cmdChan = clientChannel session
629
630 writer <- async ( toClient session pchan cmdChan rchan `xmlToByteStrings` snk )
631 finally ( src $= parseBytes def $$ fromClient session cmdChan )
632 $ do
633 atomically $ writeTChan cmdChan QuitThread
634 wait writer
635 closeSession session
636
637{-
638listenForXmppClients ::
639 (HList l, HHead l (XMPPClass session), HExtend e1 l2 l1,
640 HExtend e l1 (HCONS PortNumber l), JabberClientSession session) =>
641 Family -> e1 -> e -> l2 -> IO ServerHandle
642-}
643listenForXmppClients addr_family session_factory port st = do
644#if MIN_VERSION_HList(0,3,0)
645 doServer (HCons' addr_family $ HCons' port $ HCons' session_factory st) handleClient
646#else
647 doServer (HCons addr_family $ HCons port $ HCons session_factory st) handleClient
648#endif
649
650
651{-
652listenForRemotePeers
653 :: (HList l, HHead l (XMPPPeerClass session),
654 HExtend e l1 (HCONS PortNumber l), HExtend e1 l2 l1,
655 JabberPeerSession session) =>
656 Family -> e1 -> e -> l2 -> IO ServerHandle
657-}
658listenForRemotePeers addrfamily session_factory port st = do
659#if MIN_VERSION_HList(0,3,0)
660 doServer (HCons' addrfamily $ HCons' port $ HCons' session_factory st) handlePeer
661#else
662 doServer (HCons addrfamily $ HCons port $ HCons session_factory st) handlePeer
663#endif
664
665{-
666handlePeer
667 :: (HHead l (XMPPPeerClass session),
668 JabberPeerSession session) =>
669 HCONS RestrictedSocket (HCONS t1 l) -> Source IO ByteString -> t -> IO ()
670-}
671handlePeer st src snk = do
672#if MIN_VERSION_HList(0,3,0)
673 let HCons' sock (HCons' _ st') = st
674#else
675 let HCons sock (HCons _ st') = st
676#endif
677 session_factory = hHead st'
678 name <- fmap bshow $ getPeerName sock
679 debugL $ "(P) connected " <++> name
680 session <- newPeerSession session_factory sock
681
682 didClose <- newTVarIO False
683 finally ( src $= parseBytes def $$ fromPeer sock session didClose )
684 $ do
685 debugL $ "(P) disconnected " <++> name
686 didc <- readTVarIO didClose
687 when (not didc) $ closePeerSession session
688
689
690handlePeerPresence session stanza False = do
691 -- Offline
692 liftIO . debugStr $ "PEER-OFFLINE: "++show stanza
693 withJust (lookupAttrib "from" (tagAttrs stanza)) $ \jid -> do
694 peer_jid <- liftIO $ parseAddressJID (textToByteString jid)
695 liftIO . debugStr $ "PEER-OFFLINE-JID: "++show peer_jid
696 liftIO $ announcePresence session (Presence peer_jid Offline)
697handlePeerPresence session stanza True = do
698 -- online (Available or Away)
699 let log = liftIO . debugL . ("(P) " <++>)
700 withJust (lookupAttrib "from" (tagAttrs stanza)) $ \jid -> do
701 pjid <- liftIO $ parseAddressJID (textToByteString jid)
702 -- stat <- show element content
703 let parseChildren stat = do
704 child <- nextElement
705 case child of
706 Just tag | tagName tag=="{jabber:server}show"
707 -> fmap toStat (lift content)
708 Just tag | otherwise -> parseChildren stat
709 Nothing -> return stat
710 toStat "away" = Away
711 toStat "xa" = ExtendedAway
712 toStat "dnd" = DoNotDisturb
713 toStat "chat" = Chatty
714
715 stat' <- parseChildren Available
716 liftIO . debugStr $ "announcing peer online: "++show (pjid,stat')
717 liftIO $ announcePresence session (Presence pjid stat')
718 log $ bshow (Presence pjid stat')
719
720handlePeerMessage session stanza = do
721 withJust (lookupAttrib "from" (tagAttrs stanza)) $ \fromstr-> do
722 withJust (lookupAttrib "to" (tagAttrs stanza)) $ \tostr -> do
723 fromjid <- liftIO $ parseAddressJID (textToByteString fromstr)
724 tojid <- liftIO $ parseAddressJID (textToByteString tostr)
725 let log = liftIO . debugL . ("(P) " <++>)
726 log $ "handlePeerMessage "<++>bshow stanza
727 msg <- parseMessage ("{jabber:server}body"
728 ,"{jabber:server}subject"
729 ,"{jabber:server}thread"
730 )
731 log
732 fromjid
733 tojid
734 stanza
735 liftIO $ sendChatToClient session msg
736
737matchAttribMaybe name (Just value) attrs =
738 case find ( (==name) . fst) attrs of
739 Just (_,[ContentText x]) | x==value -> True
740 Just (_,[ContentEntity x]) | x==value -> True
741 _ -> False
742matchAttribMaybe name Nothing attrs
743 | find ( (==name) . fst) attrs==Nothing
744 = True
745matchAttribMaybe name Nothing attrs
746 | otherwise
747 = False
748
749presenceTypeOffline = Just "unavailable"
750presenceTypeOnline = Nothing
751presenceTypeProbe = Just "probe"
752presenceTypeSubscribe = Just "subscribe"
753presenceTypeSubscribed = Just "subscribed"
754presenceTypeUnsubscribed = Just "unsubscribed"
755
756isPresenceOf (EventBeginElement name attrs) testType
757 | name=="{jabber:server}presence"
758 && matchAttribMaybe "type" testType attrs
759 = True
760isPresenceOf _ _ = False
761
762isMessageStanza (EventBeginElement name attrs)
763 | name=="{jabber:client}message"
764 = True
765isMessageStanza (EventBeginElement name attrs)
766 | name=="{jabber:server}message"
767 = True
768isMessageStanza _ = False
769
770isClientPresenceOf (EventBeginElement name attrs) testType
771 | name=="{jabber:client}presence"
772 && matchAttribMaybe "type" testType attrs
773 = True
774isClientPresenceOf _ _ = False
775
776
777handlePresenceProbe session stanza = do
778 withJust (lookupAttrib "to" (tagAttrs stanza)) $ \to -> do
779 -- withJust (lookupAttrib "from" (tagAttrs stanza)) $ \from -> do
780 jid <- liftIO $ parseAddressJID $ textToByteString to
781 withJust (name jid) $ \user -> do
782 liftIO $ debugL $ "RECEIVED PROBE "<++>bshow (peerAddress session,to)
783 liftIO $ do
784 subs <- getSubscribers (peerSessionFactory session) user
785 liftIO $ debugL $ "subscribers for "<++>bshow user<++>": " <++>bshow subs
786 forM_ subs $ \jidstr -> do
787 handleIO_ (return ()) $ do
788 debugL $ "parsing " <++>jidstr
789 sub <- parseHostNameJID jidstr
790 debugStr $ "comparing " ++show (peer sub , peerAddress session)
791 when (peer sub == discardPort (peerAddress session)) $ do
792 ps <- userStatus session user
793 -- todo: Consider making this a directed presence
794 forM_ ps $ \p -> do
795 debugStr ("PROBE-REPLY: "++show p)
796 mapM_ (sendPeerMessage session . OutBoundPresence) ps
797 return ()
798
799subscribeToPresence subscribers peer_jid user = do
800 pjid <- parseAddressJID peer_jid
801 if Set.member pjid subscribers
802 then return ()
803 else return ()
804
805bare (JID n host _) = JID n host Nothing
806
807presenceErrorRemoteNotFound iqid from to = return
808 [ EventBeginElement "{stream:client}presence"
809 ( case iqid of { Nothing -> id; Just iqid -> ( attr "id" iqid :) }
810 $ [ attr "from" to
811 , attr "type" "error"
812 ] )
813 , EventBeginElement "{stream:client}error"
814 [ attr "type" "modify"]
815 , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-stanzas}remote-server-not-found"
816 []
817 , EventEndElement "{urn:ietf:params:xml:ns:xmpp-stanzas}remote-server-not-found"
818 , EventEndElement "{stream:client}error"
819 , EventEndElement "{stream:client}presence"
820 ]
821
822presenceSubscribed from = return
823 [ EventBeginElement "{stream:client}presence"
824 [ attr "from" from
825 , attr "type" "subscribed"
826 ]
827 , EventEndElement "{stream:client}presence"
828 ]
829
830clientRequestsSubscription session cmdChan stanza = do
831 liftIO $ do
832 debugStr $ "CLIENT PRESENCE SUBSCRIBE " ++ show stanza
833 withJust (lookupAttrib "to" (tagAttrs stanza)) $ \to_str0 -> do
834 let to_str = S.takeWhile (/='/') to_str0
835 from = lookupAttrib "from" (tagAttrs stanza)
836 iqid = lookupAttrib "id" (tagAttrs stanza)
837 let handleError e | isDoesNotExistError e = do
838 debugStr $ "remote-server-not-found"
839 r <- presenceErrorRemoteNotFound iqid from to_str
840 atomically $ writeTChan cmdChan (Send r)
841 handleError e = do
842 debugStr $ "ERROR: "++ show e
843 handleIO handleError $ do
844 let to_str' = textToByteString to_str
845 to_jid <- fmap bare $ parseHostNameJID to_str'
846 if (is_remote . peer) to_jid
847 then do
848 addSolicited session to_str' to_jid
849 debugStr $ "added to solicited: " ++ show to_jid
850 else do
851 -- addLocalSubscriber session to_str
852 -- self <- getJID session
853 r <- presenceSubscribed to_str -- self
854 atomically $ writeTChan cmdChan (Send r)
855 return ()
856
857
858stanzaFromTo ::
859 JabberPeerSession session =>
860 session -> Event -> IO (Maybe (JID, JID))
861stanzaFromTo session stanza =
862 let lookup key = fmap textToByteString (lookupAttrib key (tagAttrs stanza))
863 parse jidstr = handleIO_ (return Nothing) (fmap Just $ parseAddressJID jidstr)
864 in case liftM2 (,) (lookup "from") (lookup "to") of
865 Nothing -> return Nothing
866 Just (from,to) -> do
867 mfrom <- parse from
868 mto <- parse to
869 case liftM2 (,) mfrom mto of
870 Nothing -> return Nothing
871 Just (from,to) -> do
872 let fromjid = JID (name from) (peerAddress session) Nothing
873 return $ Just (fromjid,to)
874
875peerRequestsSubsription session stanza = do
876 liftIO $ debugStr $ "PEER PRESENCE SUBSCRIBE " ++ show stanza
877
878 whenJust (liftIO . handleIO (\e -> debugStr ("peerRequestsSubsription: "++show e) >> return Nothing)
879 $ stanzaFromTo session stanza) $ \(fromjid,tojid) -> do
880 withJust (name tojid) $ \user -> do
881
882 subs <- liftIO $ do
883 subs <- getSubscribers (peerSessionFactory session) user
884 msubs <- flip mapM subs $ \str -> do
885 handleIO_ (return Nothing)
886 (fmap Just $ parseHostNameJID str)
887 return (catMaybes msubs)
888 if elem fromjid subs
889 then do
890 liftIO . debugL $ bshow fromjid <++> " already subscribed to " <++> user
891 -- if already subscribed, reply
892 liftIO $ do
893 sendPeerMessage session (Approval tojid fromjid)
894 ps <- userStatus session user
895 -- todo: consider making this a directed presence
896 mapM_ (sendPeerMessage session . OutBoundPresence) ps
897 else
898 liftIO $ processRequest session user fromjid
899
900clientApprovesSubscription session stanza = do
901 liftIO $ debugStr $ "CLIENT APPROVES SUBSCRIPTION"
902 withJust (lookupAttrib "to" (tagAttrs stanza)) $ \to_str -> do
903 liftIO $ approveSubscriber session (textToByteString to_str)
904
905clientRejectsSubscription session stanza = do
906 liftIO $ debugStr $ "CLIENT REJECTS SUBSCRIPTION"
907 withJust (lookupAttrib "to" (tagAttrs stanza)) $ \to_str -> do
908 liftIO $ rejectSubscriber session (textToByteString to_str)
909
910peerApprovesSubscription session stanza = do
911 liftIO $ debugStr $ "PEER APPROVES SUBSCRIPTION"
912 whenJust (liftIO . handleIO (\e -> debugStr ("peerApprovesSubscription: "++show e) >> return Nothing)
913 $ stanzaFromTo session stanza) $ \(fromjid,tojid) -> do
914 withJust (name tojid) $ \user -> do
915 liftIO $ processApproval session user fromjid
916
917peerRejectsSubscription session stanza = do
918 liftIO $ debugStr $ "PEER REJECTS SUBSCRIPTION"
919 whenJust (liftIO . handleIO (\e -> debugStr ("peerRejectsSubscription: "++show e) >> return Nothing)
920 $ stanzaFromTo session stanza) $ \(fromjid,tojid) -> do
921 withJust (name tojid) $ \user -> do
922 liftIO $ processRejection session user fromjid
923
924handlePeerIQGet :: (JabberPeerSession session, MonadIO m) =>
925 session -> XML.Event -> NestingXML o m ()
926handlePeerIQGet session tag = do
927 -- TODO: Pings should not require an id field.
928 withJust (lookupAttrib "id" (tagAttrs tag)) $ \stanza_id -> do
929 whenJust nextElement $ \child -> do
930 let unhandledGet req = do
931 liftIO $ debugStr ("iq-peer-get: "++show (stanza_id,child))
932 liftIO $
933 sendPeerMessage session (Unsupported (JID Nothing LocalHost Nothing)
934 (JID Nothing (peerAddress session) Nothing)
935 (Just (ContentText stanza_id))
936 req)
937 -- Client equiv: liftIO . atomically . writeTChan cmdChan . Send $ iq_service_unavailable host stanza_id Nothing req
938 case tagName child of
939 -- "{http://jabber.org/protocol/disco#items}query" -> liftIO $ debugStr "iq-get-query-items"
940 "{urn:xmpp:ping}ping" -> liftIO $ do
941 sendPeerMessage session (Pong (JID Nothing LocalHost Nothing)
942 (JID Nothing (peerAddress session) Nothing)
943 (Just (ContentText stanza_id)))
944 -- Client equiv: atomically . writeTChan cmdChan . Send $ pong
945 return ()
946
947 req -> unhandledGet req
948
949fromPeer :: (MonadThrow m,MonadIO m, JabberPeerSession session) =>
950 RestrictedSocket -> session -> TVar Bool -> Sink XML.Event m ()
951fromPeer sock session didClose = doNestingXML $ do
952 let log = liftIO . debugL . ("(P) " <++>)
953 withXML $ \begindoc -> do
954 when (begindoc==EventBeginDocument) $ do
955 log "begin-doc"
956 withXML $ \xml -> do
957 withJust (elementAttrs "stream" xml) $ \stream_attrs -> do
958 log $ "stream atributes: " <++> bshow stream_attrs
959
960 let doTimeout = Thunk $ do
961 atomically $ writeTVar didClose True
962 closePeerSession session
963
964 fix $ \loop -> do
965 log "waiting for stanza."
966 whenJust nextElement $ \stanza -> do
967 stanza_lvl <- nesting
968
969 liftIO $ sendPeerMessage session (ActivityBump doTimeout) -- reset ping timer
970
971 let unhandledStanza = do
972 xs <- gatherElement stanza Seq.empty
973 prettyPrint "P: " (toList xs)
974 case () of
975 _ | stanza `isServerIQOf` iqTypeGet -> handlePeerIQGet session stanza
976 _ | stanza `isPresenceOf` presenceTypeOnline
977 -> handlePeerPresence session stanza True
978 _ | stanza `isPresenceOf` presenceTypeOffline
979 -> handlePeerPresence session stanza False
980 _ | stanza `isPresenceOf` presenceTypeProbe
981 -> handlePresenceProbe session stanza
982 _ | stanza `isPresenceOf` presenceTypeSubscribe
983 -> peerRequestsSubsription session stanza
984 _ | stanza `isPresenceOf` presenceTypeSubscribed
985 -> peerApprovesSubscription session stanza
986 _ | stanza `isPresenceOf` presenceTypeUnsubscribed
987 -> peerRejectsSubscription session stanza
988 _ | isMessageStanza stanza
989 -> handlePeerMessage session stanza
990 _ -> unhandledStanza
991
992 awaitCloser stanza_lvl
993 loop
994
995 log $ "end of stream"
996 withXML $ \xml -> do
997 log $ "end-of-document: " <++> bshow xml
998
999
1000
1001
1002newServerConnections = newTVar Map.empty
1003
1004data CachedMessages = CachedMessages
1005 { presences :: Map JID JabberShow
1006 , probes :: Map JID (Set (Bool,JID)) -- False means solicitation rather than probe
1007 , approvals :: Map JID (Set (Bool,JID) ) -- False means rejection rather than approval
1008 }
1009
1010instance CommandCache CachedMessages where
1011 type CacheableCommand CachedMessages = OutBoundMessage
1012 emptyCache = CachedMessages Map.empty Map.empty Map.empty
1013
1014 updateCache (OutBoundPresence (Presence jid Offline)) cache =
1015 cache { presences=Map.delete jid . presences $ cache }
1016 updateCache (OutBoundPresence p@(Presence jid st)) cache =
1017 cache { presences=Map.insert jid st . presences $ cache }
1018 updateCache (PresenceProbe from to) cache =
1019 cache { probes = mmInsert (True,from) to $ probes cache }
1020 updateCache (Solicitation from to) cache =
1021 cache { probes= mmInsert (False,from) to $ probes cache }
1022 updateCache (Approval from to) cache =
1023 cache { approvals= mmInsert (True,from) to $ approvals cache }
1024 updateCache (Rejection from to) cache =
1025 cache { approvals= mmInsert (False,from) to $ approvals cache }
1026 updateCache (OutBoundMessage msg) cache = cache -- TODO: cache chat?
1027 updateCache (Pong _ _ _) cache = trace "(DISCARDING Pong)" cache -- pings are not cached
1028 updateCache (Unsupported _ _ _ _) cache = cache -- error messages are not cached
1029 updateCache (ActivityBump sock) cache = cache
1030
1031instance ThreadChannelCommand OutBoundMessage where
1032 isQuitCommand Disconnect = True
1033 isQuitCommand _ = False
1034
1035mmInsert val key mm = Map.alter f key mm
1036 where
1037 f Nothing = Just $ Set.singleton val
1038 f (Just set) = Just $ Set.insert val set
1039
1040
1041greetPeer =
1042 [ EventBeginDocument
1043 , EventBeginElement (streamP "stream")
1044 [ attr "xmlns" "jabber:server"
1045 , attr "version" "1.0"
1046 ]
1047 ]
1048
1049goodbyePeer =
1050 [ EventEndElement (streamP "stream")
1051 , EventEndDocument
1052 ]
1053
1054peerJidTextLocal sock jid = do
1055 addr <- getSocketName sock
1056 return . toStrict . L.decodeUtf8
1057 $ name jid <$++> "@"
1058 <?++> showPeer (RemotePeer addr)
1059 <++?> "/" <++$> resource jid
1060
1061peerJidTextRemote sock jid = do
1062 addr <- getPeerName sock
1063 return . toStrict . L.decodeUtf8
1064 $ name jid <$++> "@"
1065 <?++> showPeer (RemotePeer addr)
1066 <++?> "/" <++$> resource jid
1067
1068presenceStanza sock fromjid tojid typ = do
1069 from <- peerJidTextLocal sock fromjid
1070 let to = toStrict . L.decodeUtf8
1071 $ name tojid <$++> "@"
1072 <?++> showPeer (peer tojid)
1073 return
1074 [ EventBeginElement "{jabber:server}presence"
1075 [ attr "from" from
1076 , attr "to" to
1077 , attr "type" typ
1078 ]
1079 , EventEndElement "{jabber:server}presence"
1080 ]
1081
1082
1083toPeer
1084 :: SocketLike sock =>
1085 sock
1086 -> CachedMessages
1087 -> TChan OutBoundMessage
1088 -> (Maybe OutBoundMessage -> IO ())
1089 -> ConduitM i [Event] IO ()
1090toPeer sock cache chan fail = do
1091 let -- log = liftIO . debugL . ("(>P) " <++>)
1092 send xs = yield xs >> prettyPrint ">P: " xs -- >> return (3::Int)
1093 checkConnection cmd = do
1094 liftIO $ catchIO (getPeerName sock >> return ())
1095 (\_ -> fail . Just $ cmd)
1096 sendOrFail getXML cmd = do
1097 checkConnection cmd
1098 r <- liftIO $ getXML
1099 -- handleIO (\e -> debugStr ("ERROR: "++show e) >> return []) getXML
1100 yieldOr r (fail . Just $ cmd)
1101 prettyPrint ">P: " r
1102 sendPresence presence =
1103 sendOrFail (xmlifyPresenceForPeer sock presence)
1104 (OutBoundPresence presence)
1105 sendProbe from to =
1106 sendOrFail (presenceStanza sock from to "probe")
1107 (PresenceProbe from to)
1108 sendSolicitation from to =
1109 sendOrFail (presenceStanza sock from to "subscribe")
1110 (Solicitation from to)
1111 sendApproval approve from to =
1112 sendOrFail (presenceStanza sock from to
1113 (if approve then "subscribed" else "unsubscribed"))
1114 (if approve then Approval from to
1115 else Rejection from to)
1116 sendMessage msg =
1117 sendOrFail (xmlifyMessageForPeer sock msg)
1118 (OutBoundMessage msg)
1119
1120 sendPong from to mid = do
1121 liftIO . debugL $ "SEND PONG"
1122 sendOrFail (xmlifyPong sock from to mid)
1123 (Pong from to mid)
1124 where
1125 xmlifyPong sock from to mid = do
1126 fromjid <- peerJidTextLocal sock to
1127 tojid <- peerJidTextRemote sock to
1128 return $ [ EventBeginElement "{jabber:server}iq"
1129 $ (case mid of
1130 Just c -> (("id",[c]):)
1131 _ -> id )
1132 [ attr "type" "result"
1133 , attr "to" tojid
1134 , attr "from" fromjid
1135 ]
1136 , EventEndElement "{jabber:server}iq"
1137 ]
1138 sendUnsupported from to mid tag =
1139 sendOrFail (xmlifyUnsupported sock from to mid tag)
1140 (Unsupported from to mid tag)
1141 where
1142 xmlifyUnsupported sock from to mid req = do
1143 fromjid <- peerJidTextLocal sock to
1144 tojid <- peerJidTextRemote sock to
1145 return $
1146 [ EventBeginElement "{jabber:server}iq"
1147 $ (case mid of
1148 Just c -> (("id",[c]):)
1149 _ -> id )
1150 [("type",[ContentText "error"])
1151 , attr "to" tojid
1152 , attr "from" fromjid
1153 ]
1154 , EventBeginElement req []
1155 , EventEndElement req
1156 , EventBeginElement "{jabber:server}error" [("type",[ContentText "cancel"])]
1157 , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-stanzas}service-unavailable" []
1158 , EventEndElement "{urn:ietf:params:xml:ns:xmpp-stanzas}service-unavailable"
1159 , EventEndElement "{jabber:server}error"
1160 , EventEndElement "{jabber:server}iq"
1161 ]
1162
1163
1164 send greetPeer
1165 forM_ (Map.assocs . approvals $ cache) $ \(to,froms) -> do
1166 forM_ (Set.toList froms) $ \(approve,from) -> do
1167 liftIO $ debugL "sending cached approval/rejection..."
1168 sendApproval approve from to
1169 forM_ (Map.assocs . presences $ cache) $ \(jid,st) -> do
1170 sendPresence (Presence jid st)
1171 forM_ (Map.assocs . probes $ cache) $ \(to,froms) -> do
1172 forM_ (Set.toList froms) $ \(got,from) -> do
1173 if got
1174 then do
1175 liftIO $ debugL "sending cached probe..."
1176 sendProbe from to
1177 else do
1178 liftIO $ debugL "sending cached solicitation..."
1179 sendSolicitation from to
1180
1181
1182 let five_sec = 5 * 1000000 :: Int
1183 pingref <- liftIO $ do
1184 ping_timer <- liftIO $ newDelay five_sec
1185 newTVarIO (ping_timer,0::Int)
1186
1187 sockref <- liftIO $ atomically newEmptyTMVar
1188 let bump fromsock = do
1189 remote <- liftIO $ catchIO (fmap Just $ getPeerName sock)
1190 (\_ -> return Nothing)
1191 debugL $ "PING BUMP" <++?> fmap (showPeer . RemotePeer) remote
1192 timer <- atomically $ do
1193 tryTakeTMVar sockref
1194 putTMVar sockref fromsock
1195 (timer,v) <- readTVar pingref
1196 writeTVar pingref (timer,0)
1197 return timer
1198 updateDelay timer five_sec
1199 waitPing = do
1200 (timer,v) <- readTVar pingref
1201 waitDelay timer
1202 return v
1203
1204 fix $ \loop -> do
1205 liftIO . debugStr $ "LOOP waiting..."
1206 event <- lift . atomically $ orElse (Left `fmap` readTChan chan)
1207 (Right `fmap` waitPing)
1208 liftIO . debugStr $ "LOOP event = " ++ show event
1209 let sendPing n = do
1210 case n of
1211 0 -> do
1212 ping <- liftIO makePing
1213 yield ping
1214 liftIO . debugL $ "SEND PING"
1215 prettyPrint ">P: " ping
1216 ping_timer <- liftIO $ newDelay five_sec
1217 liftIO . atomically $ writeTVar pingref (ping_timer,1)
1218 loop
1219 1 -> do
1220 remote <- liftIO $ getPeerName sock
1221 liftIO . debugL $ "PING TIMEOUT: " <++> showPeer (RemotePeer remote)
1222 fromsock <- liftIO $ atomically $ readTMVar sockref
1223 -- liftIO $ sClose fromsock
1224 liftIO $ runThunk fromsock
1225
1226 return () -- PING TIMEOUT (loop quits)
1227 x -> error ("What? "++show x)
1228 where makePing = do
1229 addr <- getSocketName sock
1230 remote <- getPeerName sock
1231 let from = toStrict . L.decodeUtf8 . showPeer $ RemotePeer addr
1232 to = toStrict . L.decodeUtf8 . showPeer $ RemotePeer remote
1233 mid = Just (ContentText "iduno")
1234 return $
1235 [ EventBeginElement "{jabber:server}iq"
1236 $ (case mid of
1237 Just c -> (("id",[c]):)
1238 _ -> id )
1239 [ ("type",[ContentText "get"])
1240 , attr "to" to
1241 , attr "from" from
1242 ]
1243 , EventBeginElement "{urn:xmpp:ping}ping" []
1244 , EventEndElement "{urn:xmpp:ping}ping"
1245 , EventEndElement "{jabber:server}iq" ]
1246 chanEvent event = do
1247 case event of
1248 OutBoundPresence p -> sendPresence p
1249 PresenceProbe from to -> do
1250 liftIO $ debugL "sending live probe..."
1251 sendProbe from to
1252 Solicitation from to -> do
1253 liftIO $ debugL "sending live solicitation..."
1254 sendSolicitation from to
1255 Approval from to -> do
1256 liftIO . debugL $ "sending approval "<++>bshow (from,to)
1257 sendApproval True from to
1258 Rejection from to -> do
1259 liftIO . debugL $ "sending rejection "<++>bshow (from,to)
1260 sendApproval False from to
1261 OutBoundMessage msg -> sendMessage msg
1262 Pong from to mid -> do
1263 liftIO . debugL $ "sending pong "<++>bshow (from,to)
1264 sendPong from to mid
1265 Unsupported from to mid tag -> sendUnsupported from to mid tag
1266 Disconnect -> return ()
1267 ActivityBump fromsock -> liftIO (bump fromsock)
1268 when (not . isQuitCommand $ event) loop
1269 either chanEvent sendPing event
1270 return ()
1271 -- send goodbyePeer -- TODO: why does this cause an exception?
1272 -- Text/XML/Stream/Render.hs:169:5-15:
1273 -- Irrefutable pattern failed for pattern (sl : s')
1274
1275
1276
1277
1278seekRemotePeers :: JabberPeerSession config =>
1279 XMPPPeerClass config -> TChan Presence -> OutgoingConnections CachedMessages -> IO b0
1280seekRemotePeers config chan server_connections = do
1281 fix $ \loop -> do
1282 event <- atomically $ readTChan chan
1283 case event of
1284 p@(Presence jid stat) | not (is_remote (peer jid)) -> do
1285 -- debugL $ "seekRemotePeers: " <++> L.show jid <++> " " <++> bshow stat
1286 runMaybeT $ do
1287 u <- MaybeT . return $ name jid
1288 subscribers <- liftIO $ do
1289 subs <- getSubscribers config u
1290 mapM parseHostNameJID subs
1291 -- liftIO . debugL $ "subscribers: " <++> bshow subscribers
1292 let peers = Set.map peer (Set.fromList subscribers)
1293 forM_ (Set.toList peers) $ \peer -> do
1294 when (is_remote peer) $
1295 liftIO $ sendMessage server_connections (OutBoundPresence p) peer
1296 _ -> return (Just ())
1297 loop
1298
1299xmlifyPresenceForPeer sock (Presence jid stat) = do
1300 addr <- getSocketName sock
1301 let n = name jid
1302 rsc = resource jid
1303 jidstr = toStrict . L.decodeUtf8
1304 $ n <$++> "@" <?++> showPeer (RemotePeer addr) <++?> "/" <++$> rsc
1305 return $
1306 [ EventBeginElement "{jabber:server}presence"
1307 (attr "from" jidstr:typ stat) ]
1308 ++ ( shw stat >>= jabberShow ) ++
1309 [ EventEndElement "{jabber:server}presence" ]
1310 where
1311 typ Offline = [attr "type" "unavailable"]
1312 typ _ = []
1313
1314 shw ExtendedAway = ["xa"]
1315 shw Chatty = ["chat"]
1316 shw Away = ["away"]
1317 shw DoNotDisturb = ["dnd"]
1318 shw _ = []
1319 jabberShow stat =
1320 [ EventBeginElement "{jabber:server}show" []
1321 , EventContent (ContentText stat)
1322 , EventEndElement "{jabber:server}show" ]
1323
1324xmlifyMessageForClient msg = do
1325 let tojid = msgTo msg
1326 fromjid = msgFrom msg
1327 tonames <- getNamesForPeer (peer tojid)
1328 fromnames <- getNamesForPeer (peer fromjid)
1329 let mk_str ns jid = toStrict . L.decodeUtf8 $ name jid <$++> "@" <?++> L.fromChunks [head ns] <++?> "/" <++$> resource jid
1330 to_str = mk_str tonames tojid
1331 from_str = mk_str fromnames fromjid
1332 tags = ( "{jabber:client}subject"
1333 , "{jabber:client}body"
1334 )
1335 return $
1336 [ EventBeginElement "{jabber:client}message"
1337 [ attr "from" from_str
1338 , attr "to" to_str
1339 ]
1340 ]
1341 ++ xmlifyMsgElements tags (msgLangMap msg) ++
1342 [ EventEndElement "{jabber:client}message" ]
1343
1344
1345xmlifyMessageForPeer sock msg = do
1346 addr <- getSocketName sock
1347 remote <- getPeerName sock
1348 let n = name (msgFrom msg)
1349 rsc = resource (msgFrom msg)
1350 jidstr = toStrict . L.decodeUtf8
1351 $ n <$++> "@" <?++> showPeer (RemotePeer addr) <++?> "/" <++$> rsc
1352 tostr = toStrict . L.decodeUtf8
1353 $ name (msgTo msg) <$++> "@"
1354 <?++> showPeer (RemotePeer remote) <++?> "/"
1355 <++$> resource (msgTo msg)
1356 tags = ( "{jabber:server}subject"
1357 , "{jabber:server}body"
1358 )
1359 return $
1360 [ EventBeginElement "{jabber:server}message"
1361 [ attr "from" jidstr
1362 , attr "to" tostr
1363 ]
1364 ]
1365 ++ xmlifyMsgElements tags (msgLangMap msg) ++
1366 [ EventEndElement "{jabber:server}message" ]
1367
1368xmlifyMsgElements tags langmap = concatMap (uncurry (langElements tags)) . Map.toList $ langmap
1369
1370langElements (subjecttag,bodytag) lang msg =
1371 ( maybeToList (msgSubject msg)
1372 >>= wrap subjecttag )
1373 ++ ( maybeToList (msgBody msg)
1374 >>= wrap bodytag )
1375 ++ ( Set.toList (msgElements msg)
1376 >>= wrapTriple )
1377 where
1378 wrap name content =
1379 [ EventBeginElement name
1380 ( if lang/="" then [attr "xml:lang" lang]
1381 else [] )
1382 , EventContent (ContentText content)
1383 , EventEndElement name
1384 ]
1385 wrapTriple (name,attrs,content) =
1386 [ EventBeginElement name attrs -- Note: we assume lang specified in attrs
1387 , EventContent (ContentText content)
1388 , EventEndElement name
1389 ]
1390
1391
1392handleClientMessage session stanza = do
1393 let log = liftIO . debugL . ("(C) " <++>)
1394 log $ "handleClientMessage "<++>bshow stanza
1395 from <- liftIO $ getJID session
1396 withJust (lookupAttrib "to" (tagAttrs stanza)) $ \to_str -> do
1397 log $ " to = "<++>bshow to_str
1398 tojid <- liftIO $ parseHostNameJID (textToByteString to_str)
1399 msg <- parseMessage ("{jabber:client}body"
1400 ,"{jabber:client}subject"
1401 ,"{jabber:client}thread"
1402 )
1403 log
1404 from
1405 tojid
1406 stanza
1407 liftIO $ sendChat session msg
1408
1409{-
1410unhandled-C: <message
1411unhandled-C: type="chat"
1412unhandled-C: id="purplea0a7fd24"
1413unhandled-C: to="user@vm2"
1414unhandled-C: xmlns="jabber:client">
1415unhandled-C: <active xmlns="http://jabber.org/protocol/chatstates"/>
1416unhandled-C: <body>
1417unhandled-C: hello dude
1418unhandled-C: </body>
1419unhandled-C: </message>
1420-}
1421parseMessage (bodytag,subjecttag,threadtag) log from tojid stanza = do
1422 let emptyMsg = LangSpecificMessage { msgBody=Nothing, msgSubject=Nothing, msgElements=Set.empty }
1423 parseChildren (th,cmap) = do
1424 child <- nextElement
1425 lvl <- nesting
1426 xmllang <- xmlLang
1427 let lang = maybe "" id xmllang
1428 let c = maybe emptyMsg id (Map.lookup lang cmap)
1429 log $ " child: "<++> bshow child
1430 case child of
1431 Just tag | tagName tag==bodytag
1432 -> do
1433 txt <- lift content
1434 awaitCloser lvl
1435 parseChildren (th,Map.insert lang (c { msgBody=Just txt }) cmap)
1436 Just tag | tagName tag==subjecttag
1437 -> do
1438 txt <- lift content
1439 awaitCloser lvl
1440 parseChildren (th,Map.insert lang (c { msgSubject=Just txt }) cmap)
1441 Just tag | tagName tag==threadtag
1442 -> do
1443 txt <- lift content
1444 awaitCloser lvl
1445 parseChildren (th {msgThreadContent=txt},cmap)
1446 Just tag -> do
1447 let nm = tagName tag
1448 attrs = tagAttrs tag
1449 elems = msgElements c
1450 txt <- lift content
1451 awaitCloser lvl
1452 parseChildren (th,Map.insert lang (c {msgElements=Set.insert (nm,attrs,txt) elems}) cmap)
1453 Nothing -> return (th,cmap)
1454 (th,langmap) <- parseChildren ( MessageThread {msgThreadParent=Nothing, msgThreadContent=""}
1455 , Map.empty )
1456 return Message {
1457 msgTo = tojid,
1458 msgFrom = from,
1459 msgLangMap = langmap,
1460 msgThread = if msgThreadContent th/="" then Just th else Nothing
1461 }
diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
new file mode 100644
index 00000000..2e3c0a37
--- /dev/null
+++ b/Presence/XMPPServer.hs
@@ -0,0 +1,1829 @@
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE RankNTypes #-}
4{-# LANGUAGE FlexibleInstances #-} -- instance for TChan Event
5{-# LANGUAGE DoAndIfThenElse #-}
6module XMPPServer
7 ( xmppServer
8 , ConnectionKey(..)
9 , XMPPServerParameters(..)
10 , XMPPServer
11 , addPeer
12 , StanzaWrap(..)
13 , Stanza(..)
14 , StanzaType(..)
15 , StanzaOrigin(..)
16 , cloneStanza
17 , LangSpecificMessage(..)
18 , peerKeyToText
19 , addrToText
20 , sendModifiedStanzaToPeer
21 , sendModifiedStanzaToClient
22 , presenceProbe
23 , presenceSolicitation
24 , makePresenceStanza
25 , makeInformSubscription
26 , makeRosterUpdate
27 , makeMessage
28 , JabberShow(..)
29 , Server
30 ) where
31
32import ConnectionKey
33import qualified Control.Concurrent.STM.UpdateStream as Slotted
34import Nesting
35import Server
36import EventUtil
37import ControlMaybe
38import LockedChan
39import PeerResolve
40import Blaze.ByteString.Builder (Builder)
41
42import Debug.Trace
43import System.IO (hFlush,stdout)
44import Control.Monad.Trans.Resource
45import Control.Monad.Trans (lift)
46import Control.Monad.IO.Class (MonadIO, liftIO)
47import Control.Monad.Fix (fix)
48import Control.Monad
49import Control.Concurrent (forkIO)
50import Control.Concurrent.STM
51-- import Control.Concurrent.STM.TChan
52import Network.Socket
53import Text.Printf
54import System.Posix.Signals
55import Data.ByteString (ByteString)
56import qualified Data.ByteString.Char8 as Strict8
57-- import qualified Data.ByteString.Lazy.Char8 as Lazy8
58import Data.Int (Int8)
59
60import Data.Conduit
61import qualified Data.Conduit.List as CL
62import qualified Data.Conduit.Binary as CB
63import Data.Conduit.Blaze (builderToByteStringFlush)
64
65import qualified Text.XML.Stream.Render as XML hiding (content)
66import qualified Text.XML.Stream.Parse as XML
67import Data.XML.Types as XML
68import Data.Maybe
69import Data.List (nub)
70import Data.Monoid ( (<>) )
71import Data.Text (Text)
72import qualified Data.Text as Text (pack,unpack,words,intercalate)
73import Data.Char (toUpper,chr,ord)
74import Data.Map (Map)
75import qualified Data.Map as Map
76import Data.Set (Set, (\\) )
77import qualified Data.Set as Set
78import Data.String ( IsString(..) )
79import qualified System.Random
80import Data.Void (Void)
81import System.Endian (toBE32)
82import Control.Applicative
83
84peerport :: PortNumber
85peerport = 5269
86clientport :: PortNumber
87clientport = 5222
88
89my_uuid :: Text
90my_uuid = "154ae29f-98f2-4af4-826d-a40c8a188574"
91
92data JabberShow = Offline
93 | ExtendedAway
94 | Away
95 | DoNotDisturb
96 | Available
97 | Chatty
98 deriving (Show,Enum,Ord,Eq,Read)
99
100data MessageThread = MessageThread {
101 msgThreadParent :: Maybe Text,
102 msgThreadContent :: Text
103 }
104 deriving (Show,Eq)
105
106data LangSpecificMessage =
107 LangSpecificMessage { msgBody :: Maybe Text
108 , msgSubject :: Maybe Text
109 }
110 deriving (Show,Eq)
111
112data RosterEventType
113 = RequestedSubscription
114 | NewBuddy -- preceded by PresenceInformSubscription True
115 | RemovedBuddy -- preceded by PresenceInformSubscription False
116 | PendingSubscriber -- same as PresenceRequestSubscription
117 | NewSubscriber
118 | RejectSubscriber
119 deriving (Show,Read,Ord,Eq,Enum)
120
121data ClientHack = SimulatedChatErrors
122 deriving (Show,Read,Ord,Eq,Enum)
123
124data StanzaType
125 = Unrecognized
126 | Ping
127 | Pong
128 | RequestResource (Maybe Text)
129 | SetResource
130 | SessionRequest
131 | UnrecognizedQuery Name
132 | RequestRoster
133 | Roster
134 | RosterEvent { rosterEventType :: RosterEventType
135 , rosterUser :: Text
136 , rosterContact :: Text }
137 | Error StanzaError XML.Event
138 | PresenceStatus { presenceShow :: JabberShow
139 , presencePriority :: Maybe Int8
140 , presenceStatus :: [(Lang,Text)]
141 , presenceWhiteList :: [Text]
142 }
143 | PresenceInformError
144 | PresenceInformSubscription Bool
145 | PresenceRequestStatus
146 | PresenceRequestSubscription Bool
147 | Message { msgThread :: Maybe MessageThread
148 , msgLangMap :: [(Lang,LangSpecificMessage)]
149 }
150 | NotifyClientVersion { versionName :: Text
151 , versionVersion :: Text }
152 | InternalEnableHack ClientHack
153 | InternalCacheId Text
154 deriving (Show,Eq)
155
156data StanzaOrigin = LocalPeer | NetworkOrigin ConnectionKey (TChan Stanza)
157
158data StanzaWrap a = Stanza
159 { stanzaType :: StanzaType
160 , stanzaId :: Maybe Text
161 , stanzaTo :: Maybe Text
162 , stanzaFrom :: Maybe Text
163 , stanzaChan :: a
164 , stanzaClosers :: TVar (Maybe [XML.Event])
165 , stanzaInterrupt :: TMVar ()
166 , stanzaOrigin :: StanzaOrigin
167 }
168
169type Stanza = StanzaWrap (LockedChan XML.Event)
170
171data XMPPServerParameters =
172 XMPPServerParameters
173 { -- | Called when a client requests a resource id. The Maybe value is the
174 -- client's preference.
175 xmppChooseResourceName :: ConnectionKey -> SockAddr -> Maybe Text -> IO Text
176 , -- | This should indicate the server's hostname that all client's see.
177 xmppTellMyNameToClient :: IO Text
178 , xmppTellMyNameToPeer :: SockAddr -> IO Text
179 , xmppTellClientHisName :: ConnectionKey -> IO Text
180 , xmppTellPeerHisName :: ConnectionKey -> IO Text
181 , xmppNewConnection :: ConnectionKey -> SockAddr -> TChan Stanza -> IO ()
182 , xmppEOF :: ConnectionKey -> IO ()
183 , xmppRosterBuddies :: ConnectionKey -> IO [Text]
184 , xmppRosterSubscribers :: ConnectionKey -> IO [Text]
185 , xmppRosterSolicited :: ConnectionKey -> IO [Text]
186 , xmppRosterOthers :: ConnectionKey -> IO [Text]
187 , -- | Called when after sending a roster to a client. Usually this means
188 -- the client status should change from "available" to "interested".
189 xmppSubscribeToRoster :: ConnectionKey -> IO ()
190 -- , xmppLookupClientJID :: ConnectionKey -> IO Text
191 , xmppTellClientNameOfPeer :: ConnectionKey -> [Text] -> IO Text
192 , xmppDeliverMessage :: (IO ()) -> Stanza -> IO ()
193 -- | Called whenever a local client's presence changes.
194 , xmppInformClientPresence :: ConnectionKey -> Stanza -> IO ()
195 -- | Called whenever a remote peer's presence changes.
196 , xmppInformPeerPresence :: ConnectionKey -> Stanza -> IO ()
197 , -- | Called when a remote peer requests our status.
198 xmppAnswerProbe :: ConnectionKey -> Stanza -> TChan Stanza -> IO ()
199 , xmppClientSubscriptionRequest :: IO () -> ConnectionKey -> Stanza -> TChan Stanza -> IO ()
200 , -- | Called when a remote peer sends subscription request.
201 xmppPeerSubscriptionRequest :: IO () -> ConnectionKey -> Stanza -> TChan Stanza -> IO ()
202 , xmppClientInformSubscription :: IO () -> ConnectionKey -> Stanza -> IO ()
203 , -- | Called when a remote peer informs us of our subscription status.
204 xmppPeerInformSubscription :: IO () -> ConnectionKey -> Stanza -> IO ()
205 , xmppVerbosity :: IO Int
206 }
207
208
209enableClientHacks ::
210 forall t a.
211 (Eq a, IsString a) =>
212 a -> t -> TChan Stanza -> IO ()
213enableClientHacks "Pidgin" version replyto = do
214 wlog "Enabling hack SimulatedChatErrors for client Pidgin"
215 donevar <- atomically newEmptyTMVar
216 sendReply donevar
217 (InternalEnableHack SimulatedChatErrors)
218 []
219 replyto
220enableClientHacks "irssi-xmpp" version replyto = do
221 wlog "Enabling hack SimulatedChatErrors for client irssi-xmpp"
222 donevar <- atomically newEmptyTMVar
223 sendReply donevar
224 (InternalEnableHack SimulatedChatErrors)
225 []
226 replyto
227enableClientHacks _ _ _ = return ()
228
229cacheMessageId :: Text -> TChan Stanza -> IO ()
230cacheMessageId id' replyto = do
231 wlog $ "Caching id " ++ Text.unpack id'
232 donevar <- atomically newEmptyTMVar
233 sendReply donevar
234 (InternalCacheId id')
235 []
236 replyto
237
238
239-- TODO: http://xmpp.org/rfcs/rfc6120.html#rules-remote-error
240-- client connection
241-- socat script to send stanza fragment
242-- copyToChannel can keep a stack of closers to append to finish-off a stanza
243-- the TMVar () from forkConnection can be passed and with a stanza to detect interruption
244
245addrToText :: SockAddr -> Text
246addrToText (addr@(SockAddrInet _ _)) = Text.pack $ stripColon (show addr)
247 where stripColon s = pre where (pre,port) = break (==':') s
248addrToText (addr@(SockAddrInet6 _ _ _ _)) = Text.pack $ stripColon (show addr)
249 where stripColon s = if null bracket then pre else pre ++ "]"
250 where
251 (pre,bracket) = break (==']') s
252
253peerKeyToText :: ConnectionKey -> Text
254peerKeyToText (PeerKey { callBackAddress=addr }) = addrToText addr
255peerKeyToText (ClientKey { localAddress=addr }) = "ErrorClIeNt0"
256
257
258wlog :: String -> IO ()
259wlog s = putStrLn s >> hFlush stdout
260
261wlogb :: ByteString -> IO ()
262wlogb s = Strict8.putStrLn s >> hFlush stdout
263
264flushPassThrough :: Monad m => Conduit a m b -> Conduit (Flush a) m (Flush b)
265flushPassThrough c = getZipConduit $ ZipConduit (onlyChunks =$= mapOutput Chunk c) <* ZipConduit onlyFlushes
266 where
267 onlyChunks :: Monad m => Conduit (Flush a) m a
268 onlyFlushes :: Monad m => Conduit (Flush a) m (Flush b)
269 onlyChunks = awaitForever yieldChunk
270 onlyFlushes = awaitForever yieldFlush
271 yieldFlush Flush = yield Flush
272 yieldFlush _ = return ()
273 yieldChunk (Chunk x) = yield x
274 yieldChunk _ = return ()
275
276xmlStream :: ReadCommand -> WriteCommand -> ( Source IO XML.Event
277 , Sink (Flush XML.Event) IO () )
278xmlStream conread conwrite = (xsrc,xsnk)
279 where
280 xsrc = src $= XML.parseBytes XML.def
281 xsnk :: Sink (Flush Event) IO ()
282 xsnk = -- XML.renderBytes XML.def =$ snk
283 flushPassThrough (XML.renderBuilder XML.def)
284 =$= builderToByteStringFlush
285 =$= discardFlush
286 =$ snk
287 where
288 discardFlush :: Monad m => ConduitM (Flush a) a m ()
289 discardFlush = awaitForever yieldChunk
290 yieldChunk (Chunk x) = yield x
291 yieldChunk _ = return ()
292
293 src = do
294 v <- lift conread
295 maybe (return ()) -- lift . wlog $ "conread: Nothing")
296 (yield >=> const src)
297 v
298 snk = awaitForever $ liftIO . conwrite
299
300
301type FlagCommand = STM Bool
302type ReadCommand = IO (Maybe ByteString)
303type WriteCommand = ByteString -> IO Bool
304
305cloneStanza :: StanzaWrap (LockedChan a) -> IO (StanzaWrap (LockedChan a))
306cloneStanza stanza = do
307 dupped <- cloneLChan (stanzaChan stanza)
308 return stanza { stanzaChan = dupped }
309
310copyToChannel
311 :: MonadIO m =>
312 (Event -> a) -> LockedChan a -> TVar (Maybe [Event]) -> ConduitM Event Event m ()
313copyToChannel f chan closer_stack = awaitForever copy
314 where
315 copy x = do
316 liftIO . atomically $ writeLChan chan (f x)
317 case x of
318 EventBeginDocument {} -> do
319 let clsr = closerFor x
320 liftIO . atomically $
321 modifyTVar' closer_stack (fmap (clsr:))
322 EventEndDocument {} -> do
323 liftIO . atomically $
324 modifyTVar' closer_stack (fmap (drop 1))
325 _ -> return ()
326 yield x
327
328
329prettyPrint :: ByteString -> ConduitM Event Void IO ()
330prettyPrint prefix =
331 XML.renderBytes (XML.def { XML.rsPretty=True })
332 =$= CB.lines
333 =$ CL.mapM_ (wlogb . (prefix <>))
334
335swapNamespace :: Monad m => Text -> Text -> ConduitM Event Event m ()
336swapNamespace old new = awaitForever (yield . swapit old new)
337
338swapit :: Text -> Text -> Event -> Event
339swapit old new (EventBeginElement n as) | nameNamespace n==Just old =
340 EventBeginElement (n { nameNamespace = Just new }) as
341swapit old new (EventEndElement n) | nameNamespace n==Just old =
342 EventEndElement (n { nameNamespace = Just new })
343swapit old new x = x
344
345fixHeaders :: Monad m => Stanza -> ConduitM Event Event m ()
346fixHeaders Stanza { stanzaType=typ, stanzaTo=mto, stanzaFrom=mfrom } = do
347 x <- await
348 maybe (return ()) f x
349 where
350 f (EventBeginElement n as) = do yield $ EventBeginElement n (update n as)
351 awaitForever yield
352 f x = yield x >> awaitForever yield
353 update n as = as3
354 where
355 as' = maybe as (setAttrib "to" as) mto
356 as'' = maybe as' (setAttrib "from" as') mfrom
357 as3 = case typ of
358 PresenceStatus {} | nameNamespace n == Just "jabber:client"
359 -> delAttrib "whitelist" as''
360 PresenceStatus {} | otherwise
361 -> case presenceWhiteList typ of
362 [] -> delAttrib "whitelist" as''
363 ws -> setAttrib "whitelist" as'' (Text.intercalate " " ws)
364 _ -> as''
365
366 setAttrib akey as aval = attr akey aval:filter ((/=akey) . fst) as
367 delAttrib akey as = filter ((/=akey) . fst) as
368
369conduitToChan
370 :: Conduit () IO Event
371 -> IO (LockedChan Event, TVar (Maybe [Event]), TMVar a)
372conduitToChan c = do
373 chan <- atomically newLockedChan
374 clsrs <- atomically $ newTVar (Just [])
375 quitvar <- atomically $ newEmptyTMVar
376 forkIO $ do
377 c =$= copyToChannel id chan clsrs $$ awaitForever (const $ return ())
378 atomically $ writeTVar clsrs Nothing
379 return (chan,clsrs,quitvar)
380
381conduitToStanza
382 :: StanzaType
383 -> Maybe Text -- ^ id
384 -> Maybe Text -- ^ from
385 -> Maybe Text -- ^ to
386 -> Conduit () IO Event
387 -> IO Stanza
388conduitToStanza stype mid from to c = do
389 (chan,clsrs,quitvar) <- conduitToChan c
390 return
391 Stanza { stanzaType = stype
392 , stanzaId = mid
393 , stanzaTo = to
394 , stanzaFrom = from
395 , stanzaChan = chan
396 , stanzaClosers = clsrs
397 , stanzaInterrupt = quitvar
398 , stanzaOrigin = LocalPeer
399 }
400
401
402ioWriteChan :: MonadIO m => TChan a -> a -> m ()
403ioWriteChan c v = liftIO . atomically $ writeTChan c v
404
405stanzaToConduit :: MonadIO m => Stanza -> ConduitM i Event m ()
406stanzaToConduit stanza = do
407 let xchan = stanzaChan stanza
408 xfin = stanzaClosers stanza
409 rdone = stanzaInterrupt stanza
410 loop = return ()
411 xchan <- liftIO $ unlockChan xchan
412 fix $ \inner -> do
413 what <- liftIO . atomically $ foldr1 orElse
414 [readTChan xchan >>= \xml -> return $ do
415 yield xml -- atomically $ Slotted.push slots Nothing xml
416 inner
417 ,do mb <- readTVar xfin
418 cempty <- isEmptyTChan xchan
419 if isNothing mb
420 then if cempty then return loop else retry
421 else do done <- tryReadTMVar rdone
422 check (isJust done)
423 trace "todo: send closers" retry
424 ,do isEmptyTChan xchan >>= check
425 readTMVar rdone
426 return (return ())]
427 what
428
429
430sendModifiedStanzaToPeer :: Stanza -> TChan Stanza -> IO ()
431sendModifiedStanzaToPeer stanza chan = do
432 (echan,clsrs,quitvar) <- conduitToChan c
433 ioWriteChan chan
434 stanza { stanzaChan = echan
435 , stanzaClosers = clsrs
436 , stanzaInterrupt = quitvar
437 , stanzaType = processedType (stanzaType stanza)
438 -- TODO id? origin?
439 }
440 where
441 old = "jabber:client"
442 new = "jabber:server"
443 c = stanzaToConduit stanza =$= swapNamespace old new =$= fixHeaders stanza
444 processedType (Error cond tag) = Error cond (swapit old new tag)
445 processedType x = x
446
447
448sendModifiedStanzaToClient :: Stanza -> TChan Stanza -> IO ()
449sendModifiedStanzaToClient stanza chan = do
450 (echan,clsrs,quitvar) <- conduitToChan c
451 -- wlog $ "send-to-client " ++ show (stanzaId stanza)
452 ioWriteChan chan
453 stanza { stanzaChan = echan
454 , stanzaClosers = clsrs
455 , stanzaInterrupt = quitvar
456 , stanzaType = processedType (stanzaType stanza)
457 -- TODO id? origin?
458 }
459 where
460 old = "jabber:server"
461 new = "jabber:client"
462 c = stanzaToConduit stanza =$= swapNamespace old new =$= fixHeaders stanza
463 processedType (Error cond tag) = Error cond (swapit old new tag)
464 processedType x = x
465
466
467-- id,to, and from are taken as-is from reply list
468-- todo: this should probably be restricted to IO monad
469sendReply :: (Functor m, MonadIO m) => TMVar () -> StanzaType -> [Event] -> TChan Stanza -> m ()
470sendReply donevar stype reply replychan = do
471 let stanzaTag = listToMaybe reply
472 mid = stanzaTag >>= lookupAttrib "id" . tagAttrs
473 mfrom = stanzaTag >>= lookupAttrib "from" . tagAttrs
474 mto = stanzaTag >>= lookupAttrib "to" . tagAttrs
475 isInternal (InternalEnableHack {}) = True
476 isInternal (InternalCacheId {}) = True
477 isInternal _ = False
478 flip (maybe $ return ())
479 (fmap (const ()) stanzaTag `mplus` guard (isInternal stype))
480 . const $ do
481 replyStanza <- liftIO . atomically $ do
482 replyChan <- newLockedChan
483 replyClsrs <- newTVar (Just [])
484 return Stanza { stanzaType = stype
485 , stanzaId = mid
486 , stanzaTo = mto -- as-is from reply list
487 , stanzaFrom = mfrom -- as-is from reply list
488 , stanzaChan = replyChan
489 , stanzaClosers = replyClsrs
490 , stanzaInterrupt = donevar
491 , stanzaOrigin = LocalPeer
492 }
493 ioWriteChan replychan replyStanza
494 void . liftIO . forkIO $ do
495 mapM_ (liftIO . atomically . writeLChan (stanzaChan replyStanza)) reply
496 liftIO . atomically $ writeTVar (stanzaClosers replyStanza) Nothing
497 -- liftIO $ wlog "finished reply stanza"
498
499stanzaFromList :: StanzaType -> [Event] -> IO Stanza
500stanzaFromList stype reply = do
501 let stanzaTag = listToMaybe reply
502 mid = stanzaTag >>= lookupAttrib "id" . tagAttrs
503 mfrom = stanzaTag >>= lookupAttrib "from" . tagAttrs
504 mto = stanzaTag >>= lookupAttrib "to" . tagAttrs
505 {-
506 isInternal (InternalEnableHack {}) = True
507 isInternal (InternalCacheId {}) = True
508 isInternal _ = False
509 -}
510 (donevar,replyChan,replyClsrs) <- atomically $ do
511 donevar <- newEmptyTMVar -- TMVar ()
512 replyChan <- newLockedChan
513 replyClsrs <- newTVar (Just [])
514 return (donevar,replyChan, replyClsrs)
515 forkIO $ do
516 forM_ reply $ atomically . writeLChan replyChan
517 atomically $ do putTMVar donevar ()
518 writeTVar replyClsrs Nothing
519 return Stanza { stanzaType = stype
520 , stanzaId = mid
521 , stanzaTo = mto -- as-is from reply list
522 , stanzaFrom = mfrom -- as-is from reply list
523 , stanzaChan = replyChan
524 , stanzaClosers = replyClsrs
525 , stanzaInterrupt = donevar
526 , stanzaOrigin = LocalPeer
527 }
528
529grokStanzaIQGet :: Monad m => XML.Event -> NestingXML o m (Maybe StanzaType)
530grokStanzaIQGet stanza = do
531 mtag <- nextElement
532 flip (maybe $ return Nothing) mtag $ \tag -> do
533 case tagName tag of
534 "{urn:xmpp:ping}ping" -> return $ Just Ping
535 "{jabber:iq:roster}query" -> return $ Just RequestRoster
536 name -> return . Just $ UnrecognizedQuery name
537
538parseClientVersion :: NestingXML o IO (Maybe StanzaType)
539parseClientVersion = parseit Nothing Nothing
540 where
541 reportit mname mver = return $ do
542 name <- mname
543 ver <- mver
544 return NotifyClientVersion { versionName=name, versionVersion=ver }
545 parseit :: Maybe Text -> Maybe Text -> NestingXML o IO (Maybe StanzaType)
546 parseit mname mver = do
547 mtag <- nextElement
548 flip (maybe $ reportit mname mver) mtag $ \tag -> do
549 case tagName tag of
550 "{jabber:iq:version}name" -> do
551 x <- XML.content
552 parseit (Just x) mver
553 "{jabber:iq:version}version" -> do
554 x <- XML.content
555 parseit mname (Just x)
556 _ -> parseit mname mver
557
558
559grokStanzaIQResult :: XML.Event -> NestingXML o IO (Maybe StanzaType)
560grokStanzaIQResult stanza = do
561 mtag <- nextElement
562 flip (maybe $ return (Just Pong)) mtag $ \tag -> do
563 case tagName tag of
564 "{jabber:iq:version}query" | nameNamespace (tagName stanza)==Just "jabber:client"
565 -> parseClientVersion
566 _ -> return Nothing
567
568grokStanzaIQSet :: XML.Event -> NestingXML o IO (Maybe StanzaType)
569grokStanzaIQSet stanza = do
570 mtag <- nextElement
571 flip (maybe $ return Nothing) mtag $ \tag -> do
572 case tagName tag of
573 "{urn:ietf:params:xml:ns:xmpp-bind}bind" -> do
574 mchild <- nextElement
575 case fmap tagName mchild of
576 Just "{urn:ietf:params:xml:ns:xmpp-bind}resource" -> do
577 rsc <- XML.content -- TODO: MonadThrow???
578 return . Just $ RequestResource (Just rsc)
579 Just _ -> return Nothing
580 Nothing -> return . Just $ RequestResource Nothing
581 "{urn:ietf:params:xml:ns:xmpp-session}session" -> do
582 return $ Just SessionRequest
583 _ -> return Nothing
584
585
586{-
587C->Unrecognized <iq
588C->Unrecognized type="set"
589C->Unrecognized id="purpleae62d88f"
590C->Unrecognized xmlns="jabber:client">
591C->Unrecognized <bind xmlns="urn:ietf:params:xml:ns:xmpp-bind"/>
592C->Unrecognized </iq>
593-}
594chanContents :: TChan x -> IO [x]
595chanContents ch = do
596 x <- atomically $ do
597 bempty <- isEmptyTChan ch
598 if bempty
599 then return Nothing
600 else fmap Just $ readTChan ch
601 maybe (return [])
602 (\x -> do
603 xs <- chanContents ch
604 return (x:xs))
605 x
606
607
608parsePresenceStatus
609 :: ( MonadThrow m
610 , MonadIO m
611 ) => Text -> XML.Event -> NestingXML o m (Maybe StanzaType)
612parsePresenceStatus ns stanzaTag = do
613
614 let toStat "away" = Away
615 toStat "xa" = ExtendedAway
616 toStat "dnd" = DoNotDisturb
617 toStat "chat" = Chatty
618
619 showv <- liftIO . atomically $ newTVar Available
620 priov <- liftIO . atomically $ newTVar Nothing
621 statusv <- liftIO . atomically $ newTChan
622 fix $ \loop -> do
623 mtag <- nextElement
624 flip (maybe $ return ()) mtag $ \tag -> do
625 when (nameNamespace (tagName tag) == Just ns) $ do
626 case nameLocalName (tagName tag) of
627 "show" -> do t <- XML.content
628 liftIO . atomically $ writeTVar showv (toStat t)
629 "priority" -> do t <- XML.content
630 liftIO . handleIO_ (return ()) $ do
631 prio <- readIO (Text.unpack t)
632 atomically $ writeTVar priov (Just prio)
633 "status" -> do t <- XML.content
634 lang <- xmlLang
635 ioWriteChan statusv (maybe "" id lang,t)
636 _ -> return ()
637 loop
638 show <- liftIO . atomically $ readTVar showv
639 prio <- liftIO . atomically $ readTVar priov
640 status <- liftIO $ chanContents statusv -- Could use unsafeInterleaveIO to
641 -- avoid multiple passes, but whatever.
642 let wlist = do
643 w <- maybeToList $ lookupAttrib "whitelist" (tagAttrs stanzaTag)
644 Text.words w
645 return . Just $ PresenceStatus { presenceShow = show
646 , presencePriority = prio
647 , presenceStatus = status
648 , presenceWhiteList = wlist
649 }
650grokPresence
651 :: ( MonadThrow m
652 , MonadIO m
653 ) => Text -> XML.Event -> NestingXML o m (Maybe StanzaType)
654grokPresence ns stanzaTag = do
655 let typ = lookupAttrib "type" (tagAttrs stanzaTag)
656 case typ of
657 Nothing -> parsePresenceStatus ns stanzaTag
658 Just "unavailable" -> fmap (fmap (\p -> p {presenceShow=Offline}))
659 $ parsePresenceStatus ns stanzaTag
660 Just "error" -> return . Just $ PresenceInformError
661 Just "unsubscribed" -> return . Just $ PresenceInformSubscription False
662 Just "subscribed" -> return . Just $ PresenceInformSubscription True
663 Just "probe" -> return . Just $ PresenceRequestStatus
664 Just "unsubscribe" -> return . Just $ PresenceRequestSubscription False
665 Just "subscribe" -> return . Just $ PresenceRequestSubscription True
666 _ -> return Nothing
667
668parseMessage
669 :: ( MonadThrow m
670 , MonadIO m
671 ) => Text -> XML.Event -> NestingXML o m StanzaType
672parseMessage ns stanza = do
673 let bodytag = Name { nameNamespace = Just ns
674 , nameLocalName = "body"
675 , namePrefix = Nothing }
676 subjecttag = Name { nameNamespace = Just ns
677 , nameLocalName = "subject"
678 , namePrefix = Nothing }
679 threadtag = Name { nameNamespace = Just ns
680 , nameLocalName = "thread"
681 , namePrefix = Nothing }
682 let emptyMsg = LangSpecificMessage { msgBody=Nothing, msgSubject=Nothing }
683 parseChildren (th,cmap) = do
684 child <- nextElement
685 lvl <- nesting
686 xmllang <- xmlLang
687 let lang = maybe "" id xmllang
688 let c = maybe emptyMsg id (Map.lookup lang cmap)
689 -- log $ " child: "<> bshow child
690 case child of
691 Just tag | tagName tag==bodytag
692 -> do
693 txt <- XML.content
694 awaitCloser lvl
695 parseChildren (th,Map.insert lang (c { msgBody=Just txt }) cmap)
696 Just tag | tagName tag==subjecttag
697 -> do
698 txt <- XML.content
699 awaitCloser lvl
700 parseChildren (th,Map.insert lang (c { msgSubject=Just txt }) cmap)
701 Just tag | tagName tag==threadtag
702 -> do
703 txt <- XML.content
704 awaitCloser lvl
705 parseChildren (th {msgThreadContent=txt},cmap)
706 Just tag -> do
707 -- let nm = tagName tag
708 -- attrs = tagAttrs tag
709 -- -- elems = msgElements c
710 -- txt <- XML.content
711 awaitCloser lvl
712 parseChildren (th,Map.insert lang c cmap)
713 Nothing -> return (th,cmap)
714 (th,langmap) <- parseChildren ( MessageThread {msgThreadParent=Nothing, msgThreadContent=""}
715 , Map.empty )
716 return Message {
717 msgLangMap = Map.toList langmap,
718 msgThread = if msgThreadContent th/="" then Just th else Nothing
719 }
720
721findConditionTag :: Monad m => NestingXML o m (Maybe XML.Event)
722findConditionTag = do
723 x <- nextElement
724 flip (maybe $ return Nothing) x $ \x -> do
725 case nameNamespace (tagName x) of
726 Just "urn:ietf:params:xml:ns:xmpp-stanzas" -> return (Just x)
727 _ -> findConditionTag
728
729conditionFromText :: Text -> Maybe StanzaError
730conditionFromText t = fmap fst $ listToMaybe ss
731 where
732 es = [BadRequest .. UnexpectedRequest]
733 ts = map (\e->(e,errorTagLocalName e)) es
734 ss = dropWhile ((/=t) . snd) ts
735
736findErrorTag :: Monad m => Text -> NestingXML o m (Maybe StanzaError)
737findErrorTag ns = do
738 x <- nextElement
739 flip (maybe $ return Nothing) x $ \x -> do
740 case tagName x of
741 n | nameNamespace n==Just ns && nameLocalName n=="error"
742 -> do
743 mtag <- findConditionTag
744 return $ do
745 tag <- {- trace ("mtag = "++show mtag) -} mtag
746 let t = nameLocalName (tagName tag)
747 conditionFromText t
748 _ -> findErrorTag ns
749
750grokMessage
751 :: ( MonadThrow m
752 , MonadIO m
753 ) => Text -> XML.Event -> NestingXML o m (Maybe StanzaType)
754grokMessage ns stanzaTag = do
755 let typ = lookupAttrib "type" (tagAttrs stanzaTag)
756 case typ of
757 Just "error" -> do
758 mb <- findErrorTag ns
759 return $ do
760 e <- mb
761 return $ Error e stanzaTag
762 _ -> do t <- parseMessage ns stanzaTag
763 return $ Just t
764
765
766
767grokStanza
768 :: Text -> XML.Event -> NestingXML o IO (Maybe StanzaType)
769grokStanza "jabber:server" stanzaTag =
770 case () of
771 _ | stanzaTag `isServerIQOf` "get" -> grokStanzaIQGet stanzaTag
772 _ | stanzaTag `isServerIQOf` "result" -> grokStanzaIQResult stanzaTag
773 _ | tagName stanzaTag == "{jabber:server}presence" -> grokPresence "jabber:server" stanzaTag
774 _ | tagName stanzaTag == "{jabber:server}message" -> grokMessage "jabber:server" stanzaTag
775 _ -> return $ Just Unrecognized
776
777grokStanza "jabber:client" stanzaTag =
778 case () of
779 _ | stanzaTag `isClientIQOf` "get" -> grokStanzaIQGet stanzaTag
780 _ | stanzaTag `isClientIQOf` "set" -> grokStanzaIQSet stanzaTag
781 _ | stanzaTag `isClientIQOf` "result" -> grokStanzaIQResult stanzaTag
782 _ | tagName stanzaTag == "{jabber:client}presence" -> grokPresence "jabber:client" stanzaTag
783 _ | tagName stanzaTag == "{jabber:client}message" -> grokMessage "jabber:client" stanzaTag
784 _ -> return $ Just Unrecognized
785
786mkname :: Text -> Text -> XML.Name
787mkname namespace name = (Name name (Just namespace) Nothing)
788
789makeMessage :: Text -> Text -> Text -> Text -> IO Stanza
790makeMessage namespace from to bod =
791 stanzaFromList typ
792 $ [ EventBeginElement (mkname namespace "message")
793 [ attr "from" from
794 , attr "to" to
795 ]
796 , EventBeginElement (mkname namespace "body") []
797 , EventContent (ContentText bod)
798 , EventEndElement (mkname namespace "body")
799 , EventEndElement (mkname namespace "message") ]
800 where
801 typ = Message { msgThread = Nothing
802 , msgLangMap = [("", lsm)]
803 }
804 lsm = LangSpecificMessage
805 { msgBody = Just bod
806 , msgSubject = Nothing }
807
808makeInformSubscription :: Text -> Text -> Text -> Bool -> IO Stanza
809makeInformSubscription namespace from to approved =
810 stanzaFromList (PresenceInformSubscription approved)
811 $ [ EventBeginElement (mkname namespace "presence")
812 [ attr "from" from
813 , attr "to" to
814 , attr "type" $ if approved then "subscribed"
815 else "unsubscribed" ]
816 , EventEndElement (mkname namespace "presence")]
817
818makePresenceStanza :: Text -> Maybe Text -> JabberShow -> IO Stanza
819makePresenceStanza namespace mjid pstat = do
820 stanzaFromList PresenceStatus { presenceShow = pstat
821 , presencePriority = Nothing
822 , presenceStatus = []
823 , presenceWhiteList = []
824 }
825 $ [ EventBeginElement (mkname namespace "presence")
826 (setFrom $ typ pstat) ]
827 ++ (shw pstat >>= jabberShow) ++
828 [ EventEndElement (mkname namespace "presence")]
829 where
830 setFrom = maybe id
831 (\jid -> (attr "from" jid :) )
832 mjid
833 typ Offline = [attr "type" "unavailable"]
834 typ _ = []
835 shw ExtendedAway = ["xa"]
836 shw Chatty = ["chat"]
837 shw Away = ["away"]
838 shw DoNotDisturb = ["dnd"]
839 shw _ = []
840 jabberShow stat =
841 [ EventBeginElement "{jabber:client}show" []
842 , EventContent (ContentText stat)
843 , EventEndElement "{jabber:client}show" ]
844
845makeRosterUpdate :: Text -> Text -> [(Name, Text)] -> IO Stanza
846makeRosterUpdate tojid contact as = do
847 let attrs = map (uncurry attr) as
848 stanzaFromList Unrecognized
849 [ EventBeginElement "{jabber:client}iq"
850 [ attr "to" tojid
851 , attr "id" "someid"
852 , attr "type" "set"
853 ]
854 , EventBeginElement "{jabber:iq:roster}query" []
855 , EventBeginElement "{jabber:iq:roster}item" (attr "jid" contact : attrs)
856 , EventEndElement "{jabber:iq:roster}item"
857 , EventEndElement "{jabber:iq:roster}query"
858 , EventEndElement "{jabber:client}iq"
859 ]
860
861makePong :: Text -> Maybe Text -> Text -> Text -> [XML.Event]
862makePong namespace mid to from =
863 -- Note: similar to session reply
864 [ EventBeginElement (mkname namespace "iq")
865 $(case mid of
866 Just c -> (("id",[ContentText c]):)
867 _ -> id)
868 [ attr "type" "result"
869 , attr "to" to
870 , attr "from" from
871 ]
872 , EventEndElement (mkname namespace "iq")
873 ]
874
875
876xmppInbound :: Server ConnectionKey SockAddr
877 -> XMPPServerParameters
878 -> ConnectionKey
879 -> SockAddr
880 -> FlagCommand -- ^ action to check whether the connection needs a ping
881 -> TChan Stanza -- ^ channel to announce incomming stanzas on
882 -> TChan Stanza -- ^ channel used to send stanzas
883 -> TMVar () -- ^ mvar that is filled when the connection quits
884 -> Sink XML.Event IO ()
885xmppInbound sv xmpp k laddr pingflag stanzas output donevar = doNestingXML $ do
886 let (namespace,tellmyname,tellyourname) = case k of
887 ClientKey {} -> ( "jabber:client"
888 , xmppTellMyNameToClient xmpp
889 , xmppTellClientHisName xmpp k
890 )
891 PeerKey {} -> ( "jabber:server"
892 , xmppTellMyNameToPeer xmpp laddr
893 , xmppTellPeerHisName xmpp k
894 )
895 me <- liftIO tellmyname
896 withXML $ \begindoc -> do
897 when (begindoc==EventBeginDocument) $ do
898 whenJust nextElement $ \xml -> do
899 withJust (elementAttrs "stream" xml) $ \stream_attrs -> do
900 fix $ \loop -> do
901 -- liftIO . wlog $ "waiting for stanza."
902 (chan,clsrs) <- liftIO . atomically $
903 liftM2 (,) newLockedChan (newTVar (Just []))
904 whenJust nextElement $ \stanzaTag -> do
905 stanza_lvl <- nesting
906 liftIO . atomically $ do
907 writeLChan chan stanzaTag
908 modifyTVar' clsrs (fmap (closerFor stanzaTag:))
909 copyToChannel id chan clsrs =$= do
910 let mid = lookupAttrib "id" (tagAttrs stanzaTag)
911 mfrom = lookupAttrib "from" (tagAttrs stanzaTag)
912 mto = lookupAttrib "to" (tagAttrs stanzaTag)
913 dispatch <- grokStanza namespace stanzaTag
914 let unrecog = do
915 let stype = Unrecognized
916 s <- liftIO . atomically $ do
917 return Stanza
918 { stanzaType = stype
919 , stanzaId = mid
920 , stanzaTo = mto
921 , stanzaFrom = mfrom
922 , stanzaChan = chan
923 , stanzaClosers = clsrs
924 , stanzaInterrupt = donevar
925 , stanzaOrigin = NetworkOrigin k output
926 }
927 ioWriteChan stanzas s
928 you <- liftIO tellyourname
929 flip (maybe $ unrecog) dispatch $ \dispatch ->
930 case dispatch of
931 -- Checking that the to-address matches this server.
932 -- Otherwise it could be a client-to-client ping or a
933 -- client-to-server for some other server.
934 -- For now, assuming its for the immediate connection.
935 Ping | mto==Just me || mto==Nothing -> do
936 let pongto = maybe you id mfrom
937 pongfrom = maybe me id mto
938 pong = makePong namespace mid pongto pongfrom
939 sendReply donevar Pong pong output
940#ifdef PINGNOISE
941 -- TODO: Remove this, it is only to generate a debug print
942 ioWriteChan stanzas Stanza
943 { stanzaType = Ping
944 , stanzaId = mid
945 , stanzaTo = mto
946 , stanzaFrom = mfrom
947 , stanzaChan = chan
948 , stanzaClosers = clsrs
949 , stanzaInterrupt = donevar
950 , stanzaOrigin = NetworkOrigin k output
951 }
952#endif
953 stype -> ioWriteChan stanzas Stanza
954 { stanzaType = stype
955 , stanzaId = mid
956 , stanzaTo = mto
957 , stanzaFrom = mfrom
958 , stanzaChan = chan
959 , stanzaClosers = clsrs
960 , stanzaInterrupt = donevar
961 , stanzaOrigin = NetworkOrigin k output
962 }
963 awaitCloser stanza_lvl
964 liftIO . atomically $ writeTVar clsrs Nothing
965 loop
966
967
968while :: IO Bool -> IO a -> IO [a]
969while cond body = do
970 b <- cond
971 if b then do x <- body
972 xs <- while cond body
973 return (x:xs)
974 else return []
975
976readUntilNothing :: TChan (Maybe x) -> IO [x]
977readUntilNothing ch = do
978 x <- atomically $ readTChan ch
979 maybe (return [])
980 (\x -> do
981 xs <- readUntilNothing ch
982 return (x:xs))
983 x
984
985
986streamFeatures :: Text -> [XML.Event]
987streamFeatures "jabber:client" =
988 [ EventBeginElement (streamP "features") []
989 , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-bind}bind" []
990 , EventEndElement "{urn:ietf:params:xml:ns:xmpp-bind}bind"
991
992 {-
993 -- , " <session xmlns='urn:ietf:params:xml:ns:xmpp-session'/>"
994 , " <mechanisms xmlns='urn:ietf:params:xml:ns:xmpp-sasl'>"
995 -- , " <mechanism>DIGEST-MD5</mechanism>"
996 , " <mechanism>PLAIN</mechanism>"
997 , " </mechanisms> "
998 -}
999
1000 , EventEndElement (streamP "features")
1001 ]
1002streamFeatures "jabber:server" =
1003 []
1004
1005
1006greet' :: Text -> Text -> [XML.Event]
1007greet' namespace host = EventBeginDocument : greet'' namespace host
1008
1009greet'' :: Text -> Text -> [Event]
1010greet'' namespace host =
1011 [ EventBeginElement (streamP "stream")
1012 [("from",[ContentText host])
1013 ,("id",[ContentText "someid"])
1014 ,("xmlns",[ContentText namespace])
1015 ,("xmlns:stream",[ContentText "http://etherx.jabber.org/streams"])
1016 ,("version",[ContentText "1.0"])
1017 ]
1018 ] ++ streamFeatures namespace
1019
1020consid :: Maybe Text -> [(Name, [Content])] -> [(Name, [Content])]
1021consid Nothing = id
1022consid (Just sid) = (("id",[ContentText sid]):)
1023
1024
1025data XMPPState
1026 = PingSlot
1027 deriving (Eq,Ord)
1028
1029makePing :: Text -> Maybe Text -> Text -> Text -> [XML.Event]
1030makePing namespace mid to from =
1031 [ EventBeginElement (mkname namespace "iq")
1032 $ (case mid of
1033 Just c -> (("id",[ContentText c]):)
1034 _ -> id )
1035 [ ("type",[ContentText "get"])
1036 , attr "to" to
1037 , attr "from" from
1038 ]
1039 , EventBeginElement "{urn:xmpp:ping}ping" []
1040 , EventEndElement "{urn:xmpp:ping}ping"
1041 , EventEndElement $ mkname namespace "iq"]
1042
1043iq_bind_reply :: Maybe Text -> Text -> [XML.Event]
1044iq_bind_reply mid jid =
1045 [ EventBeginElement "{jabber:client}iq" (consid mid [("type",[ContentText "result"])])
1046 , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-bind}bind"
1047 [("xmlns",[ContentText "urn:ietf:params:xml:ns:xmpp-bind"])]
1048 , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-bind}jid" []
1049 , EventContent (ContentText jid)
1050 , EventEndElement "{urn:ietf:params:xml:ns:xmpp-bind}jid"
1051 , EventEndElement "{urn:ietf:params:xml:ns:xmpp-bind}bind"
1052 , EventEndElement "{jabber:client}iq"
1053
1054 {-
1055 -- query for client version
1056 , EventBeginElement "{jabber:client}iq"
1057 [ attr "to" jid
1058 , attr "from" hostname
1059 , attr "type" "get"
1060 , attr "id" "version"]
1061 , EventBeginElement "{jabber:iq:version}query" []
1062 , EventEndElement "{jabber:iq:version}query"
1063 , EventEndElement "{jabber:client}iq"
1064 -}
1065 ]
1066
1067iq_session_reply :: Maybe Text -> Text -> [XML.Event]
1068iq_session_reply mid host =
1069 -- Note: similar to Pong
1070 [ EventBeginElement "{jabber:client}iq"
1071 (consid mid [("from",[ContentText host])
1072 ,("type",[ContentText "result"])
1073 ])
1074 , EventEndElement "{jabber:client}iq"
1075 ]
1076
1077iq_service_unavailable :: Maybe Text -> Text -> XML.Name -> [XML.Event]
1078iq_service_unavailable mid host {- mjid -} req =
1079 [ EventBeginElement "{jabber:client}iq"
1080 (consid mid [attr "type" "error"
1081 ,attr "from" host])
1082 , EventBeginElement req []
1083 , EventEndElement req
1084 , EventBeginElement "{jabber:client}error"
1085 [ attr "type" "cancel"
1086 , attr "code" "503" ]
1087 , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-stanzas}service-unavailable" []
1088 , EventEndElement "{urn:ietf:params:xml:ns:xmpp-stanzas}service-unavailable"
1089 , EventEndElement "{jabber:client}error"
1090 , EventEndElement "{jabber:client}iq"
1091 ]
1092
1093
1094wrapStanzaList :: [XML.Event] -> STM [Either (StanzaWrap XML.Event) XML.Event]
1095wrapStanzaList xs = do
1096 wrap <- do
1097 clsrs <- newTVar Nothing
1098 donev <- newTMVar ()
1099 return $ \ x ->
1100 Stanza { stanzaType = Unrecognized
1101 , stanzaId = mid
1102 , stanzaTo = mto
1103 , stanzaFrom = mfrom
1104 , stanzaClosers = clsrs
1105 , stanzaInterrupt = donev
1106 , stanzaOrigin = LocalPeer
1107 , stanzaChan = x
1108 }
1109 return $ map (Left . wrap) (take 1 xs) ++ map Right (drop 1 xs)
1110 where
1111 m = listToMaybe xs
1112 mto = m >>= lookupAttrib "to" . tagAttrs
1113 mfrom = m >>= lookupAttrib "from" . tagAttrs
1114 mid = m >>= lookupAttrib "id" . tagAttrs
1115
1116wrapStanzaConduit :: Monad m => StanzaWrap a -> ConduitM Event (Either (StanzaWrap Event) Event) m ()
1117wrapStanzaConduit stanza = do
1118 mfirst <- await
1119 flip (maybe $ return ()) mfirst $ \first -> do
1120 yield . Left $ stanza { stanzaChan = first }
1121 awaitForever $ yield . Right
1122
1123
1124
1125{-
1126greet namespace =
1127 [ EventBeginDocument
1128 , EventBeginElement (streamP "stream")
1129 [ attr "xmlns" namespace
1130 , attr "version" "1.0"
1131 ]
1132 ]
1133-}
1134
1135goodbye :: [XML.Event]
1136goodbye =
1137 [ EventEndElement (streamP "stream")
1138 , EventEndDocument
1139 ]
1140
1141simulateChatError :: StanzaError -> Maybe Text -> [Event]
1142simulateChatError err mfrom =
1143 [ EventBeginElement "{jabber:client}message"
1144 ((maybe id (\t->(attr "from" t:)) mfrom)
1145 [attr "type" "normal" ])
1146 , EventBeginElement "{jabber:client}body" []
1147 , EventContent $ ContentText ("/me " <> errorText err)
1148 , EventEndElement "{jabber:client}body"
1149 , EventBeginElement "{http://jabber.org/protocol/xhtml-im}html" []
1150 , EventBeginElement "{http://www.w3.org/1999/xhtml}body" []
1151 , EventBeginElement "{http://www.w3.org/1999/xhtml}p"
1152 [ attr "style" "font-weight:bold; color:red"
1153 ]
1154 , EventContent $ ContentText ("/me " <> errorText err)
1155 , EventEndElement "{http://www.w3.org/1999/xhtml}p"
1156 , EventEndElement "{http://www.w3.org/1999/xhtml}body"
1157 , EventEndElement "{http://jabber.org/protocol/xhtml-im}html"
1158 , EventEndElement "{jabber:client}message"
1159 ]
1160
1161
1162presenceSolicitation :: Text -> Text -> IO Stanza
1163presenceSolicitation = presenceStanza (PresenceRequestSubscription True) "subscribe"
1164
1165presenceProbe :: Text -> Text -> IO Stanza
1166presenceProbe = presenceStanza PresenceRequestStatus "probe"
1167
1168presenceStanza :: StanzaType -> Text -> Text -> Text -> IO Stanza
1169presenceStanza stanza_type type_attr me jid =
1170 stanzaFromList stanza_type
1171 [ EventBeginElement "{jabber:server}presence"
1172 [ attr "to" jid
1173 , attr "from" me
1174 , attr "type" type_attr
1175 ]
1176 , EventEndElement "{jabber:server}presence" ]
1177
1178forkConnection :: Server ConnectionKey SockAddr
1179 -> XMPPServerParameters
1180 -> ConnectionKey
1181 -> SockAddr
1182 -> FlagCommand
1183 -> Source IO XML.Event
1184 -> Sink (Flush XML.Event) IO ()
1185 -> TChan Stanza
1186 -> IO (TChan Stanza)
1187forkConnection sv xmpp k laddr pingflag src snk stanzas = do
1188 let (namespace,tellmyname) = case k of
1189 ClientKey {} -> ("jabber:client", xmppTellMyNameToClient xmpp)
1190 PeerKey {} -> ("jabber:server",xmppTellMyNameToPeer xmpp laddr)
1191 me <- tellmyname
1192 rdone <- atomically newEmptyTMVar
1193 let isStarter (Left _) = True
1194 isStarter (Right e) | isEventBeginElement e = True
1195 isStarter _ = False
1196 isStopper (Left _) = False
1197 isStopper (Right e) | isEventEndElement e = True
1198 isStopper _ = False
1199 slots <- atomically $ Slotted.new isStarter isStopper
1200 needsFlush <- atomically $ newTVar False
1201 lastStanza <- atomically $ newTVar Nothing
1202 nesting <- atomically $ newTVar 0
1203 let _ = slots :: Slotted.UpdateStream XMPPState (Either (StanzaWrap XML.Event) XML.Event)
1204 let greet_src = do
1205 CL.sourceList (greet' namespace me) =$= CL.map Chunk
1206 yield Flush
1207 slot_src = do
1208 what <- lift . atomically $ foldr1 orElse
1209 [Slotted.pull slots >>= \x -> do
1210 x <- case x of
1211 Left wrapped -> do
1212 writeTVar nesting 1
1213 writeTVar lastStanza (Just wrapped)
1214 return $ stanzaChan wrapped
1215 Right x -> do
1216 when (isEventBeginElement x)
1217 $ modifyTVar' nesting (+1)
1218 when (isEventEndElement x) $ do
1219 n <- readTVar nesting
1220 when (n==1) $ writeTVar lastStanza Nothing
1221 modifyTVar' nesting (subtract 1)
1222 return x
1223 writeTVar needsFlush True
1224 return $ do
1225 -- liftIO $ wlog $ "yielding Chunk: " ++ show x
1226 yield (Chunk x)
1227 slot_src
1228 ,do Slotted.isEmpty slots >>= check
1229 readTVar needsFlush >>= check
1230 writeTVar needsFlush False
1231 return $ do
1232 -- liftIO $ wlog "yielding Flush"
1233 yield Flush
1234 slot_src
1235 ,readTMVar rdone >> return (return ())
1236 ]
1237 what
1238 forkIO $ do (greet_src >> slot_src) $$ snk
1239 last <- atomically $ readTVar lastStanza
1240 es <- while (atomically . fmap not $ Slotted.isEmpty slots)
1241 (atomically . Slotted.pull $ slots)
1242 let es' = mapMaybe metadata es
1243 metadata (Left s) = Just s
1244 metadata _ = Nothing
1245 -- TODO: Issuing RecipientUnavailable for all errors is a presence leak
1246 -- and protocol violation
1247 -- TODO: IDMangler can be used for better targetted error delivery.
1248 let fail stanza = do
1249 wlog $ "failed delivery: " ++ show (stanzaId stanza)
1250 quitVar <- atomically newEmptyTMVar
1251 reply <- makeErrorStanza stanza
1252 tag <- stanzaFirstTag stanza
1253 -- sendReply quitVar (Error RecipientUnavailable tag) reply replyto
1254 replystanza <- stanzaFromList (Error RecipientUnavailable tag) reply
1255 xmppDeliverMessage xmpp (wlog $ "discarded error delivery fail") replystanza
1256 notError s = case stanzaType s of
1257 Error {} -> False
1258 _ -> True
1259 -- TODO: Probably some stanzas should be queued or saved for re-connect.
1260 mapM_ fail $ filter notError (maybeToList last ++ es')
1261 wlog $ "end post-queue fork: " ++ show k
1262 output <- atomically newTChan
1263 hacks <- atomically $ newTVar Map.empty
1264 msgids <- atomically $ newTVar []
1265 forkIO $ do
1266 -- mapM_ (atomically . Slotted.push slots Nothing) greetPeer
1267 verbosity <- xmppVerbosity xmpp
1268 fix $ \loop -> do
1269 what <- atomically $ foldr1 orElse
1270 [readTChan output >>= \stanza -> return $ do
1271 let notping f
1272 | (verbosity==1) = case stanzaType stanza of Pong -> return ()
1273 _ -> f
1274 | (verbosity>=2) = f
1275 | otherwise = return ()
1276 -- isempty <- atomically $ isEmptyTChan (stanzaChan stanza)
1277 -- kwlog $ "queuing: "++show (isempty, stanzaId stanza)
1278 notping $ do
1279 dup <- cloneStanza stanza
1280 let typ = Strict8.pack $ c ++ "<-"++(concat . take 1 . words $ show (stanzaType dup))++" "
1281 c = case k of
1282 ClientKey {} -> "C"
1283 PeerKey {} -> "P"
1284 wlog ""
1285 stanzaToConduit dup $$ prettyPrint typ
1286 -- wlog $ "hacks: "++show (stanzaId stanza)
1287 case stanzaType stanza of
1288 InternalEnableHack hack -> do
1289 -- wlog $ "enable hack: " ++ show hack
1290 atomically $ modifyTVar' hacks (Map.insert hack ())
1291 InternalCacheId x -> do
1292 -- wlog $ "cache id thread: " ++ show x
1293 atomically $ modifyTVar' msgids (take 3 . (x:))
1294 _ -> return ()
1295 stanzaToConduit stanza =$= wrapStanzaConduit stanza
1296 $$ awaitForever
1297 -- TODO: PresenceStatus stanzas should be pushed to appropriate slots
1298 $ liftIO . atomically . Slotted.push slots Nothing
1299 case stanzaType stanza of
1300 Error err tag | tagName tag=="{jabber:client}message" -> do
1301 wlog $ "handling Error hacks"
1302 b <- atomically $ do m <- readTVar hacks
1303 cached <- readTVar msgids
1304 flip (maybe $ return False) (stanzaId stanza) $ \id' -> do
1305 return $ Map.member SimulatedChatErrors m
1306 && elem id' cached
1307 ids <- atomically $ readTVar msgids
1308 wlog $ "ids = " ++ show (b,stanzaId stanza, ids)
1309 when b $ do
1310 let sim = simulateChatError err (stanzaFrom stanza)
1311 wlog $ "sending simulated chat for error message."
1312 CL.sourceList sim =$= wrapStanzaConduit stanza -- not quite right, but whatever
1313 $$ awaitForever
1314 $ liftIO . atomically . Slotted.push slots Nothing
1315 Error e _ -> do
1316 wlog $ "no hacks for error: " ++ show e
1317 _ -> return ()
1318 loop
1319 ,do pingflag >>= check
1320 return $ do
1321 to <- xmppTellPeerHisName xmpp k -- addrToText (callBackAddress k)
1322 let from = me -- Look it up from Server object
1323 -- or pass it with Connection event.
1324 mid = Just "ping"
1325 ping0 = makePing namespace mid to from
1326 ping <- atomically $ wrapStanzaList ping0
1327 mapM_ (atomically . Slotted.push slots (Just $ PingSlot))
1328 ping
1329#ifdef PINGNOISE
1330 wlog ""
1331 CL.sourceList ping0 $$ prettyPrint $ case k of
1332 ClientKey {} -> "C<-Ping"
1333 PeerKey {} -> "P<-Ping "
1334#endif
1335 loop
1336 ,readTMVar rdone >> return (return ())
1337 ]
1338 what
1339 wlog $ "end pre-queue fork: " ++ show k
1340 forkIO $ do
1341 -- src $$ awaitForever (lift . putStrLn . takeWhile (/=' ') . show)
1342 src $$ xmppInbound sv xmpp k laddr pingflag stanzas output rdone
1343 atomically $ putTMVar rdone ()
1344 wlog $ "end reader fork: " ++ show k
1345 return output
1346
1347{-
1348data Peer = Peer
1349 { peerWanted :: TVar Bool -- ^ False when this peer is on a you-call-me basis
1350 , peerState :: TVar PeerState
1351 }
1352data PeerState
1353 = PeerPendingConnect UTCTime
1354 | PeerPendingAccept UTCTime
1355 | PeerConnected (TChan Stanza)
1356-}
1357
1358peerKey :: (Socket,SockAddr) -> IO (ConnectionKey,SockAddr)
1359peerKey (sock,addr) = do
1360 peer <-
1361 sIsConnected sock >>= \c ->
1362 if c then getPeerName sock -- addr is normally socketName
1363 else return addr -- Weird hack: addr is would-be peer name
1364 laddr <- getSocketName sock
1365 return $ (PeerKey (peer `withPort` fromIntegral peerport),laddr)
1366
1367clientKey :: (Socket,SockAddr) -> IO (ConnectionKey,SockAddr)
1368clientKey (sock,addr) = do
1369 paddr <- getPeerName sock
1370 return $ (ClientKey addr,paddr)
1371
1372xmlifyRosterItems :: Monad m => Set Text -> Text -> Set Text -> ConduitM i Event m ()
1373xmlifyRosterItems solicited stype set = mapM_ item (Set.toList set)
1374 where
1375 item jid = do yield $ EventBeginElement "{jabber:iq:roster}item"
1376 ([ attr "jid" jid
1377 , attr "subscription" stype
1378 ]++if Set.member jid solicited
1379 then [attr "ask" "subscribe"]
1380 else [] )
1381 yield $ EventEndElement "{jabber:iq:roster}item"
1382
1383sendRoster ::
1384 StanzaWrap a
1385 -> XMPPServerParameters
1386 -> TChan Stanza
1387 -> IO ()
1388sendRoster query xmpp replyto = do
1389 let k = case stanzaOrigin query of
1390 NetworkOrigin k _ -> Just k
1391 LocalPeer -> Nothing -- local peer requested roster?
1392 flip (maybe $ return ()) k $ \k -> do
1393 hostname <- xmppTellMyNameToClient xmpp
1394 let getlist f = do
1395 bs <- f xmpp k
1396 return (Set.fromList bs) -- js)
1397 buddies <- getlist xmppRosterBuddies
1398 subscribers <- getlist xmppRosterSubscribers
1399 solicited <- getlist xmppRosterSolicited
1400 subnone0 <- getlist xmppRosterOthers
1401 jid <- case k of
1402 ClientKey {} -> xmppTellClientHisName xmpp k -- LookupClientJID xmpp k
1403 PeerKey {} -> xmppTellClientNameOfPeer xmpp k (Set.toList buddies)
1404 let subnone = Set.union solicited subnone0 \\ Set.union buddies subscribers
1405 let subto = buddies \\ subscribers
1406 let subfrom = subscribers \\ buddies
1407 let subboth = Set.intersection buddies subscribers
1408 let roster = do
1409 yield $ EventBeginElement "{jabber:client}iq"
1410 (consid (stanzaId query)
1411 [ attr "to" jid
1412 , attr "type" "result" ])
1413 yield $ EventBeginElement "{jabber:iq:roster}query" [] -- todo: ver?
1414 xmlifyRosterItems solicited "to" subto
1415 xmlifyRosterItems solicited "from" subfrom
1416 xmlifyRosterItems solicited "both" subboth
1417 xmlifyRosterItems solicited "none" subnone
1418 yield $ EventEndElement "{jabber:iq:roster}query"
1419 yield $ EventEndElement "{jabber:client}iq"
1420
1421 conduitToStanza Roster
1422 (stanzaId query)
1423 Nothing
1424 (Just jid)
1425 roster >>= ioWriteChan replyto
1426 {-
1427 let debugpresence =
1428 [ EventBeginElement "{jabber:client}presence"
1429 [ attr "from" "guest@oxio4inifatsetlx.onion"
1430 , attr "to" jid]
1431 , EventEndElement "{jabber:client}presence"
1432 ]
1433 quitvar <- atomically newEmptyTMVar
1434 sendReply quitvar Unrecognized debugpresence replyto
1435 -}
1436
1437
1438socketFromKey :: Server ConnectionKey SockAddr -> ConnectionKey -> IO SockAddr
1439socketFromKey sv k = do
1440 map <- atomically $ readTVar (conmap sv)
1441 let mcd = Map.lookup k map
1442 case mcd of
1443 Nothing -> case k of
1444 ClientKey addr -> return addr
1445 PeerKey addr -> return addr
1446 -- XXX: ? wrong address
1447 -- Shouldnt happen anyway.
1448 Just cd -> return $ cdata cd
1449
1450class StanzaFirstTag a where
1451 stanzaFirstTag :: StanzaWrap a -> IO XML.Event
1452instance StanzaFirstTag (TChan XML.Event) where
1453 stanzaFirstTag stanza = do
1454 e <-atomically $ peekTChan (stanzaChan stanza)
1455 return e
1456instance StanzaFirstTag (LockedChan XML.Event) where
1457 stanzaFirstTag stanza = do
1458 e <-atomically $ peekLChan (stanzaChan stanza)
1459 return e
1460instance StanzaFirstTag XML.Event where
1461 stanzaFirstTag stanza = return (stanzaChan stanza)
1462
1463data StanzaError
1464 = BadRequest
1465 | Conflict
1466 | FeatureNotImplemented
1467 | Forbidden
1468 | Gone
1469 | InternalServerError
1470 | ItemNotFound
1471 | JidMalformed
1472 | NotAcceptable
1473 | NotAllowed
1474 | NotAuthorized
1475 | PaymentRequired
1476 | RecipientUnavailable
1477 | Redirect
1478 | RegistrationRequired
1479 | RemoteServerNotFound
1480 | RemoteServerTimeout
1481 | ResourceConstraint
1482 | ServiceUnavailable
1483 | SubscriptionRequired
1484 | UndefinedCondition
1485 | UnexpectedRequest
1486 deriving (Show,Enum,Ord,Eq)
1487
1488xep0086 ::
1489 forall t t1. (Num t1, IsString t) => StanzaError -> (t, t1)
1490xep0086 e =
1491 case e of
1492 BadRequest -> ("modify", 400)
1493 Conflict -> ("cancel", 409)
1494 FeatureNotImplemented -> ("cancel", 501)
1495 Forbidden -> ("auth", 403)
1496 Gone -> ("modify", 302)
1497 InternalServerError -> ("wait", 500)
1498 ItemNotFound -> ("cancel", 404)
1499 JidMalformed -> ("modify", 400)
1500 NotAcceptable -> ("modify", 406)
1501 NotAllowed -> ("cancel", 405)
1502 NotAuthorized -> ("auth", 401)
1503 PaymentRequired -> ("auth", 402)
1504 RecipientUnavailable -> ("wait", 404)
1505 Redirect -> ("modify", 302)
1506 RegistrationRequired -> ("auth", 407)
1507 RemoteServerNotFound -> ("cancel", 404)
1508 RemoteServerTimeout -> ("wait", 504)
1509 ResourceConstraint -> ("wait", 500)
1510 ServiceUnavailable -> ("cancel", 503)
1511 SubscriptionRequired -> ("auth", 407)
1512 UndefinedCondition -> ("", 500)
1513 UnexpectedRequest -> ("wait", 400)
1514
1515errorText :: StanzaError -> Text
1516errorText e =
1517 case e of
1518 BadRequest -> "Bad request"
1519 Conflict -> "Conflict"
1520 FeatureNotImplemented -> "This feature is not implemented"
1521 Forbidden -> "Forbidden"
1522 Gone -> "Recipient can no longer be contacted"
1523 InternalServerError -> "Internal server error"
1524 ItemNotFound -> "Item not found"
1525 JidMalformed -> "JID Malformed"
1526 NotAcceptable -> "Message was rejected"
1527 NotAllowed -> "Not allowed"
1528 NotAuthorized -> "Not authorized"
1529 PaymentRequired -> "Payment is required"
1530 RecipientUnavailable -> "Recipient is unavailable"
1531 Redirect -> "Redirect"
1532 RegistrationRequired -> "Registration required"
1533 RemoteServerNotFound -> "Recipient's server not found"
1534 RemoteServerTimeout -> "Remote server timeout"
1535 ResourceConstraint -> "The server is low on resources"
1536 ServiceUnavailable -> "The service is unavailable"
1537 SubscriptionRequired -> "A subscription is required"
1538 UndefinedCondition -> "Undefined condition"
1539 UnexpectedRequest -> "Unexpected request"
1540
1541eventContent :: Maybe [Content] -> Text
1542eventContent cs = maybe "" (foldr1 (<>) . map content1) cs
1543 where content1 (ContentText t) = t
1544 content1 (ContentEntity t) = t
1545
1546errorTagLocalName :: forall a. Show a => a -> Text
1547errorTagLocalName e = Text.pack . drop 1 $ do
1548 c <- show e
1549 if 'A' <= c && c <= 'Z'
1550 then [ '-', chr( ord c - ord 'A' + ord 'a') ]
1551 else return c
1552
1553makeErrorStanza :: StanzaFirstTag a => StanzaWrap a -> IO [XML.Event]
1554makeErrorStanza stanza = do
1555 startTag <- stanzaFirstTag stanza
1556 let n = tagName startTag
1557 endTag = EventEndElement n
1558 amap0 = Map.fromList (tagAttrs startTag)
1559 mto = Map.lookup "to" amap0
1560 mfrom = Map.lookup "from" amap0
1561 mtype = Map.lookup "type" amap0
1562 mid = Map.lookup "id" amap0
1563 amap1 = Map.alter (const mto) "from" amap0
1564 -- amap2 = Map.alter (const $ Just $ [ContentText "blackbird"]) {-mfrom)-} "to" amap1
1565 amap2 = Map.alter (const mfrom) "to" amap1
1566 amap3 = Map.insert "type" [XML.ContentText "error"] amap2
1567 startTag' = EventBeginElement
1568 (tagName startTag)
1569 (Map.toList amap3)
1570 -- err = Gone -- FeatureNotImplemented -- UndefinedCondition -- RecipientUnavailable
1571 err = RecipientUnavailable
1572 errname = n { nameLocalName = "error" }
1573 -- errattrs = [attr "type" "wait"] -- "modify"]
1574 errorAttribs e xs = ys ++ xs -- todo replace instead of append
1575 where (typ,code) = xep0086 e
1576 ys = [attr "type" typ, attr "code" (Text.pack . show $ code)]
1577 errorTagName = Name { nameNamespace = Just "urn:ietf:params:xml:ns:xmpp-stanzas"
1578 , nameLocalName = errorTagLocalName err
1579 , namePrefix = Nothing }
1580 errattrs = errorAttribs err []
1581 let wlogd v s = do
1582 wlog $ "error "++show (lookupAttrib "id" $ tagAttrs startTag)++" " ++ v ++ " = " ++ show s
1583 {-
1584 wlogd "amap0" amap0
1585 wlogd "mto" mto
1586 wlogd "mfrom" mfrom
1587 wlogd "amap3" amap3
1588 -}
1589 if eventContent mtype=="error" then return [] else do
1590 return [ startTag'
1591 , EventBeginElement errname errattrs
1592 , EventBeginElement errorTagName []
1593 , EventEndElement errorTagName
1594 , EventEndElement errname
1595 {-
1596 , EventBeginElement "{jabber:client}body" []
1597 , EventContent (ContentText "what?")
1598 , EventEndElement "{jabber:client}body"
1599 -}
1600 {-
1601 , EventBeginElement "{154ae29f-98f2-4af4-826d-a40c8a188574}dummy" []
1602 , EventEndElement "{154ae29f-98f2-4af4-826d-a40c8a188574}dummy"
1603 -}
1604 , endTag
1605 ]
1606
1607monitor ::
1608 Server ConnectionKey SockAddr
1609 -> ConnectionParameters ConnectionKey SockAddr
1610 -> XMPPServerParameters
1611 -> IO b
1612monitor sv params xmpp = do
1613 chan <- return $ serverEvent sv
1614 stanzas <- atomically newTChan
1615 quitVar <- atomically newEmptyTMVar
1616 fix $ \loop -> do
1617 action <- atomically $ foldr1 orElse
1618 [ readTChan chan >>= \((k,u),e) -> return $ do
1619 case e of
1620 Connection pingflag conread conwrite -> do
1621 wlog $ tomsg k "Connection"
1622 let (xsrc,xsnk) = xmlStream conread conwrite
1623 outs <- forkConnection sv xmpp k u pingflag xsrc xsnk stanzas
1624 xmppNewConnection xmpp k u outs
1625 return ()
1626 ConnectFailure addr -> return () -- wlog $ tomsg k "ConnectFailure"
1627 EOF -> do wlog $ tomsg k "EOF"
1628 xmppEOF xmpp k
1629 HalfConnection In -> do
1630 wlog $ tomsg k "ReadOnly"
1631 control sv (Connect (callBackAddress k) params)
1632 HalfConnection Out -> wlog $ tomsg k "WriteOnly"
1633 RequiresPing -> return () -- wlog $ tomsg k "RequiresPing"
1634 _ -> return ()
1635 , readTChan stanzas >>= \stanza -> return $ do
1636 {-
1637 dup <- case stanzaType stanza of
1638 -- Must dup anything that is going to be delivered...
1639 Message {} -> do
1640 dup <- cloneStanza stanza -- dupped so we can make debug print
1641 return dup
1642 Error {} -> do
1643 dup <- cloneStanza stanza -- dupped so we can make debug print
1644 return dup
1645 _ -> return stanza
1646 -}
1647 dup <- cloneStanza stanza
1648
1649 forkIO $ do
1650 case stanzaOrigin stanza of
1651 NetworkOrigin k@(ClientKey {}) replyto ->
1652 case stanzaType stanza of
1653 RequestResource wanted -> do
1654 sockaddr <- socketFromKey sv k
1655 rsc <- xmppChooseResourceName xmpp k sockaddr wanted
1656 let reply = iq_bind_reply (stanzaId stanza) rsc
1657 -- sendReply quitVar SetResource reply replyto
1658 hostname <- xmppTellMyNameToClient xmpp
1659 let requestVersion :: Producer IO XML.Event
1660 requestVersion = do
1661 yield $ EventBeginElement "{jabber:client}iq"
1662 [ attr "to" rsc
1663 , attr "from" hostname
1664 , attr "type" "get"
1665 , attr "id" "version"]
1666 yield $ EventBeginElement "{jabber:iq:version}query" []
1667 yield $ EventEndElement "{jabber:iq:version}query"
1668 yield $ EventEndElement "{jabber:client}iq"
1669 {-
1670 -- XXX Debug chat:
1671 yield $ EventBeginElement "{jabber:client}message"
1672 [ attr "from" $ eventContent (Just [ContentText rsc])
1673 , attr "type" "normal" ] -- "blackbird" ]
1674 yield $ EventBeginElement "{jabber:client}body" []
1675 yield $ EventContent $ ContentText ("hello?")
1676 yield $ EventEndElement "{jabber:client}body"
1677 yield $ EventEndElement "{jabber:client}message"
1678 -}
1679 sendReply quitVar SetResource reply replyto
1680 conduitToStanza (UnrecognizedQuery "{jabber:iq:version}query")
1681 Nothing -- id
1682 (Just hostname) -- from
1683 (Just rsc) -- to
1684 requestVersion
1685 >>= ioWriteChan replyto
1686 SessionRequest -> do
1687 me <- xmppTellMyNameToClient xmpp
1688 let reply = iq_session_reply (stanzaId stanza) me
1689 sendReply quitVar Pong reply replyto
1690 RequestRoster -> do
1691 sendRoster stanza xmpp replyto
1692 xmppSubscribeToRoster xmpp k
1693 PresenceStatus {} -> do
1694 xmppInformClientPresence xmpp k stanza
1695 PresenceRequestSubscription {} -> do
1696 let fail = return () -- todo
1697 xmppClientSubscriptionRequest xmpp fail k stanza replyto
1698 PresenceInformSubscription {} -> do
1699 let fail = return () -- todo
1700 xmppClientInformSubscription xmpp fail k stanza
1701 NotifyClientVersion name version -> do
1702 enableClientHacks name version replyto
1703 UnrecognizedQuery query -> do
1704 me <- xmppTellMyNameToClient xmpp
1705 let reply = iq_service_unavailable (stanzaId stanza) me query
1706 sendReply quitVar (Error ServiceUnavailable (head reply)) reply replyto
1707 Message {} -> do
1708 -- wlog $ "LANGMAP "++show (stanzaId stanza, msgLangMap (stanzaType stanza))
1709 maybe (return ()) (flip cacheMessageId replyto) $ do
1710 guard . not . null . mapMaybe (msgBody . snd) $ msgLangMap (stanzaType stanza)
1711 stanzaId stanza
1712 _ -> return ()
1713 NetworkOrigin k@(PeerKey {}) replyto ->
1714 case stanzaType stanza of
1715 PresenceRequestStatus {} -> do
1716 xmppAnswerProbe xmpp k stanza replyto
1717 PresenceStatus {} -> do
1718 xmppInformPeerPresence xmpp k stanza
1719 PresenceRequestSubscription {} -> do
1720 let fail = return () -- todo
1721 xmppPeerSubscriptionRequest xmpp fail k stanza replyto
1722 PresenceInformSubscription {} -> do
1723 let fail = return () -- todo
1724 xmppPeerInformSubscription xmpp fail k stanza
1725 _ -> return ()
1726 _ -> return ()
1727 let deliver replyto = do
1728 -- TODO: Issuing RecipientUnavailable for all errors is a presence leak
1729 -- and protocol violation
1730 let fail = do
1731 wlog $ "Failed delivery id="++show (stanzaId stanza) -- TODO
1732 reply <- makeErrorStanza stanza
1733 tag <- stanzaFirstTag stanza
1734 sendReply quitVar (Error RecipientUnavailable tag) reply replyto
1735 xmppDeliverMessage xmpp fail stanza
1736 -- -- bad idea:
1737 -- let newStream = greet'' "jabber:client" "blackbird"
1738 -- sendReply quitVar Error newStream replyto
1739 case stanzaType stanza of
1740 Message {} -> do
1741 case stanzaOrigin stanza of
1742 LocalPeer {} -> return ()
1743 NetworkOrigin _ replyto -> deliver replyto
1744 Error {} -> do
1745 case stanzaOrigin stanza of
1746 LocalPeer {} -> return ()
1747 NetworkOrigin k replyto -> do
1748 -- wlog $ "delivering error: " ++show (stanzaId stanza)
1749 -- wlog $ " from: " ++ show k
1750 deliver replyto
1751 _ -> return ()
1752 -- We need to clone in the case the stanza is passed on as for Message.
1753 verbosity <- xmppVerbosity xmpp
1754 let notping f | (verbosity==1) = case stanzaType stanza of Pong -> return ()
1755 _ -> f
1756 | (verbosity>=2) = f
1757 | otherwise = return ()
1758 notping $ do
1759 let typ = Strict8.pack $ c ++ "->"++(concat . take 1 . words $ show (stanzaType stanza))++" "
1760 c = case stanzaOrigin stanza of
1761 LocalPeer -> "*"
1762 NetworkOrigin (ClientKey {}) _ -> "C"
1763 NetworkOrigin (PeerKey {}) _ -> "P"
1764 wlog ""
1765 stanzaToConduit dup $$ prettyPrint typ
1766
1767 ]
1768 action
1769 loop
1770 where
1771 tomsg k str = printf "%12s %s" str (show k)
1772 where
1773 _ = str :: String
1774
1775data XMPPServer
1776 = XMPPServer { _xmpp_sv :: Server ConnectionKey SockAddr
1777 , _xmpp_peer_params :: ConnectionParameters ConnectionKey SockAddr
1778 }
1779
1780addPeer :: XMPPServer -> SockAddr -> IO ()
1781addPeer sv addr = do
1782 control (_xmpp_sv sv) (ConnectWithEndlessRetry addr (_xmpp_peer_params sv) 10000)
1783
1784xmppServer :: ( MonadResource m
1785 , MonadIO m
1786 ) => XMPPServerParameters -> m XMPPServer
1787xmppServer xmpp = do
1788 sv <- server
1789 -- some fuzz helps avoid simultaneity
1790 pingfuzz <- liftIO $ do
1791 gen <- System.Random.getStdGen
1792 let (r,gen') = System.Random.next gen
1793 return $ r `mod` 2000 -- maximum 2 seconds of fuzz
1794 liftIO . wlog $ "pingfuzz = " ++ show pingfuzz
1795 let peer_params = (connectionDefaults peerKey)
1796 { pingInterval = 15000 + pingfuzz
1797 , timeout = 2000
1798 , duplex = False }
1799 client_params = (connectionDefaults clientKey)
1800 { pingInterval = 0
1801 , timeout = 0
1802 }
1803 liftIO $ do
1804 forkIO $ monitor sv peer_params xmpp
1805 control sv (Listen peerport peer_params)
1806 control sv (Listen clientport client_params)
1807 return XMPPServer { _xmpp_sv = sv, _xmpp_peer_params = peer_params }
1808
1809#if MIN_VERSION_stm(2,4,0)
1810#else
1811-- |Clone a 'TChan': similar to dupTChan, but the cloned channel starts with the
1812-- same content available as the original channel.
1813--
1814-- Terrible inefficient implementation provided to build against older libraries.
1815cloneTChan :: TChan a -> STM (TChan a)
1816cloneTChan chan = do
1817 contents <- chanContents' chan
1818 chan2 <- dupTChan chan
1819 mapM_ (writeTChan chan) contents
1820 return chan2
1821 where
1822 chanContents' chan = do
1823 b <- isEmptyTChan chan
1824 if b then return [] else do
1825 x <- readTChan chan
1826 xs <- chanContents' chan
1827 return (x:xs)
1828#endif
1829
diff --git a/Presence/monitortty.c b/Presence/monitortty.c
new file mode 100644
index 00000000..a9a095cf
--- /dev/null
+++ b/Presence/monitortty.c
@@ -0,0 +1,173 @@
1// monitortty.c
2
3#include <unistd.h>
4#include <pthread.h>
5#include <stdio.h>
6#include <string.h>
7#include <stdint.h>
8#include <errno.h>
9#include <linux/vt.h>
10#include <sys/ioctl.h>
11#include <fcntl.h>
12#include <linux/kd.h>
13#include <stdlib.h>
14
15static char *conspath[] = {
16 "/proc/self/fd/0",
17 "/dev/tty",
18 "/dev/tty0",
19 "/dev/vc/0",
20 "/dev/systty",
21 "/dev/console",
22 NULL
23};
24
25static int
26is_a_console(int fd) {
27 char arg;
28
29 arg = 0;
30 return (isatty (fd)
31 && ioctl(fd, KDGKBTYPE, &arg) == 0
32 && ((arg == KB_101) || (arg == KB_84)));
33}
34
35static int
36open_a_console(const char *fnam) {
37 int fd;
38
39 /*
40 * For ioctl purposes we only need some fd and permissions
41 * do not matter. But setfont:activatemap() does a write.
42 */
43 fd = open(fnam, O_RDWR);
44 if (fd < 0)
45 fd = open(fnam, O_WRONLY);
46 if (fd < 0)
47 fd = open(fnam, O_RDONLY);
48 if (fd < 0)
49 return -1;
50 return fd;
51}
52
53int ttyfd() {
54 // We try several things because opening /dev/console will fail
55 // if someone else used X (which does a chown on /dev/console).
56 int i;
57 int fd;
58 for (i = 0; conspath[i]; i++) {
59 if ((fd = open_a_console(conspath[i])) >= 0) {
60 if (is_a_console(fd)) {
61 printf("using %s\n",conspath[i]);
62 return fd;
63 }
64 close(fd);
65 }
66 }
67 for (fd = 0; fd < 3; fd++)
68 if (is_a_console(fd))
69 return fd;
70 printf("failed to find console fd\n");
71 return -1;
72}
73
74void vt_wait(int tty_fd) {
75 struct vt_event vt;
76 memset(&vt,'\0',sizeof(vt));
77 vt.event = VT_EVENT_SWITCH;
78 int res;
79 // printf("started wait\n");
80 res = ioctl (tty_fd, VT_WAITEVENT, &vt);
81 if (res==-1) {
82 printf("vt_wait error fd=%i\n",tty_fd);
83 perror("vt_wait");
84 // printf("vt_wait: %u - %s\n", errno, errmsg(errno));
85 sleep(1);
86 }
87 // printf("finished wait\n");
88}
89
90int8_t get_active(int tty_fd) {
91 struct vt_stat vtstat;
92 memset(&vtstat,'\0',sizeof(vtstat));
93 if (ioctl(tty_fd, VT_GETSTATE, &vtstat)) {
94 perror ("get_active: VT_GETSTATE");
95 return 7;
96 }
97 return vtstat.v_active;
98}
99
100void chvt(int tty_fd, int n) {
101 if (ioctl(tty_fd, VT_ACTIVATE, n)) {
102 perror ("chvt: VT_ACTIVATE");
103 }
104
105}
106
107pthread_mutex_t mu;
108pthread_t mt;
109int tty = -1;
110
111void *write_vtch(void *pfd) {
112 int fd = (int)(intptr_t)pfd;
113 printf("started VT_WAITEVENT loop fd=%i\n",fd);
114 pthread_mutex_lock(&mu);
115 tty = ttyfd();
116 pthread_mutex_unlock(&mu);
117 int8_t active_tty = get_active(tty);
118 int8_t reported_tty;
119 ssize_t e;
120
121 pthread_setcancelstate(PTHREAD_CANCEL_ENABLE, NULL);
122 for (;;) {
123 // ssize_t write(int fd, const void *buf, size_t count);
124 e = write(fd, &active_tty, 1);
125 if (e<0 ) {
126 if( errno==EAGAIN) continue;
127 break;
128 }
129 else if(e==1) {
130 reported_tty = active_tty;
131 }
132 do {
133 vt_wait(tty);
134 // printf("vt_wait() finished. tty=%d fd=%d\n",tty,fd);
135 active_tty = get_active(tty);
136 } while (active_tty==reported_tty);
137 }
138
139 // TODO:
140 // use VT_GETSTATE
141 // use VT_WAITEVENT
142 printf("stopped VT_WAITEVENT loop\n");
143 tty = -1;
144 pthread_mutex_destroy(&mu);
145 return NULL;
146}
147
148
149void monitorTTY(int fd) {
150 pthread_mutex_init(&mu,NULL);
151 // printf ("Hello world.\n");
152 pthread_create (&mt, NULL, write_vtch, (void*)(intptr_t)fd);
153}
154
155void closeTTY() {
156 int fd = -1;
157 int active = 7;
158 pthread_mutex_lock(&mu);
159 active = get_active(tty);
160 fd = tty;
161 pthread_mutex_unlock(&mu);
162#ifndef VTHACK
163 pthread_cancel(mt);
164#endif
165 char cmd[40]; cmd[39] = '\0';
166 // Hack to wake up from VT_WAITEVENT ioctl
167#ifdef VTHACK
168 snprintf(cmd,39,"chvt %i;chvt %i",active+1,active);
169 system(cmd);
170 pthread_join(mt,NULL);
171#endif
172 close(fd);
173}
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 19:09:54 +0000