summaryrefslogtreecommitdiff
path: root/Presence
diff options
context:
space:
mode:
Diffstat (limited to 'Presence')
-rw-r--r--Presence/ByteStringOperators.hs59
-rw-r--r--Presence/Chat.hs227
-rw-r--r--Presence/ClientState.hs41
-rw-r--r--Presence/ConfigFiles.hs170
-rw-r--r--Presence/ConnectionKey.hs8
-rw-r--r--Presence/ConsoleWriter.hs420
-rw-r--r--Presence/Control/Concurrent/STM/Util.hs21
-rw-r--r--Presence/ControlMaybe.hs64
-rw-r--r--Presence/DNSCache.hs291
-rw-r--r--Presence/EventUtil.hs83
-rw-r--r--Presence/FGConsole.hs67
-rw-r--r--Presence/GetHostByAddr.hs77
-rw-r--r--Presence/IDMangler.hs68
-rw-r--r--Presence/LocalChat.hs71
-rw-r--r--Presence/LocalPeerCred.hs234
-rw-r--r--Presence/LockedChan.hs78
-rw-r--r--Presence/Logging.hs25
-rw-r--r--Presence/MUC.hs61
-rw-r--r--Presence/Nesting.hs86
-rw-r--r--Presence/Paths.hs62
-rw-r--r--Presence/PeerResolve.hs27
-rw-r--r--Presence/Presence.hs1428
-rw-r--r--Presence/SockAddr.hs14
-rw-r--r--Presence/Stanza/Build.hs155
-rw-r--r--Presence/Stanza/Parse.hs277
-rw-r--r--Presence/Stanza/Types.hs257
-rw-r--r--Presence/UTmp.hs259
-rw-r--r--Presence/Util.hs57
-rw-r--r--Presence/XMPPServer.hs1812
-rw-r--r--Presence/monitortty.c182
30 files changed, 0 insertions, 6681 deletions
diff --git a/Presence/ByteStringOperators.hs b/Presence/ByteStringOperators.hs
deleted file mode 100644
index e8485134..00000000
--- a/Presence/ByteStringOperators.hs
+++ /dev/null
@@ -1,59 +0,0 @@
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#if MIN_VERSION_bytestring(0,10,0)
9#else
10-- These two were imported to provide an NFData instance.
11import qualified Data.ByteString.Lazy.Internal as L (ByteString(..))
12import Control.DeepSeq
13#endif
14
15
16(<++>) :: ByteString -> ByteString -> ByteString
17(<++.>) :: ByteString -> S.ByteString -> ByteString
18(<.++>) :: S.ByteString -> ByteString -> ByteString
19(<.++.>) :: S.ByteString -> S.ByteString -> ByteString
20a <++> b = L.append a b
21a <++.> b = L.append a (fromChunks [b])
22a <.++> b = L.append (fromChunks [a]) b
23a <.++.> b = fromChunks [a,b]
24infixr 5 <.++.>
25infixr 5 <.++>
26infixr 5 <++>
27infixr 5 <++.>
28
29
30(<++$>) :: Functor f => ByteString -> f ByteString -> f ByteString
31(<$++>) :: Functor f => f ByteString -> ByteString -> f ByteString
32(<$++$>) :: Applicative f => f ByteString -> f ByteString -> f ByteString
33a <++$> b = fmap (a<++>) b
34a <$++> b = fmap (<++>b) a
35a <$++$> b = liftA2 (<++>) a b
36infixr 6 <++$>
37infixr 6 <$++>
38infixr 6 <$++$>
39
40(<?++>) :: Maybe ByteString -> ByteString -> ByteString
41Nothing <?++> b = b
42Just a <?++> b = a <++> b
43infixr 5 <?++>
44
45(<++?>) :: ByteString -> Maybe ByteString -> ByteString
46a <++?> Nothing = a
47a <++?> Just b = a <++> b
48infixr 5 <++?>
49
50bshow :: Show a => a -> ByteString
51bshow = L.pack . show
52
53
54#if MIN_VERSION_bytestring(0,10,0)
55#else
56instance NFData L.ByteString where
57 rnf L.Empty = ()
58 rnf (L.Chunk _ b) = rnf b
59#endif
diff --git a/Presence/Chat.hs b/Presence/Chat.hs
deleted file mode 100644
index 03bea44b..00000000
--- a/Presence/Chat.hs
+++ /dev/null
@@ -1,227 +0,0 @@
1{-# LANGUAGE LambdaCase #-}
2module Chat where
3
4import Debug.Trace
5import Data.Semigroup
6import Control.Concurrent.STM
7import Control.Monad
8import qualified Data.Map as Map
9 ;import Data.Map (Map)
10import Data.Text (Text)
11import Data.Word
12
13import Util (stripResource)
14
15-- To join a chat room, add a 'ClientRoomLink' to 'roomDesiredLink' with
16-- 'desireStreamEvent' set to 'Nothing'.
17--
18-- To leave a chat room, remove the 'ClientRoomLink' from the map.
19
20data Room k = Room
21 { roomDesiredTransaction :: TVar (Map k (TVar (Maybe ChatTransaction)))
22 , roomChan :: TChan ChatTransaction
23 , roomFutureSeqNo :: TVar Word64
24 , roomMembers :: TVar (Map Text{-nick-} (PerMember k))
25 , roomAffiliations :: TVar (Map Text{-jid-} Affiliation)
26 , roomReservations :: TVar (Map Text{-nick-} Text{-jid-})
27 }
28
29newtype PerMember k = PerMember
30 { memberKey :: k
31 }
32
33newtype Affiliation = Affiliation
34 { reservedNick :: Text
35 }
36
37data ChatEvent = Join | Part | Action Text | Talk Text -- | NickChange Text
38 deriving (Eq,Ord,Show)
39
40data Membership = Outside | Inside
41 deriving (Eq,Ord,Read,Show)
42
43data MembershipEffect = MembershipEffect { fromMembership :: Membership
44 , toMembership :: Membership
45 }
46 | NoMembershipEffect
47 | InvalidMembershipEffect
48 deriving (Eq,Ord,Read,Show)
49
50instance Semigroup MembershipEffect
51
52instance Monoid MembershipEffect where
53 mempty = NoMembershipEffect
54 MembershipEffect a x `mappend` MembershipEffect y b
55 | x == y = MembershipEffect a b
56 | otherwise = InvalidMembershipEffect
57 NoMembershipEffect `mappend` b = b
58 a `mappend` NoMembershipEffect = a
59 _ `mappend` _ = InvalidMembershipEffect
60
61chatEffect :: ChatEvent -> MembershipEffect
62chatEffect Join = MembershipEffect Outside Inside
63chatEffect Part = MembershipEffect Inside Outside
64chatEffect _ = MembershipEffect Inside Inside
65
66membershipEffect :: [ChatEvent] -> MembershipEffect
67membershipEffect xs = foldMap chatEffect xs
68
69
70data ChatTransaction = ChatTransaction
71 { chatSeqNo :: Word64
72 , chatSenderJID :: Maybe Text
73 , chatSender :: Text
74 , chatMessage :: [ChatEvent]
75 }
76 deriving (Eq,Ord,Show)
77
78newtype RoomHandle = RH (TVar (Maybe ChatTransaction))
79
80data JoinedRoom k = JoinedRoom
81 { joinedRoom :: Room k
82 , joinedNick :: Text
83 , roomHandle :: RoomHandle
84 , roomTransactions :: TChan ChatTransaction
85 }
86
87newRoom :: STM (Room k)
88newRoom = do
89 m <- newTVar Map.empty
90 c <- newTChan -- newBroadcastTChan
91 n <- newTVar 0
92 cs <- newTVar Map.empty
93 as <- newTVar Map.empty
94 rs <- newTVar Map.empty
95 return Room
96 { roomDesiredTransaction = m
97 , roomChan = c
98 , roomFutureSeqNo = n
99 , roomMembers = cs
100 , roomAffiliations = as
101 , roomReservations = rs
102 }
103
104
105--- Client interface
106
107joinRoom :: Ord k => k
108 -> Room k
109 -> Maybe Text
110 -> Text
111 -> STM (JoinedRoom k)
112joinRoom k room jid nick = do
113 no <- readTVar $ roomFutureSeqNo room
114 v <- newTVar (Just $ ChatTransaction no jid nick [Join])
115 modifyTVar' (roomDesiredTransaction room) $ Map.insert k v
116 c <- dupTChan (roomChan room)
117 return $ JoinedRoom room nick (RH v) c
118
119partRoom :: JoinedRoom k -> Maybe Text -> STM ()
120partRoom (JoinedRoom room nick (RH v) c) jid = do
121 writeTVar v Nothing -- Cancel pending chat.
122 sendChat (JoinedRoom room nick (RH v) c) jid [Part]
123 return ()
124
125sendChat :: JoinedRoom k -> Maybe Text -> [ChatEvent] -> STM Bool
126sendChat (JoinedRoom room nick (RH v) _) jid chat = do
127 mpending <- readTVar v
128 no <- readTVar $ roomFutureSeqNo room
129 case mpending of
130 Just (ChatTransaction no' _ _ _) | no' >= no -> return False
131 _ -> do
132 writeTVar v (Just $ ChatTransaction no jid nick chat)
133 return True
134
135-- | Blocks until a transaction occurs. Optionally, a failed transaction will
136-- be automatically renewed.
137readRoom :: Ord k => k -> JoinedRoom k -> STM (Bool, ChatTransaction)
138readRoom k (JoinedRoom room _ (RH v) c) = do
139 mpending <- readTVar v
140 final <- readTChan c
141 case mpending of
142 Just pending -> do
143 if pending == final
144 then do
145 writeTVar v Nothing
146 when (Part `elem` chatMessage final) $ do
147 modifyTVar' (roomDesiredTransaction room)
148 $ Map.delete k
149 return (True,final)
150 else do
151 no <- readTVar $ roomFutureSeqNo room
152 writeTVar v $ Just pending { chatSeqNo = no }
153 return (False,final)
154 Nothing -> return (False,final)
155
156roomOccupants :: Room k-> STM [(Text{-nick-},Maybe Text{-friendly name-})]
157roomOccupants room = do
158 ns <- Map.keys <$> readTVar (roomMembers room)
159 return $ map (\n -> (n,Just n)) ns
160
161roomReservedNick :: Room k -> Text{-JID-} -> STM (Maybe Text{-nick-})
162roomReservedNick room jid = do
163 a <- Map.lookup jid <$> readTVar (roomAffiliations room)
164 return $ reservedNick <$> a
165
166roomFriendlyName :: Room k -> STM (Maybe Text)
167roomFriendlyName _ = return Nothing
168
169-- Room implementation interface
170
171data Validation = Malformed | Requires Membership | Denied | Valid Membership Membership
172 deriving (Eq,Ord,Show,Read)
173
174validateTransaction :: Ord k => Room k -> k -> ChatTransaction -> STM Validation
175validateTransaction room k t@(ChatTransaction no mjid nick xs)
176 | null xs = return Malformed
177 | otherwise = case membershipEffect xs of
178 MembershipEffect Inside what ->
179 Map.lookup nick <$> readTVar (roomMembers room) >>= \case
180 Nothing -> return (Requires Inside)
181 Just p | memberKey p /= k -> return Denied
182 _ -> return (Valid Inside what)
183 MembershipEffect Outside what -> do
184 Map.lookup k <$> return Map.empty {- readTVar (roomDesiredTransaction room) -} >>= \case
185 Nothing -> Map.lookup nick <$> readTVar (roomMembers room) >>= \case
186 Nothing -> Map.lookup nick <$> readTVar (roomReservations room) >>= \case
187 Just rjid | Just jid <- mjid
188 , stripResource jid == rjid
189 -> return (Valid Outside what)
190 Just _ -> return Denied
191 Nothing -> return (Valid Outside what)
192 Just _ -> return Denied -- Nick already taken.
193 Just _ -> return (Requires Outside)
194 _ -> return Malformed
195
196
197roomCommit :: Ord k => Room k -> k -> ChatTransaction -> STM ()
198roomCommit room k t = do
199 let fin = do
200 trace "increment seqno!" $ return ()
201 modifyTVar' (roomFutureSeqNo room) succ
202 writeTChan (roomChan room) t
203 v <- validateTransaction room k t
204 trace ("roomCommit " ++ show v ++ " " ++ show t) $ return ()
205 case v of
206 Valid Outside Inside -> do
207 modifyTVar' (roomMembers room) $ Map.insert (chatSender t) PerMember
208 { memberKey = k
209 }
210 fin
211 Valid Inside Outside -> do
212 modifyTVar' (roomMembers room) $ Map.delete (chatSender t)
213 fin
214 Valid _ _ -> fin
215 bad -> trace ("validateTransaction: " ++ show bad) $ return ()
216
217roomPending :: Ord k => Room k -> STM (Map k ChatTransaction)
218roomPending room = do
219 no <- readTVar $ roomFutureSeqNo room
220 m <- Map.mapMaybe (>>= \t -> do guard (chatSeqNo t == no)
221 return t)
222 <$> do readTVar (roomDesiredTransaction room)
223 >>= mapM readTVar
224 fmap (Map.mapMaybe id)
225 $ sequence $ Map.mapWithKey (\k t -> validateTransaction room k t >>= \case
226 Valid _ _ -> return (Just t)
227 _ -> return Nothing) m
diff --git a/Presence/ClientState.hs b/Presence/ClientState.hs
deleted file mode 100644
index 08cc54ed..00000000
--- a/Presence/ClientState.hs
+++ /dev/null
@@ -1,41 +0,0 @@
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 -- | The unix tty or the jabber resource for this client.
13 { clientResource :: Text
14 -- | Unix user that is running this client.
15 , clientUser :: Text
16 -- | The specific roster/identity of the user that this client presenting.
17 , clientProfile :: Text
18 -- | The unix process id of the client if we know it.
19 , clientPid :: Maybe ProcessID
20 -- | The presence (away/available) stanza this client is indicating.
21 , clientStatus :: TVar (Maybe Stanza)
22 -- | XMPP client flags (read access via 'clientIsAvailable' and 'clientIsInterested')
23 , clientFlags :: TVar Int8
24 }
25
26cf_available :: Int8
27cf_available = 0x1
28cf_interested :: Int8
29cf_interested = 0x2
30
31-- | True if the client has sent an initial presence
32clientIsAvailable :: ClientState -> STM Bool
33clientIsAvailable c = do
34 flgs <- readTVar (clientFlags c)
35 return $ flgs .&. cf_available /= 0
36
37-- | True if the client has requested a roster
38clientIsInterested :: ClientState -> STM Bool
39clientIsInterested c = do
40 flgs <- readTVar (clientFlags c)
41 return $ flgs .&. cf_interested /= 0
diff --git a/Presence/ConfigFiles.hs b/Presence/ConfigFiles.hs
deleted file mode 100644
index d0164e33..00000000
--- a/Presence/ConfigFiles.hs
+++ /dev/null
@@ -1,170 +0,0 @@
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 Data.List (partition)
17import Data.Maybe (catMaybes,isJust)
18
19import DPut
20import DebugTag
21
22type User = ByteString
23type Profile = String
24
25configDir, buddyFile, subscriberFile,
26 otherFile, pendingFile, solicitedFile,
27 secretsFile :: FilePath
28
29-- A "buddy" is somebody who approved our friend request and will keep
30-- us informed of their presence.
31--
32-- A "subscriber" is somebody who we approved and promised to keep informed
33-- of our own presence.
34
35configDir = ".presence"
36buddyFile = "buddies" -- subscription="to"
37subscriberFile = "subscribers" -- subscription="from"
38pendingFile = "pending" -- pending subscriber (we've yet to approve)
39solicitedFile = "solicited" -- pending buddy (we sent a friend request)
40otherFile = "others"
41secretsFile = "secret"
42
43
44configPath :: User -> Profile -> String -> IO String
45configPath user "." filename = do
46 ue <- getUserEntryForName (unpack user)
47 return $ (++("/"++configDir++"/"++filename)) $ homeDirectory ue
48 `catchIOError` \e -> do
49 dput XJabber $ "configPath " ++ show user ++ "\".\": " ++ show e
50 return $ (++("/"++configDir++"/"++filename)) $ "/tmp"
51configPath user profile filename = do
52 ue <- getUserEntryForName (unpack user)
53 return $ (++("/"++configDir++"/"++profile++"/"++filename)) $ homeDirectory ue
54 `catchIOError` \e -> do
55 dput XJabber $ "configPath " ++ show user ++ " " ++ show profile ++ ": " ++ show e
56 return $ (++("/"++configDir++"/"++filename)) $ "/tmp"
57
58createConfigFile :: ByteString -> FilePath -> IO ()
59createConfigFile tag path = do
60 let dir = dropFileName path
61 doesDirectoryExist dir >>= flip unless (do
62 createDirectory dir
63 )
64 withFile path WriteMode $ \h -> do
65 L.hPutStrLn h tag
66
67addItem :: ByteString -> ByteString -> FilePath -> IO ()
68addItem item tag path =
69 let doit = do
70 handle (\e -> when (isDoesNotExistError e)
71 (createConfigFile tag path >> doit))
72 $ do exists <- fileExist path
73 if exists
74 then withFile path AppendMode $ \h ->
75 L.hPutStrLn h item
76 else withFile path WriteMode $ \h -> do
77 L.hPutStrLn h tag
78 L.hPutStrLn h item
79 in doit
80
81
82-- | Modify a presence configuration file. This function will iterate over all
83-- items in the file and invoke a test function. If the function returns
84-- Nothing, that item is removed from the file. Otherwise, the function may
85-- rename the item by returning the new name.
86--
87-- If the last argument is populated, it is a new item to append to the end of
88-- the file.
89--
90-- Note that the entire file is read in, processed, and then rewritten from
91-- scratch.
92modifyFile ::
93 (ByteString,FilePath)
94 -> User
95 -> Profile
96 -> (ByteString -> IO (Maybe ByteString)) -- ^ Returns Just for each item you want to keep.
97 -> Maybe ByteString -- ^ Optionally append this item.
98 -> IO Bool -- Returns True if test function ever returned Nothing
99modifyFile (tag,file) user profile test appending = configPath user profile file >>= doit
100 where
101 doit path = do
102 handle (\e -> if (isDoesNotExistError e)
103 then (createConfigFile tag path >> doit path)
104 else return False)
105 $ do exists <- fileExist path
106 if exists
107 then do
108 xs <- withFile path ReadMode $ \h -> do
109 contents <- L.hGetContents h
110 case L.lines contents of
111 x:xs -> mapM test xs
112 _ -> return []
113 let (keepers,deleted) = partition isJust xs
114 withFile path WriteMode $ \h -> do
115 L.hPutStrLn h tag
116 forM_ (catMaybes keepers) (L.hPutStrLn h)
117 forM_ appending (L.hPutStrLn h)
118 return . not . Prelude.null $ deleted
119 else do
120 withFile path WriteMode $ \h -> do
121 L.hPutStrLn h tag
122 forM_ appending (L.hPutStrLn h)
123 return False
124
125modifySolicited, modifyBuddies, modifyOthers, modifyPending, modifySubscribers
126 :: User -> Profile -> (ByteString -> IO (Maybe ByteString)) -> Maybe ByteString -> IO Bool
127
128modifySolicited = modifyFile ("<? solicited ?>" , solicitedFile)
129modifyBuddies = modifyFile ("<? buddies ?>" , buddyFile)
130modifyOthers = modifyFile ("<? others ?>" , otherFile)
131modifyPending = modifyFile ("<? pending ?>" , pendingFile)
132modifySubscribers = modifyFile ("<? subscribers ?>" , subscriberFile)
133
134addBuddy :: User -> Profile -> ByteString -> IO ()
135addBuddy user profile buddy =
136 configPath user profile buddyFile >>= addItem buddy "<? buddies ?>"
137
138addSubscriber :: User -> Profile -> ByteString -> IO ()
139addSubscriber user profile subscriber =
140 configPath user profile subscriberFile >>= addItem subscriber "<? subscribers ?>"
141
142addSolicited :: User -> Profile -> ByteString -> IO ()
143addSolicited user profile solicited =
144 configPath user profile solicitedFile >>= addItem solicited "<? solicited ?>"
145
146getConfigList :: FilePath -> IO [ByteString]
147getConfigList path =
148 handle (\e -> if isDoesNotExistError e then (return []) else throw e)
149 $ withFile path ReadMode $
150 L.hGetContents
151 >=> return . Prelude.tail . L.lines
152 >=> (\a -> seq (rnf a) (return a))
153
154getBuddies :: User -> Profile -> IO [ByteString]
155getBuddies user profile = configPath user profile buddyFile >>= getConfigList
156
157getSubscribers :: User -> Profile -> IO [ByteString]
158getSubscribers user profile = configPath user profile subscriberFile >>= getConfigList
159
160getOthers :: User -> Profile -> IO [ByteString]
161getOthers user profile = configPath user profile otherFile >>= getConfigList
162
163getPending :: User -> Profile -> IO [ByteString]
164getPending user profile = configPath user profile pendingFile >>= getConfigList
165
166getSolicited :: User -> Profile -> IO [ByteString]
167getSolicited user profile = configPath user profile solicitedFile >>= getConfigList
168
169getSecrets :: User -> Profile -> IO [ByteString]
170getSecrets user profile = configPath user profile secretsFile >>= getConfigList
diff --git a/Presence/ConnectionKey.hs b/Presence/ConnectionKey.hs
deleted file mode 100644
index ad4eeab7..00000000
--- a/Presence/ConnectionKey.hs
+++ /dev/null
@@ -1,8 +0,0 @@
1module ConnectionKey where
2
3import Network.Socket ( SockAddr(..) )
4import SockAddr ()
5
6newtype ClientAddress = ClientAddress SockAddr
7 deriving (Eq,Ord,Show)
8
diff --git a/Presence/ConsoleWriter.hs b/Presence/ConsoleWriter.hs
deleted file mode 100644
index c6e1871a..00000000
--- a/Presence/ConsoleWriter.hs
+++ /dev/null
@@ -1,420 +0,0 @@
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.Exit ( ExitCode(ExitSuccess) )
21import System.Posix.Env ( setEnv )
22import System.Posix.Process ( forkProcess, exitImmediately, executeFile )
23import System.Posix.User ( setUserID, getUserEntryForName, userID )
24import System.Posix.Files ( getFileStatus, fileMode )
25import System.INotify ( initINotify, EventVariety(Modify), addWatch )
26import System.IO.Error
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 DPut
39import DebugTag
40import UTmp ( users2, utmp_file, UtmpRecord(..), UT_Type(..) )
41import FGConsole ( forkTTYMonitor )
42import XMPPServer ( Stanza, makePresenceStanza, JabberShow(..), stanzaType
43 , LangSpecificMessage(..), msgLangMap, cloneStanza, stanzaFrom )
44import ControlMaybe
45import ClientState
46
47data ConsoleWriter = ConsoleWriter
48 { cwPresenceChan :: TMVar (ClientState,Stanza)
49 -- ^ tty switches and logins are announced on this mvar
50 , csActiveTTY :: TVar Word8
51 , csUtmp :: TVar (Map Text (TVar (Maybe UtmpRecord)))
52 , cwClients :: TVar (Map Text ClientState)
53 -- ^ This 'TVar' holds a map from resource id (tty name)
54 -- to ClientState for all active TTYs and PTYs.
55 }
56
57tshow :: forall a. Show a => a -> Text
58tshow x = Text.pack . show $ x
59
60retryWhen :: forall b. STM b -> (b -> Bool) -> STM b
61retryWhen var pred = do
62 value <- var
63 if pred value then retry
64 else return value
65
66
67onLogin ::
68 forall t.
69 ConsoleWriter
70 -> (STM (Word8, Maybe UtmpRecord)
71 -> TVar (Maybe UtmpRecord) -> IO ())
72 -> t
73 -> IO ()
74onLogin cs start = \e -> do
75 us <- UTmp.users2
76 let (m,cruft) =
77 foldl' (\(m,cruft) x ->
78 case utmpType x of
79 USER_PROCESS
80 -> (Map.insert (utmpTty x) x m,cruft)
81 DEAD_PROCESS | utmpPid x /= 0
82 -> (m,Map.insert (utmpTty x) x cruft)
83 _ -> (m,cruft))
84 (Map.empty,Map.empty)
85 us
86 forM_ (Map.elems cruft) $ \c -> do
87 putStrLn $ "cruft " ++ show (utmpTty c, utmpPid c,utmpHost c, utmpRemoteAddr c)
88 newborn <- atomically $ do
89 old <- readTVar (csUtmp cs) -- swapTVar (csUtmp cs) m
90 newborn <- flip Traversable.mapM (m Map.\\ old)
91 $ newTVar . Just
92 updated <- let upd v u = writeTVar v $ Just u
93 in Traversable.sequence $ Map.intersectionWith upd old m
94 let dead = old Map.\\ m
95 Traversable.mapM (flip writeTVar Nothing) dead
96 writeTVar (csUtmp cs) $ (old `Map.union` newborn) Map.\\ dead
97 return newborn
98 let getActive = do
99 tty <- readTVar $ csActiveTTY cs
100 utmp <- readTVar $ csUtmp cs
101 fromMaybe (return (tty,Nothing))
102 $ Map.lookup ("tty"<>tshow tty) utmp <&> \tuvar -> do
103 tu <- readTVar tuvar
104 return (tty,tu)
105
106 forM_ (Map.elems newborn) $
107 forkIO . start getActive
108 -- forM_ (Map.elems dead ) $ putStrLn . ("gone: "++) . show
109
110-- | Sets up threads to monitor tty switches and logins that are
111-- written to the system utmp file and returns a 'ConsoleWriter'
112-- object for interacting with that information.
113newConsoleWriter :: IO (Maybe ConsoleWriter)
114newConsoleWriter = do
115 chan <- atomically $ newEmptyTMVar
116 cs <- atomically $ do
117 ttyvar <- newTVar 0
118 utmpvar <- newTVar Map.empty
119 clients <- newTVar Map.empty
120 return $ ConsoleWriter { cwPresenceChan = chan
121 , csActiveTTY = ttyvar
122 , csUtmp = utmpvar
123 , cwClients = clients
124 }
125 outvar <- atomically $ newTMVar ()
126 let logit outvar s = do
127 {-
128 atomically $ takeTMVar outvar
129 Text.putStrLn s
130 atomically $ putTMVar outvar ()
131 -}
132 return ()
133 onTTY outvar cs vtnum = do
134 logit outvar $ "switch: " <> tshow vtnum
135 atomically $ writeTVar (csActiveTTY cs) vtnum
136
137 inotify <- initINotify
138
139 -- get active tty
140 mtty <- forkTTYMonitor (onTTY outvar cs)
141 forM mtty $ \_ -> do
142 atomically $ retryWhen (readTVar $ csActiveTTY cs) (==0)
143
144 -- read utmp
145 onLogin cs (newCon (logit outvar) cs) Modify
146
147 -- monitor utmp
148 wd <- addWatch
149 inotify
150 [Modify] -- [CloseWrite,Open,Close,Access,Modify,Move]
151 utmp_file
152 (onLogin cs (newCon (logit outvar) cs))
153 return cs
154
155-- Transforms a string of form language[_territory][.codeset][@modifier]
156-- typically used in LC_ locale variables into the BCP 47
157-- language codes used in xml:lang attributes.
158toBCP47 :: [Char] -> [Char]
159toBCP47 lang = map hyphen $ takeWhile (/='.') lang
160 where hyphen '_' = '-'
161 hyphen c = c
162
163#if MIN_VERSION_base(4,6,0)
164#else
165lookupEnv k = fmap (lookup k) getEnvironment
166#endif
167
168getPreferedLang :: IO Text
169getPreferedLang = do
170 lang <- do
171 lc_all <- lookupEnv "LC_ALL"
172 lc_messages <- lookupEnv "LC_MESSAGES"
173 lang <- lookupEnv "LANG"
174 return $ lc_all `mplus` lc_messages `mplus` lang
175 return $ maybe "en" (Text.pack . toBCP47) lang
176
177cimatch :: Text -> Text -> Bool
178cimatch w t = Text.toLower w == Text.toLower t
179
180cimatches :: Text -> [Text] -> [Text]
181cimatches w ts = dropWhile (not . cimatch w) ts
182
183-- rfc4647 lookup of best match language tag
184lookupLang :: [Text] -> [Text] -> Maybe Text
185lookupLang (w:ws) tags
186 | Text.null w = lookupLang ws tags
187 | otherwise = case cimatches w tags of
188 (t:_) -> Just t
189 [] -> lookupLang (reduce w:ws) tags
190 where
191 reduce w = Text.concat $ reverse nopriv
192 where
193 rparts = reverse . init $ Text.groupBy (\_ c -> c/='-') w
194 nopriv = dropWhile ispriv rparts
195 ispriv t = Text.length t == 2 && Text.head t == '-'
196
197lookupLang [] tags | "" `elem` tags = Just ""
198 | otherwise = listToMaybe $ tags
199
200
201messageText :: Stanza -> IO Text
202messageText msg = do
203 pref <- getPreferedLang
204 let m = msgLangMap (stanzaType msg)
205 key = lookupLang [pref] (map fst m)
206 mchoice = do
207 k <- key
208 lookup k m
209 return $ fromMaybe "" $ do
210 choice <- mchoice
211 let subj = fmap ("Subject: " <>) $ msgSubject choice
212 ts = catMaybes [subj, msgBody choice]
213 return $ Text.intercalate "\n\n" ts
214
215readEnvFile :: String -> FilePath -> IO (Maybe String)
216readEnvFile var file = fmap parse $ readFile file
217 where
218 parse xs = listToMaybe $ map (drop 1 . concat . drop 1) $ filter ofinterest bs
219 where
220 bs = map (groupBy (\_ x -> x/='=')) $ split (/='\0') xs
221 ofinterest (k:vs) | k==var = True
222 ofinterest _ = False
223
224 split pred xs = take 1 gs ++ map (drop 1) (drop 1 gs)
225 where
226 gs = groupBy (\_ x -> pred x) xs
227
228-- | Delivers an XMPP message stanza to the currently active
229-- tty. If that is a linux console, it will write to it similar
230-- to the manner of the BSD write command. If that is an X11
231-- display, it will attempt to notify the user via a libnotify
232-- interface.
233writeActiveTTY :: ConsoleWriter -> Stanza -> IO Bool
234writeActiveTTY cw msg = do
235 putStrLn $ "writeActiveTTY"
236 -- TODO: Do not deliver if the detination user does not own the active tty!
237 (tty, mbu) <- atomically $ do
238 num <- readTVar $ csActiveTTY cw
239 utmp <- readTVar $ csUtmp cw
240 mbu <- maybe (return Nothing) readTVar
241 $ Map.lookup ("tty"<>tshow num) utmp
242 return ( "/dev/tty" <> tshow num
243 , mbu )
244 fromMaybe (return False) $ mbu <&> \utmp -> do
245 display <- fmap (fmap Text.pack)
246 $ readEnvFile "DISPLAY" ("/proc/" ++ show (utmpPid utmp) ++ "/environ")
247 case fmap (==utmpHost utmp) display of
248 Just True -> deliverGUIMessage cw tty utmp msg
249 _ -> deliverTerminalMessage cw tty utmp msg
250
251deliverGUIMessage ::
252 forall t t1. t -> t1 -> UtmpRecord -> Stanza -> IO Bool
253deliverGUIMessage cw tty utmp msg = do
254 text <- do
255 t <- messageText msg
256 return $ Text.unpack
257 $ case stanzaFrom msg of
258 Just from -> from <> ": " <> t
259 Nothing -> t
260 putStrLn $ "deliverGUI: " ++ text
261 handleIO_ (return False) $ do
262 muentry <- fmap Just (getUserEntryForName (Text.unpack $ utmpUser utmp))
263 `catchIOError` \e -> do
264 dput XJabber $ "deliverGUIMessage(getUserEntryForName "++show (utmpUser utmp)++"): "++show e
265 return Nothing
266 forM_ muentry $ \uentry -> do
267 let display = Text.unpack $ utmpHost utmp
268 pid <- forkProcess $ do
269 setUserID (userID uentry)
270 setEnv "DISPLAY" display True
271 -- rawSystem "/usr/bin/notify-send" [text]
272 executeFile "/usr/bin/notify-send" False [text] (Just [("DISPLAY",display)])
273 exitImmediately ExitSuccess
274 return ()
275 return True
276
277crlf :: Text -> Text
278crlf t = Text.unlines $ map cr (Text.lines t)
279 where
280 cr t | Text.last t == '\r' = t
281 | otherwise = t <> "\r"
282
283deliverTerminalMessage ::
284 forall t t1. t -> Text -> t1 -> Stanza -> IO Bool
285deliverTerminalMessage cw tty utmp msg = do
286 mode <- fmap fileMode (getFileStatus $ Text.unpack tty)
287 let mesgy = mode .&. 0o020 /= 0 -- verify mode g+w
288 if not mesgy then return False else do
289 text <- do
290 t <- messageText msg
291 return $ Text.unpack
292 $ case stanzaFrom msg of
293 Just from -> "\r\n" <> from <> " says...\r\n" <> crlf t <> "\r\n"
294 Nothing -> crlf t <> "\r\n"
295 writeFile (Text.unpack tty) text
296 return True -- return True if a message was delivered
297
298-- | Deliver the given message to all a user's PTYs.
299writeAllPty :: ConsoleWriter -> Stanza -> IO Bool
300writeAllPty cw msg = do
301 -- TODO: filter only ptys owned by the destination user.
302 us <- atomically $ readTVar (csUtmp cw)
303 let ptys = Map.filterWithKey ispty us
304 ispty k _ = "pts/" `Text.isPrefixOf` k
305 && Text.all isDigit (Text.drop 4 k)
306 bs <- forM (Map.toList ptys) $ \(tty,utmp) -> do
307 deliverTerminalMessage cw ("/dev/" <> tty) utmp msg
308 return $ or bs
309
310resource :: UtmpRecord -> Text
311resource u =
312 case utmpTty u of
313 s | Text.take 3 s == "tty" -> s
314 s | Text.take 4 s == "pts/" -> "pty" <> Text.drop 4 s <> ":" <> utmpHost u
315 s -> escapeR s <> ":" <> utmpHost u
316 where
317 escapeR s = s
318
319textHostName :: IO Text
320textHostName = fmap Text.pack BSD.getHostName
321
322ujid :: UtmpRecord -> IO Text
323ujid u = do
324 h <- textHostName
325 return $ utmpUser u <> "@" <> h <> "/" <> resource u
326
327newCon :: (Text -> IO ())
328 -> ConsoleWriter
329 -> STM (Word8,Maybe UtmpRecord)
330 -> TVar (Maybe UtmpRecord)
331 -> IO ()
332newCon log cw activeTTY utmp = do
333 ((tty,tu),u) <- atomically $
334 liftM2 (,) activeTTY
335 (readTVar utmp)
336 forM_ u $ \u -> do
337 jid <- ujid u
338 log $ status (resource u) tty tu <> " " <> jid <> " pid=" <> tshow (utmpPid u)
339 <> (if istty (resource u)
340 then " host=" <> tshow (utmpHost u)
341 else "")
342 <> " session=" <> tshow (utmpSession u)
343 <> " addr=" <> tshow (utmpRemoteAddr u)
344 let r = resource u
345 stanza <- makePresenceStanza
346 "jabber:client"
347 (Just jid)
348 (jstatus r tty tu)
349 statusv <- atomically $ newTVar (Just stanza)
350 flgs <- atomically $ newTVar 0
351 let client = ClientState { clientResource = r
352 , clientUser = utmpUser u
353 , clientProfile = "."
354 , clientPid = Nothing
355 , clientStatus = statusv
356 , clientFlags = flgs }
357 atomically $ do
358 modifyTVar (cwClients cw) $ Map.insert r client
359 putTMVar (cwPresenceChan cw) (client,stanza)
360 loop client tty tu (Just u)
361 where
362 bstatus r ttynum mtu
363 = r == ttystr
364 || match mtu
365 where ttystr = "tty" <> tshow ttynum
366 searchstr mtu = maybe ttystr utmpHost $ do
367 tu <- mtu
368 guard (not $ Text.null $ utmpHost tu)
369 return tu
370 match mtu = searchstr mtu `Text.isInfixOf` Text.dropWhile (/=':') r
371 jstatus r ttynum tu =
372 if bstatus r ttynum tu
373 then Available
374 else Away
375 status r ttynum tu = tshow $ jstatus r ttynum tu
376
377 istty r = fst3 == "tty" && Text.all isDigit rst
378 where
379 (fst3,rst) = Text.splitAt 3 r
380
381 loop client tty tu u = do
382 what <- atomically $ foldr1 orElse
383 [ do (tty',tu') <- retryWhen activeTTY
384 (\ttyu -> bstatus r tty tu == uncurry (bstatus r) ttyu)
385 return $ ttyChanged tty' tu'
386 , do u' <- retryWhen (readTVar utmp) (==u)
387 return $ utmpChanged u'
388 ]
389 what
390 where
391 r = maybe "" resource u
392
393 ttyChanged tty' tu' = do
394 jid <- maybe (return "") ujid u
395 stanza <- makePresenceStanza
396 "jabber:client"
397 (Just jid)
398 (jstatus r tty' tu')
399 dup <- cloneStanza stanza
400 atomically $ do
401 writeTVar (clientStatus client) $ Just dup
402 putTMVar (cwPresenceChan cw) (client,stanza)
403 log $ status r tty' tu' <> " " <> jid
404 loop client tty' tu' u
405
406 utmpChanged u' = maybe dead changed u'
407 where
408 changed u' = do
409 jid0 <- maybe (return "") ujid u
410 jid <- ujid u'
411 log $ "changed: " <> jid0 <> " --> " <> jid
412 loop client tty tu (Just u')
413 dead = do
414 jid <- maybe (return "") ujid u
415 stanza <- makePresenceStanza "jabber:client" (Just jid) Offline
416 atomically $ do
417 modifyTVar (cwClients cw) $ Map.delete (clientResource client)
418 putTMVar (cwPresenceChan cw) (client,stanza)
419 log $ "Offline " <> jid
420
diff --git a/Presence/Control/Concurrent/STM/Util.hs b/Presence/Control/Concurrent/STM/Util.hs
deleted file mode 100644
index 4be3cff5..00000000
--- a/Presence/Control/Concurrent/STM/Util.hs
+++ /dev/null
@@ -1,21 +0,0 @@
1module Control.Concurrent.STM.Util where
2
3import Control.Monad.IO.Class
4import Control.Concurrent.STM
5
6chanContents :: TChan x -> IO [x]
7chanContents ch = do
8 x <- atomically $ do
9 bempty <- isEmptyTChan ch
10 if bempty
11 then return Nothing
12 else fmap Just $ readTChan ch
13 maybe (return [])
14 (\x -> do
15 xs <- chanContents ch
16 return (x:xs))
17 x
18
19ioWriteChan :: MonadIO m => TChan a -> a -> m ()
20ioWriteChan c v = liftIO . atomically $ writeTChan c v
21
diff --git a/Presence/ControlMaybe.hs b/Presence/ControlMaybe.hs
deleted file mode 100644
index a101d667..00000000
--- a/Presence/ControlMaybe.hs
+++ /dev/null
@@ -1,64 +0,0 @@
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE ScopedTypeVariables #-}
3module ControlMaybe
4 ( module ControlMaybe
5 , module Data.Functor
6 ) where
7
8-- import GHC.IO.Exception (IOException(..))
9import Control.Monad
10import Data.Functor
11import System.IO.Error
12
13
14-- forM_ with less polymorphism.
15withJust :: Monad m => Maybe x -> (x -> m ()) -> m ()
16withJust m f = forM_ m f
17{-# INLINE withJust #-}
18
19whenJust :: Monad m => m (Maybe x) -> (x -> m ()) -> m ()
20whenJust acn f = acn >>= mapM_ f
21{-# INLINE whenJust #-}
22
23
24catchIO_ :: IO a -> IO a -> IO a
25catchIO_ body catcher = catchIOError body (\_ -> catcher)
26{-# INLINE catchIO_ #-}
27
28handleIO_ :: IO a -> IO a -> IO a
29handleIO_ catcher body = catchIOError body (\_ -> catcher)
30{-# INLINE handleIO_ #-}
31
32
33handleIO :: (IOError -> IO a) -> IO a -> IO a
34handleIO catcher body = catchIOError body catcher
35{-# INLINE handleIO #-}
36
37#if !MIN_VERSION_base(4,11,0)
38-- | Flipped version of '<$>'.
39--
40-- @
41-- ('<&>') = 'flip' 'fmap'
42-- @
43--
44-- @since 4.11.0.0
45--
46-- ==== __Examples__
47-- Apply @(+1)@ to a list, a 'Data.Maybe.Just' and a 'Data.Either.Right':
48--
49-- >>> Just 2 <&> (+1)
50-- Just 3
51--
52-- >>> [1,2,3] <&> (+1)
53-- [2,3,4]
54--
55-- >>> Right 3 <&> (+1)
56-- Right 4
57--
58(<&>) :: Functor f => f a -> (a -> b) -> f b
59as <&> f = f <$> as
60
61infixl 1 <&>
62#endif
63
64
diff --git a/Presence/DNSCache.hs b/Presence/DNSCache.hs
deleted file mode 100644
index e28655c5..00000000
--- a/Presence/DNSCache.hs
+++ /dev/null
@@ -1,291 +0,0 @@
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 #-}
13{-# LANGUAGE CPP #-}
14module DNSCache
15 ( DNSCache
16 , reverseResolve
17 , forwardResolve
18 , newDNSCache
19 , parseAddress
20 , unsafeParseAddress
21 , strip_brackets
22 , withPort
23 ) where
24
25#ifdef THREAD_DEBUG
26import Control.Concurrent.Lifted.Instrument
27#else
28import Control.Concurrent.Lifted
29import GHC.Conc (labelThread)
30#endif
31import Control.Arrow
32import Control.Concurrent.STM
33import Data.Text ( Text )
34import Network.Socket ( SockAddr(..), AddrInfoFlag(..), defaultHints, getAddrInfo, AddrInfo(..) )
35import Data.Time.Clock ( UTCTime, getCurrentTime, diffUTCTime )
36import System.IO.Error ( isDoesNotExistError )
37import System.Endian ( fromBE32, toBE32 )
38import Control.Exception ( handle )
39import Data.Map ( Map )
40import qualified Data.Map as Map
41import qualified Network.BSD as BSD
42import qualified Data.Text as Text
43import Control.Monad
44import Data.Function
45import Data.List
46import Data.Ord
47import Data.Maybe
48import System.IO.Error
49import System.IO.Unsafe
50
51import SockAddr ()
52import ControlMaybe ( handleIO_ )
53import GetHostByAddr ( getHostByAddr )
54import InterruptibleDelay
55import DPut
56import DebugTag
57
58type TimeStamp = UTCTime
59
60data DNSCache =
61 DNSCache
62 { fcache :: TVar (Map Text [(TimeStamp, SockAddr)])
63 , rcache :: TVar (Map SockAddr [(TimeStamp, Text)])
64 }
65
66
67newDNSCache :: IO DNSCache
68newDNSCache = do
69 fcache <- newTVarIO Map.empty
70 rcache <- newTVarIO Map.empty
71 return DNSCache { fcache=fcache, rcache=rcache }
72
73updateCache :: Eq x =>
74 Bool -> TimeStamp -> [x] -> Maybe [(TimeStamp,x)] -> Maybe [(TimeStamp,x)]
75updateCache withScrub utc xs mys = do
76 let ys = maybe [] id mys
77 ys' = filter scrub ys
78 ys'' = map (utc,) xs ++ ys'
79 minute = 60
80 scrub (t,x) | withScrub && diffUTCTime utc t < minute = False
81 scrub (t,x) | x `elem` xs = False
82 scrub _ = True
83 guard $ not (null ys'')
84 return ys''
85
86dnsObserve :: DNSCache -> Bool -> TimeStamp -> [(Text,SockAddr)] -> STM ()
87dnsObserve dns withScrub utc obs = do
88 f <- readTVar $ fcache dns
89 r <- readTVar $ rcache dns
90 let obs' = map (\(n,a)->(n,a `withPort` 0)) obs
91 gs = do
92 g <- groupBy ((==) `on` fst) $ sortBy (comparing fst) obs'
93 (n,_) <- take 1 g
94 return (n,map snd g)
95 f' = foldl' updatef f gs
96 hs = do
97 h <- groupBy ((==) `on` snd) $ sortBy (comparing snd) obs'
98 (_,a) <- take 1 h
99 return (a,map fst h)
100 r' = foldl' updater r hs
101 writeTVar (fcache dns) f'
102 writeTVar (rcache dns) r'
103 where
104 updatef f (n,addrs) = Map.alter (updateCache withScrub utc addrs) n f
105 updater r (a,ns) = Map.alter (updateCache withScrub utc ns) a r
106
107make6mapped4 :: SockAddr -> SockAddr
108make6mapped4 addr@(SockAddrInet6 {}) = addr
109make6mapped4 addr@(SockAddrInet port a) = SockAddrInet6 port 0 (0,0,0xFFFF,fromBE32 a) 0
110
111tryForkOS :: IO () -> IO ThreadId
112tryForkOS action = catchIOError (forkOS action) $ \e -> do
113 dput XMisc $ "DNSCache: Link with -threaded to avoid excessively long time-out."
114 forkIO action
115
116
117-- Attempt to resolve the given domain name. Returns an empty list if the
118-- resolve operation takes longer than the timeout, but the 'DNSCache' will be
119-- updated when the resolve completes.
120--
121-- When the resolve operation does complete, any entries less than a minute old
122-- will be overwritten with the new results. Older entries are allowed to
123-- persist for reasons I don't understand as of this writing. (See 'updateCache')
124rawForwardResolve ::
125 DNSCache -> (Text -> IO ()) -> Int -> Text -> IO [SockAddr]
126rawForwardResolve dns onFail timeout addrtext = do
127 r <- atomically newEmptyTMVar
128 mvar <- interruptibleDelay
129 rt <- tryForkOS $ do
130 myThreadId >>= flip labelThread ("resolve."++show addrtext)
131 resolver r mvar
132 startDelay mvar timeout
133 did <- atomically $ tryPutTMVar r []
134 when did (onFail addrtext)
135 atomically $ readTMVar r
136 where
137 resolver r mvar = do
138 xs <- handle (\e -> let _ = isDoesNotExistError e in return [])
139 $ do fmap (nub . map (make6mapped4 . addrAddress)) $
140 getAddrInfo (Just $ defaultHints { addrFlags = [ AI_CANONNAME, AI_V4MAPPED ]})
141 (Just $ Text.unpack $ strip_brackets addrtext)
142 (Just "5269")
143 did <- atomically $ tryPutTMVar r xs
144 when did $ do
145 interruptDelay mvar
146 utc <- getCurrentTime
147 atomically $ dnsObserve dns True utc $ map (addrtext,) xs
148 return ()
149
150strip_brackets :: Text -> Text
151strip_brackets s =
152 case Text.uncons s of
153 Just ('[',t) -> Text.takeWhile (/=']') t
154 _ -> s
155
156
157reportTimeout :: forall a. Show a => a -> IO ()
158reportTimeout addrtext = do
159 dput XMisc $ "timeout resolving: "++show addrtext
160 -- killThread rt
161
162unmap6mapped4 :: SockAddr -> SockAddr
163unmap6mapped4 addr@(SockAddrInet6 port _ (0,0,0xFFFF,a) _) =
164 SockAddrInet port (toBE32 a)
165unmap6mapped4 addr = addr
166
167rawReverseResolve ::
168 DNSCache -> (SockAddr -> IO ()) -> Int -> SockAddr -> IO [Text]
169rawReverseResolve dns onFail timeout addr = do
170 r <- atomically newEmptyTMVar
171 mvar <- interruptibleDelay
172 rt <- forkOS $ resolver r mvar
173 startDelay mvar timeout
174 did <- atomically $ tryPutTMVar r []
175 when did (onFail addr)
176 atomically $ readTMVar r
177 where
178 resolver r mvar =
179 handleIO_ (return ()) $ do
180 ent <- getHostByAddr (unmap6mapped4 addr) -- AF_UNSPEC addr
181 let names = BSD.hostName ent : BSD.hostAliases ent
182 xs = map Text.pack $ nub names
183 forkIO $ do
184 utc <- getCurrentTime
185 atomically $ dnsObserve dns False utc $ map (,addr) xs
186 atomically $ putTMVar r xs
187
188-- Returns expired (older than a minute) cached reverse-dns results
189-- and removes them from the cache.
190expiredReverse :: DNSCache -> SockAddr -> IO [Text]
191expiredReverse dns addr = do
192 utc <- getCurrentTime
193 addr <- return $ addr `withPort` 0
194 es <- atomically $ do
195 r <- readTVar $ rcache dns
196 let ns = maybe [] id $ Map.lookup addr r
197 minute = 60 -- seconds
198 -- XXX: Is this right? flip diffUTCTime utc returns the age of the
199 -- cache entry?
200 (es0,ns') = partition ( (>=minute) . flip diffUTCTime utc . fst ) ns
201 es = map snd es0
202 modifyTVar' (rcache dns) $ Map.insert addr ns'
203 f <- readTVar $ fcache dns
204 let f' = foldl' (flip $ Map.alter (expire utc)) f es
205 expire utc Nothing = Nothing
206 expire utc (Just as) = if null as' then Nothing else Just as'
207 where as' = filter ( (<minute) . flip diffUTCTime utc . fst) as
208 writeTVar (fcache dns) f'
209 return es
210 return es
211
212cachedReverse :: DNSCache -> SockAddr -> IO [Text]
213cachedReverse dns addr = do
214 utc <- getCurrentTime
215 addr <- return $ addr `withPort` 0
216 atomically $ do
217 r <- readTVar (rcache dns)
218 let ns = maybe [] id $ Map.lookup addr r
219 {-
220 ns' = filter ( (<minute) . flip diffUTCTime utc . fst) ns
221 minute = 60 -- seconds
222 modifyTVar' (rcache dns) $ Map.insert addr ns'
223 return $ map snd ns'
224 -}
225 return $ map snd ns
226
227-- Returns any dns query results for the given name that were observed less
228-- than a minute ago and updates the forward-cache to remove any results older
229-- than that.
230cachedForward :: DNSCache -> Text -> IO [SockAddr]
231cachedForward dns n = do
232 utc <- getCurrentTime
233 atomically $ do
234 f <- readTVar (fcache dns)
235 let as = maybe [] id $ Map.lookup n f
236 as' = filter ( (<minute) . flip diffUTCTime utc . fst) as
237 minute = 60 -- seconds
238 modifyTVar' (fcache dns) $ Map.insert n as'
239 return $ map snd as'
240
241-- Reverse-resolves an address to a domain name. Returns both the result of a
242-- new query and any freshly cached results. Cache entries older than a minute
243-- will not be returned, but will be refreshed in spawned threads so that they
244-- may be available for the next call.
245reverseResolve :: DNSCache -> SockAddr -> IO [Text]
246reverseResolve dns addr = do
247 expired <- expiredReverse dns addr
248 forM_ expired $ \n -> forkIO $ do
249 rawForwardResolve dns (const $ return ()) 1000000 n
250 return ()
251 xs <- rawReverseResolve dns (const $ return ()) 1000000 addr
252 cs <- cachedReverse dns addr
253 return $ xs ++ filter (not . flip elem xs) cs
254
255-- Resolves a name, if there's no result within one second, then any cached
256-- results that are less than a minute old are returned.
257forwardResolve :: DNSCache -> Text -> IO [SockAddr]
258forwardResolve dns n = do
259 as <- rawForwardResolve dns (const $ return ()) 1000000 n
260 if null as
261 then cachedForward dns n
262 else return as
263
264parseAddress :: Text -> IO (Maybe SockAddr)
265parseAddress addr_str = do
266 info <- getAddrInfo (Just $ defaultHints { addrFlags = [ AI_NUMERICHOST ] })
267 (Just . Text.unpack $ addr_str)
268 (Just "0")
269 return . listToMaybe $ map addrAddress info
270
271
272splitAtPort :: String -> (String,String)
273splitAtPort s = second sanitizePort $ case s of
274 ('[':t) -> break (==']') t
275 _ -> break (==':') s
276 where
277 sanitizePort (']':':':p) = p
278 sanitizePort (':':p) = p
279 sanitizePort _ = "0"
280
281unsafeParseAddress :: String -> Maybe SockAddr
282unsafeParseAddress addr_str = unsafePerformIO $ do
283 let (ipstr,portstr) = splitAtPort addr_str
284 info <- getAddrInfo (Just $ defaultHints { addrFlags = [ AI_NUMERICHOST ] })
285 (Just ipstr)
286 (Just portstr)
287 return . listToMaybe $ map addrAddress info
288
289withPort :: SockAddr -> Int -> SockAddr
290withPort (SockAddrInet _ a) port = SockAddrInet (toEnum port) a
291withPort (SockAddrInet6 _ a b c) port = SockAddrInet6 (toEnum port) a b c
diff --git a/Presence/EventUtil.hs b/Presence/EventUtil.hs
deleted file mode 100644
index 908e09e0..00000000
--- a/Presence/EventUtil.hs
+++ /dev/null
@@ -1,83 +0,0 @@
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
deleted file mode 100644
index 03aaebf2..00000000
--- a/Presence/FGConsole.hs
+++ /dev/null
@@ -1,67 +0,0 @@
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
15
16import Logging
17import System.Posix.Signals
18
19-- c_monitorTTY fd = trace "c_monitorTTY" (return ()) -- (trace "WTF" todo)
20
21foreign import ccall "monitorTTY" c_monitorTTY :: Fd -> IO CInt
22foreign import ccall "closeTTY" c_closeTTY :: IO ()
23
24forkTTYMonitor :: (Word8 -> IO ()) -> IO (Maybe (Fd,ThreadId))
25forkTTYMonitor handler = do
26 (rfd,wfd) <- createPipe
27 retvar <- newEmptyMVar
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 didfork <- c_monitorTTY wfd
36 putMVar retvar didfork
37 when (didfork == 0) $ do
38 let monitor =
39 (do
40 threadWaitRead rfd
41 (cs,cnt) <- fdRead rfd 1
42 forM_ cs (handler . unsafeCoerce {- . trace "read byte" -})
43 monitor)
44 `E.catch`
45 \(e :: IOException) -> do
46 err <- getErrno
47 case () of
48 _ | err==eAGAIN -> monitor
49 _ | otherwise -> cleanup
50 `E.catch`
51 \(e :: AsyncException) -> cleanup
52 monitor
53 didfork <- takeMVar retvar
54 if didfork == 0
55 then return $! Just (rfd,thread)
56 else return $! Nothing
57
58killTTYMonitor :: (Fd, ThreadId) -> IO ()
59killTTYMonitor (rfd,thread) = do
60 closeFd rfd
61 yield
62 killThread thread
63 raiseSignal sigUSR1
64 -- threadDelay 1000000
65
66
67-- vim:ft=haskell:
diff --git a/Presence/GetHostByAddr.hs b/Presence/GetHostByAddr.hs
deleted file mode 100644
index 45bca5e9..00000000
--- a/Presence/GetHostByAddr.hs
+++ /dev/null
@@ -1,77 +0,0 @@
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
deleted file mode 100644
index 664d4f54..00000000
--- a/Presence/IDMangler.hs
+++ /dev/null
@@ -1,68 +0,0 @@
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/LocalChat.hs b/Presence/LocalChat.hs
deleted file mode 100644
index eab54a03..00000000
--- a/Presence/LocalChat.hs
+++ /dev/null
@@ -1,71 +0,0 @@
1{-# LANGUAGE CPP #-}
2module LocalChat
3 ( module Chat
4 , module LocalChat
5 ) where
6
7import Debug.Trace
8import Control.Concurrent.STM
9import Control.Monad
10import Data.Function
11import Data.List
12import qualified Data.Map as Map
13 ;import Data.Map (Map)
14import qualified Data.Text as T
15 ;import Data.Text (Text)
16
17#ifdef THREAD_DEBUG
18import Control.Concurrent.Lifted.Instrument
19#else
20import Control.Concurrent.Lifted
21import GHC.Conc (labelThread)
22#endif
23
24import DPut
25import DebugTag
26import Chat
27import MUC
28
29forkUntilSignaled :: String -> STM (IO ()) -> IO (IO ())
30forkUntilSignaled lbl action = do
31 quitSignal <- newTVarIO False
32 t <- forkIO $ do
33 fix $ \loop -> join $ atomically
34 $ orElse (do readTVar quitSignal >>= check
35 return $ return ())
36 (fmap (>> loop) $ action)
37 labelThread t lbl
38 return $ atomically (writeTVar quitSignal True)
39
40
41chatevents rsvar = do
42 rs <- readTVar rsvar
43 if Map.null rs
44 then retry
45 else do
46 ios <- forM rs $ \r -> do
47 ps <- roomPending r
48 trace ("roomPending " ++ show ps) $ return ()
49 case Map.toList ps of
50 (k,t):ts -> do
51 roomCommit r k t
52 return $ do
53 dput XJabber $ "committed " ++ show (length ts,k,t)
54 _ -> retry
55 return $ foldl1 (>>) ios
56
57forkLocalChat :: MUC -> IO (IO ())
58forkLocalChat muc = do
59 (chan, rs) <- atomically $ do
60 c <- dupTChan (mucChan muc)
61 rs <- newTVar Map.empty
62 return (c,rs)
63 forkUntilSignaled "localchat" $ orElse (chatevents rs) $ do
64 e <- readTChan chan
65 case e of
66 MUCCreate room jid nick r -> modifyTVar' rs $ Map.insert room r
67 return $ case e of
68 MUCCreate room jid nick _ ->
69 dput XJabber $ unwords $ map T.unpack
70 [ "MUCCreate", room, jid, nick ]
71
diff --git a/Presence/LocalPeerCred.hs b/Presence/LocalPeerCred.hs
deleted file mode 100644
index f68557e8..00000000
--- a/Presence/LocalPeerCred.hs
+++ /dev/null
@@ -1,234 +0,0 @@
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.Bits
17import Data.Serialize
18import Data.Word
19import System.Posix.Types
20import System.Posix.Files
21import Logging
22import Network.SocketLike
23import ControlMaybe
24import Data.String
25import System.IO
26
27(??) :: (Num t, Ord t) => [a] -> t -> Maybe a
28xs ?? n | n < 0 = Nothing
29[] ?? _ = Nothing
30(x:_) ?? 0 = Just x
31(_:xs) ?? n = xs ?? (n-1)
32
33parseHex :: W8.ByteString -> W8.ByteString
34parseHex bs = L.concat . parseHex' $ bs
35 where
36 parseHex' bs =
37 let (dnib,ts) = L.splitAt 2 bs
38 parseNibble x = W8.pack $ group2 toW8 (W8.unpack $ W8.map hexDigit x)
39 hexDigit d = d - (if d>0x39 then 0x37 else 0x30)
40 group2 f (x:y:ys) = f x y : group2 f ys
41 group2 _ _ = []
42 toW8 a b = shift a 4 .|. b
43 in parseNibble dnib :
44 if L.null ts
45 then []
46 else parseHex' ts
47
48getLocalPeerCred' :: SockAddr -> IO (Maybe (UserID, W8.ByteString))
49getLocalPeerCred' (unmap6mapped4 -> SockAddrInet portn host) = do
50 let port = fromEnum portn
51 {- trace ("tcp4 "++show(port,host)) $ -}
52 withFile "/proc/net/tcp" ReadMode (parseProcNet port host)
53
54getLocalPeerCred' (unmap6mapped4 -> SockAddrInet6 portn flow host scope) = do
55 let port = fromEnum portn
56 (a,b,c,d) = host
57 host' = (toBE32 a, toBE32 b, toBE32 c, toBE32 d)
58 withFile "/proc/net/tcp6" ReadMode (parseProcNet port host')
59
60getLocalPeerCred' (unmap6mapped4 -> addr@(SockAddrUnix _)) =
61 -- TODO: parse /proc/net/unix
62 -- see also: Network.Socket.getPeerCred
63 return Nothing
64
65getLocalPeerCred :: SocketLike sock => sock -> IO (Maybe UserID)
66getLocalPeerCred sock = do
67 addr <- getPeerName sock
68 muid <- getLocalPeerCred' addr
69 case muid of
70 Just (uid,inode) -> return (Just uid)
71 Nothing -> trace "proc failed." $ fmap (validate . CUid . fromIntegral . sndOf3) (getPeerCred sock)
72 where sndOf3 (pid,uid,gid) = uid
73 where
74 validate uid = Just uid -- TODO
75
76from16 :: Word16 -> Int
77from16 = fromEnum
78
79as16 :: Word16 -> Word16
80as16 = id
81
82parseProcNet :: (Serialize t, Num t1, Eq t, Eq t1) =>
83 t1
84 -> t
85 -> Handle
86 -> IO (Maybe (UserID, W8.ByteString))
87parseProcNet port host h = do
88 tcp <- L.hGetContents h -- Failed: tcp <- hFileSize h >>= hGet h . fromIntegral
89 let u = do
90 ls <- listToMaybe . tail . tails . L.lines $ tcp
91 let ws = map L.words ls
92 let rs = ( catMaybes . flip map ws $ \xs -> do
93 let ys = snd (Prelude.splitAt 1 xs)
94 localaddr <- listToMaybe ys
95 let zs = L.splitWith (==':') localaddr
96 addr <- fmap parseHex $ listToMaybe zs
97 port <- either (const Nothing) (Just . fromIntegral . as16) . decode . L.toStrict . parseHex
98 =<< listToMaybe (snd (Prelude.splitAt 1 zs))
99 let ys' = snd (Prelude.splitAt 5 (tail ys))
100 ys'' = snd (Prelude.splitAt 2 ys')
101 uid <- listToMaybe ys'
102 inode <- listToMaybe ys''
103 peer <- either (const Nothing) Just $ do
104 a <- decode $ L.toStrict addr
105 return (port,a)
106 let user = toEnum (read (L.unpack uid) ::Int) ::UserID -- CUid . fromIntegral $ (read (unpack uid)::Int)
107 return $ {-trace ("peer:"++show(peer,user,inode))-} (peer,(user,inode))
108 )
109 fmap snd . listToMaybe $ filter ((==(port,host)).fst) rs
110 {- trace ("found: "++show u) -}
111 u `seq` return u
112 {-
113 where
114 a === b = let r= a==b in trace ("Comparing "++show (a,b)++"-->"++show r) r
115 -}
116
117
118-- PEER NAME: [::ffff:127.0.0.1]:34307
119unmap6mapped4 :: SockAddr -> SockAddr
120unmap6mapped4 addr@(SockAddrInet6 port _ (0,0,0xFFFF,a) _) = SockAddrInet port (toBE32 a)
121unmap6mapped4 addr = addr
122
123identifyTTY ::
124 [(W8.ByteString, ProcessID)]
125 -> UserID -> W8.ByteString -> IO (Maybe W8.ByteString, Maybe CPid)
126identifyTTY tty_pids uid inode = do
127 pid <- scanProc (show uid) (L.unpack inode)
128 -- putStrLn $ "scanProc --> "++show pid
129 fromMaybe (return (Nothing,Nothing)) $ pid <&> \(pid,ttydev) -> do
130 tty <- ttyOrDisplay pid ttydev
131 -- putStrLn $ "users = " ++ show tty_pids
132 dts <- ttyToXorgs tty_pids
133 -- putStrLn $ "displays = " ++ show dts
134 -- putStrLn $ "tty = " ++ show tty
135 -- -- displays = [(":5",Chunk "tty7" Empty)]
136 let tty' = if take 3 tty=="tty"
137 then Just (L.pack tty)
138 else lookup (parseTty tty) (map (first parseTty) dts)
139 return (tty',Just pid)
140 where
141 parseTty :: String -> Float
142 parseTty = read . tail . dropWhile (/=':')
143
144ttyToXorgs :: Show a => [(t, a)] -> IO [([Char], t)]
145ttyToXorgs tty_pids = do
146 dts' <- flip mapM tty_pids $ \(tty,pid) -> do
147 cmd' <- readFile $ "/proc/"++show pid++"/cmdline"
148 case listToMaybe . words . takeWhile (/='\0') $ cmd' of
149 Nothing -> return Nothing
150 Just cmd -> do
151 if notElem cmd ["gdm-session-worker"]
152 then return Nothing
153 else do
154 display <- readDisplayVariable pid
155 return (fmap ( (,tty) . snd ) display)
156 let dts = catMaybes dts'
157 return dts
158
159
160scanProc :: t -> [Char] -> IO (Maybe (CPid, FilePath))
161scanProc uid inode = do
162 contents <- getDirectoryContents "/proc" `catchIO_` return []
163 let pids = reverse $ filter (\n -> not (null n) && isDigit (head n)) contents
164 let searchPids [] = return Nothing
165 searchPids (pid:pids) = do
166 loginuid <- fmap makeUidStr $ readFile $ "/proc/"++pid++"/loginuid"
167 if False -- (uid/=loginuid) -- this check proved bad when mcabber ran on tty3
168 then searchPids pids
169 else do
170 -- putStrLn $ "pid "++show pid ++ " --> uid "++show loginuid
171 let loop [] = return Nothing
172 loop ("0":fds) = loop fds
173 loop (fd:fds) = do
174 handleIO_ (loop fds) $ do
175 what <- readSymbolicLink $ "/proc/"++pid++"/fd/"++fd
176 -- putStrLn $ " what= "++show what
177 if (what=="socket:["++inode++"]")
178 then do
179 tty <- readSymbolicLink $ "/proc/"++pid++"/fd/0"
180 return (Just (pid,tty))
181 else loop fds
182 -- requires root (or same user as for pid)...
183 fds <- getDirectoryContents ("/proc/"++pid++"/fd") `catchIO_` return []
184 mb <- loop fds
185 maybe (searchPids pids) (return . Just) mb
186
187 fmap (fmap (first (read :: String -> CPid))) $ searchPids pids
188
189ttyOrDisplay :: Show a => a -> FilePath -> IO [Char]
190ttyOrDisplay pid ttydev = do
191 ptty <- searchParentsForTTY (show pid) ttydev
192 case ptty of
193 Just tty -> return tty
194 Nothing -> do
195 display <- readDisplayVariable pid
196 -- putStrLn $ "display = " ++ show display
197 case display of
198 Just (_,disp) -> return disp
199 _ -> return ttydev
200
201
202readDisplayVariable :: Show a => a -> IO (Maybe ([Char], [Char]))
203readDisplayVariable pid = do
204 env <- handleIO_ (return "")
205 . readFile $ "/proc/"++show pid++"/environ"
206 let vs = unzero $ List.groupBy (\_ c->c/='\0') env
207 unzero [] = []
208 unzero (v:vs) = v:map tail vs
209 keyvalue xs = (key,value)
210 where
211 (key,ys) = break (=='=') xs
212 value = case ys of { [] -> []; (_:ys') -> ys' }
213 display = listToMaybe
214 . filter ((=="DISPLAY").fst)
215 . map keyvalue
216 $ vs
217 return display
218
219
220makeUidStr :: (Data.String.IsString t, Eq t) => t -> t
221makeUidStr "4294967295" = "invalid"
222makeUidStr uid = uid
223
224
225searchParentsForTTY :: String -> FilePath -> IO (Maybe [Char])
226searchParentsForTTY pid ttydev | take 8 ttydev == "/dev/tty" = return . Just $ drop 5 ttydev
227searchParentsForTTY "1" ttydev | otherwise = return Nothing
228searchParentsForTTY pid ttydev = do
229 stat <- handleIO_ (return "") . readFile $ "/proc/"++pid++"/stat"
230 case words stat ?? 3 of
231 Nothing -> return Nothing
232 Just ppid -> do
233 tty <- handleIO_ (return "") $ readSymbolicLink $ "/proc/"++ppid++"/fd/0"
234 searchParentsForTTY ppid tty
diff --git a/Presence/LockedChan.hs b/Presence/LockedChan.hs
deleted file mode 100644
index eac2b5ad..00000000
--- a/Presence/LockedChan.hs
+++ /dev/null
@@ -1,78 +0,0 @@
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
deleted file mode 100644
index b997d341..00000000
--- a/Presence/Logging.hs
+++ /dev/null
@@ -1,25 +0,0 @@
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/MUC.hs b/Presence/MUC.hs
deleted file mode 100644
index 639e834b..00000000
--- a/Presence/MUC.hs
+++ /dev/null
@@ -1,61 +0,0 @@
1module MUC where
2
3import Control.Monad
4import Control.Concurrent.STM
5
6import qualified Data.Map.Strict as Map
7 ;import Data.Map.Strict (Map)
8
9import Chat
10import ConnectionKey
11import Data.Text (Text)
12
13data MUC = MUC
14 { mucRooms :: TVar (Map Text (Room ClientAddress))
15 , mucChan :: TChan MUCEvent
16 }
17
18data MUCEvent = MUCCreate Text{-room-} Text{-JID-} Text{-nick-} (Room ClientAddress)
19
20
21newMUC :: STM MUC
22newMUC = MUC <$> newTVar Map.empty <*> newBroadcastTChan
23
24mucRoomList :: MUC -> IO [(Text{-room-},Maybe Text{-friendly room name-})]
25mucRoomList muc = atomically $ do
26 rs <- Map.toList <$> readTVar (mucRooms muc)
27 forM rs $ \(rkey,r) -> do
28 fn <- roomFriendlyName r
29 return (rkey,fn)
30
31mucRoomOccupants :: MUC -> Text{-room-} -> IO [(Text{-nick-},Maybe Text{-friendly name-})]
32mucRoomOccupants muc rkey = atomically $ do
33 mr <- Map.lookup rkey <$> readTVar (mucRooms muc)
34 case mr of
35 Nothing -> return []
36 Just r -> roomOccupants r
37
38mucReservedNick :: MUC -> Text{-room-} -> IO (Maybe (Text{-JID-} -> IO (Maybe Text)))
39mucReservedNick muc rkey = atomically $ do
40 mr <- Map.lookup rkey <$> readTVar (mucRooms muc)
41 case mr of
42 Nothing -> return Nothing
43 Just r -> return $ Just $ \jid -> atomically $ roomReservedNick r jid
44
45mucJoinRoom :: MUC -> Text{-JID-} -> Text{-nick-} -> Text{-room-} -> ClientAddress -> STM (JoinedRoom ClientAddress)
46mucJoinRoom muc jid nick rkey k = do
47 mr <- Map.lookup rkey <$> readTVar (mucRooms muc)
48 case mr of
49 Nothing -> do
50 -- create room.
51 r <- newRoom
52 v <- joinRoom k r (Just jid) nick
53 modifyTVar' (mucRooms muc) $ Map.insert rkey r
54 writeTChan (mucChan muc) $ MUCCreate rkey jid nick r
55 return v
56 Just r -> do
57 -- join room.
58 v <- joinRoom k r (Just jid) nick
59 return v
60
61
diff --git a/Presence/Nesting.hs b/Presence/Nesting.hs
deleted file mode 100644
index cf47c9fc..00000000
--- a/Presence/Nesting.hs
+++ /dev/null
@@ -1,86 +0,0 @@
1{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Nesting where
4
5import Control.Monad.State.Strict
6import Data.Conduit
7import Data.Conduit.Lift
8import qualified Data.List as List
9import qualified Data.Text as S
10import Data.XML.Types
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 => ConduitM Event Event (StateT XMLState m) ()
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
diff --git a/Presence/Paths.hs b/Presence/Paths.hs
deleted file mode 100644
index 9d51b66e..00000000
--- a/Presence/Paths.hs
+++ /dev/null
@@ -1,62 +0,0 @@
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
deleted file mode 100644
index 62becfe1..00000000
--- a/Presence/PeerResolve.hs
+++ /dev/null
@@ -1,27 +0,0 @@
1module PeerResolve
2 ( peerKeyToResolvedNames
3 , resolvePeer
4 , parseAddress
5 , unsafeParseAddress
6 , strip_brackets
7 , withPort
8 ) where
9
10import Data.Text ( Text )
11import Network.Socket ( SockAddr(..) )
12import System.IO.Unsafe
13
14import DNSCache
15import ConnectionKey
16
17{-# NOINLINE global_dns_cache #-}
18global_dns_cache :: DNSCache
19global_dns_cache = unsafePerformIO $ newDNSCache
20
21resolvePeer :: Text -> IO [PeerAddress]
22resolvePeer addrtext = map PeerAddress <$> forwardResolve global_dns_cache addrtext
23
24peerKeyToResolvedNames :: PeerAddress -> IO [Text]
25peerKeyToResolvedNames (PeerAddress addr)
26 = reverseResolve global_dns_cache addr
27
diff --git a/Presence/Presence.hs b/Presence/Presence.hs
deleted file mode 100644
index 8cdd1cdc..00000000
--- a/Presence/Presence.hs
+++ /dev/null
@@ -1,1428 +0,0 @@
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE ExistentialQuantification #-}
3{-# LANGUAGE LambdaCase #-}
4{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE TupleSections #-}
6module Presence where
7
8import System.Directory
9import System.IO.Error
10#ifndef THREAD_DEBUG
11import Control.Concurrent
12#else
13import Control.Concurrent.Lifted.Instrument
14#endif
15
16import Control.Concurrent.STM
17import Control.Monad.Trans
18import Network.Socket ( SockAddr(..) )
19import Data.Char
20import Data.List (nub, (\\), intersect, groupBy, sort, sortBy )
21import Data.Ord (comparing )
22import Data.Monoid ((<>))
23import qualified Data.Text as Text
24import qualified Data.Text.Encoding as Text
25import Control.Monad
26import Data.Text (Text)
27import qualified Data.Map as Map
28import Data.Map (Map)
29import Control.Exception ({-evaluate,-}handle,SomeException(..))
30import System.Posix.User (getUserEntryForID,userName)
31import qualified Data.ByteString.Lazy.Char8 as L
32import qualified ConfigFiles
33import Data.Maybe
34import Data.Bits
35import Data.Int (Int8)
36import Data.XML.Types (Event)
37import System.Posix.Types (UserID,CPid)
38import Control.Applicative
39import Crypto.PubKey.Curve25519 (SecretKey,toPublic)
40
41import ControlMaybe
42import DNSCache (parseAddress, strip_brackets, withPort)
43import LockedChan (LockedChan)
44import Text.Read (readMaybe)
45import UTmp (ProcessID,users)
46import LocalPeerCred
47import XMPPServer
48import ConsoleWriter
49import ClientState
50import Util
51import qualified Connection
52 ;import Connection (PeerAddress (..), resolvePeer, reverseAddress)
53import Network.Tox.NodeId (key2id,parseNoSpamId,nospam64,NoSpamId(..),ToxProgress,ToxContact(..))
54import Crypto.Tox (decodeSecret)
55import DPut
56import DebugTag
57
58{-
59isPeerKey :: ClientAddress -> Bool
60isPeerKey k = case k of { PeerKey {} -> True ; _ -> False }
61
62isClientKey :: ClientAddress -> Bool
63isClientKey k = case k of { ClientKey {} -> True ; _ -> False }
64-}
65
66localJID :: Text -> Text -> Text -> IO Text
67localJID user "." resource = do
68 hostname <- textHostName
69 return $ user <> "@" <> hostname <> "/" <> resource
70localJID user profile resource =
71 return $ user <> "@" <> profile <> "/" <> resource
72
73-- | These hooks will be invoked in order to connect to *.tox hosts in the
74-- user's roster.
75--
76-- The parameter k is a lookup key corresponding to an XMPP client. Each
77-- unique value should be able to hold a reference to the ToxID identity which
78-- should stay online until all interested keys have run 'deactivateAccount'.
79data ToxManager k = ToxManager
80 -- | Put the given ToxID online.
81 { activateAccount :: k -> Text -> SecretKey -> IO ()
82 -- | Take the given ToxID offline (assuming no other /k/ has a claim).
83 , deactivateAccount :: k -> Text -> IO ()
84 , toxConnections :: Connection.Manager ToxProgress ToxContact
85 -- | Given a remote Tox key, return the address of a connected peer.
86 --
87 -- The arguments are our public key (in base64 format) followed by
88 -- their public key (in base64 format).
89 , resolveToxPeer :: Text -> Text -> IO (Maybe PeerAddress)
90 }
91
92type ClientProfile = Text
93
94data PresenceState status = PresenceState
95 { clients :: TVar (Map ClientAddress ClientState)
96 , clientsByUser :: TVar (Map Text LocalPresence)
97 , clientsByProfile :: TVar (Map Text LocalPresence)
98 , remotesByPeer :: TVar (Map PeerAddress
99 (Map UserName RemotePresence))
100 , server :: XMPPServer
101 , manager :: ClientProfile -> Connection.Manager status Text
102 , ckeyToChan :: TVar (Map ClientAddress Conn)
103 , pkeyToChan :: TVar (Map PeerAddress Conn)
104 , consoleWriter :: Maybe ConsoleWriter
105 , toxManager :: Maybe (ToxManager ClientAddress)
106 }
107
108
109newPresenceState :: Maybe ConsoleWriter
110 -> Maybe (PresenceState status -> ToxManager ClientAddress)
111 -> XMPPServer
112 -> (ClientProfile -> Connection.Manager status Text)
113 -> IO (PresenceState status)
114newPresenceState cw toxman sv man = atomically $ do
115 clients <- newTVar Map.empty
116 clientsByUser <- newTVar Map.empty
117 clientsByProfile <- newTVar Map.empty
118 remotesByPeer <- newTVar Map.empty
119 ckeyToChan <- newTVar Map.empty
120 pkeyToChan <- newTVar Map.empty
121 let st = PresenceState
122 { clients = clients
123 , clientsByUser = clientsByUser
124 , clientsByProfile = clientsByProfile
125 , remotesByPeer = remotesByPeer
126 , ckeyToChan = ckeyToChan
127 , pkeyToChan = pkeyToChan
128 , server = sv
129 , manager = man
130 , consoleWriter = cw
131 , toxManager = Nothing
132 }
133 return $ st { toxManager = fmap ($ st) toxman }
134
135
136nameForClient :: PresenceState stat -> ClientAddress -> IO Text
137nameForClient state k = do
138 mc <- atomically $ do
139 cmap <- readTVar (clients state)
140 return $ Map.lookup k cmap
141 case mc of
142 Nothing -> textHostName
143 Just client -> case clientProfile client of
144 "." -> textHostName
145 profile -> return profile
146
147presenceHooks :: PresenceState stat -> Map Text MUC
148 -> Int
149 -> Maybe SockAddr -- ^ client-to-server bind address
150 -> Maybe SockAddr -- ^ server-to-server bind address
151 -> XMPPServerParameters
152presenceHooks state chats verbosity mclient mpeer = XMPPServerParameters
153 { xmppChooseResourceName = chooseResourceName state
154 , xmppTellClientHisName = tellClientHisName state
155 , xmppTellMyNameToClient = nameForClient state
156 , xmppTellMyNameToPeer = \(Local addr) -> return $ addrToText addr
157 , xmppTellPeerHisName = return . peerKeyToText
158 , xmppNewConnection = newConn state
159 , xmppEOF = eofConn state
160 , xmppRosterBuddies = rosterGetBuddies state
161 , xmppRosterSubscribers = rosterGetSubscribers state
162 , xmppRosterSolicited = rosterGetSolicited state
163 , xmppRosterOthers = rosterGetOthers state
164 , xmppSubscribeToRoster = informSentRoster state
165 , xmppDeliverMessage = deliverMessage state
166 , xmppInformClientPresence = informClientPresence state
167 , xmppInformPeerPresence = informPeerPresence state
168 , xmppAnswerProbe = \k stanza chan -> answerProbe state (stanzaTo stanza) k chan
169 , xmppClientSubscriptionRequest = clientSubscriptionRequest state
170 , xmppPeerSubscriptionRequest = peerSubscriptionRequest state
171 , xmppClientInformSubscription = clientInformSubscription state
172 , xmppPeerInformSubscription = peerInformSubscription state
173 , xmppVerbosity = return verbosity
174 , xmppGroupChat = chats {- Map.singleton "chat" chat
175 { mucRoomList = return [("testroom",Just "testroom")]
176 , mucRoomOccupants = \case
177 "testroom" -> return [("fakeperson",Nothing)]
178 _ -> return []
179 , mucReservedNick = \case
180 "testroom" -> return $ Just (return . Just)
181 _ -> return Nothing
182 , mucJoinRoom = \room nick caddr stanza -> do
183 who <- tellClientHisName state caddr
184 dput XJabber $ Text.unpack who ++ " joined " ++ Text.unpack room
185 ++ " with nick: " ++ Text.unpack nick
186 -- TODO: broadcast presence to all participants.
187 -- See 7.2.3 of XEP-0045
188 -}
189 , xmppClientBind = mclient
190 , xmppPeerBind = mpeer
191 }
192
193
194data LocalPresence = LocalPresence
195 { networkClients :: Map ClientAddress ClientState
196 -- TODO: loginClients
197 }
198
199data RemotePresence = RemotePresence
200 { resources :: Map ResourceName Stanza
201 -- , localSubscribers :: Map Text ()
202 -- ^ subset of clientsByUser who should be
203 -- notified about this presence.
204 }
205
206
207
208pcSingletonNetworkClient :: ClientAddress -> ClientState -> LocalPresence
209pcSingletonNetworkClient key client =
210 LocalPresence
211 { networkClients = Map.singleton key client
212 }
213
214pcInsertNetworkClient :: ClientAddress -> ClientState -> LocalPresence -> LocalPresence
215pcInsertNetworkClient key client pc =
216 pc { networkClients = Map.insert key client (networkClients pc) }
217
218pcRemoveNewtworkClient :: ClientAddress
219 -> LocalPresence -> Maybe LocalPresence
220pcRemoveNewtworkClient key pc = if pcIsEmpty pc' then Nothing
221 else Just pc'
222 where
223 pc' = pc { networkClients = Map.delete key (networkClients pc) }
224
225pcIsEmpty :: LocalPresence -> Bool
226pcIsEmpty pc = Map.null (networkClients pc)
227
228
229
230getConsolePids :: PresenceState stat -> IO [(Text,ProcessID)]
231getConsolePids state = do
232 us <- UTmp.users
233 return $ map (\(_,tty,pid)->(lazyByteStringToText tty,pid)) us
234
235identifyTTY' :: [(Text, ProcessID)]
236 -> System.Posix.Types.UserID
237 -> L.ByteString
238 -> IO (Maybe Text, Maybe System.Posix.Types.CPid)
239identifyTTY' ttypids uid inode = ttypid
240 where ttypids' = map (\(tty,pid)->(L.fromChunks [Text.encodeUtf8 tty], pid)) ttypids
241 ttypid = fmap textify $ identifyTTY ttypids' uid inode
242 textify (tty,pid) = (fmap lazyByteStringToText tty, pid)
243
244chooseResourceName :: PresenceState stat
245 -> ClientAddress -> Remote SockAddr -> Maybe Text -> Maybe Text -> IO Text
246chooseResourceName state k (Remote addr) clientsNameForMe desired = do
247 muid <- getLocalPeerCred' addr
248 (mtty,pid) <- getTTYandPID muid
249 user <- getJabberUserForId muid
250 status <- atomically $ newTVar Nothing
251 flgs <- atomically $ newTVar 0
252 profile <- fmap (fromMaybe ".")
253 $ forM ((,) <$> clientsNameForMe <*> toxManager state) $ \(wanted_profile0,toxman) ->
254 case Text.splitAt 43 wanted_profile0 of
255 (pub,".tox") -> do
256 cdir <- ConfigFiles.configPath (L.fromChunks [Text.encodeUtf8 user]) "." ""
257#if !MIN_VERSION_directory(1,2,5)
258 let listDirectory path = filter (`notElem` [".",".."]) <$> getDirectoryContents path
259#endif
260 cfs <- map Text.pack <$> listDirectory cdir `catchIOError` (\e -> return [])
261 let profiles = filter (\f -> Text.toLower f == Text.toLower wanted_profile0) cfs
262 -- dput XMisc $ "Toxmpp profile " ++ show (user,wanted_profile0,profiles,cfs)
263 let wanted_profile = head $ profiles ++ [wanted_profile0]
264 secs <- configText ConfigFiles.getSecrets user wanted_profile
265 case secs of
266 sec:_ | Just s <- decodeSecret (Text.encodeUtf8 sec)
267 , map toLower (show $ key2id $ toPublic s) == map toLower (Text.unpack pub)
268 -> do activateAccount toxman k wanted_profile s
269 dput XMisc $ "loaded tox secret " ++ show sec
270 return wanted_profile
271 _ -> do
272 -- XXX: We should probably fail to connect when an
273 -- invalid Tox profile is used. For now, we'll
274 -- fall back to the Unix account login.
275 dput XMisc "failed to find tox secret"
276 return "."
277 ("*.tox","") -> do
278 dput XMisc $ "TODO: Match single tox key profile or generate first."
279 -- TODO: Match single tox key profile or generate first.
280 _todo
281 _ -> return "."
282 let client = ClientState { clientResource = maybe "fallback" id mtty
283 , clientUser = user
284 , clientProfile = profile
285 , clientPid = pid
286 , clientStatus = status
287 , clientFlags = flgs }
288
289 do -- forward-lookup of the buddies so that it is cached for reversing.
290 buds <- configText ConfigFiles.getBuddies (clientUser client) (clientProfile client)
291 forM_ buds $ \bud -> do
292 let (_,h,_) = splitJID bud
293 forkIO $ void $ resolvePeer (manager state $ clientProfile client) h
294
295 atomically $ do
296 modifyTVar' (clients state) $ Map.insert k client
297 let add mb = Just $ maybe (pcSingletonNetworkClient k client)
298 (pcInsertNetworkClient k client)
299 mb
300 modifyTVar' (clientsByUser state) $ Map.alter add (clientUser client)
301 modifyTVar' (clientsByProfile state) $ Map.alter add (clientProfile client)
302
303 localJID (clientUser client) (clientProfile client) (clientResource client)
304
305 where
306 getTTYandPID muid = do
307 -- us <- fmap (map (second fst) . Map.toList) . readTVarIO $ activeUsers state
308 ttypids <- getConsolePids state
309 -- let tailOf3 ((_,a),b) = (a,b)
310 (t,pid) <- case muid of
311 Just (uid,inode) -> identifyTTY' ttypids uid inode
312 Nothing -> return (Nothing,Nothing)
313 let rsc = t `mplus` fmap ( ("pid."<>) . Text.pack . show ) pid
314 return (rsc,pid)
315
316 getJabberUserForId muid =
317 maybe (return "nobody")
318 (\(uid,_) ->
319 handle (\(SomeException _) ->
320 return . (<> "uid.") . Text.pack . show $ uid)
321 $ do
322 user <- fmap userName $ getUserEntryForID uid
323 return (Text.pack user)
324 )
325 muid
326
327-- Perform action with 'ClientState' associated with the given 'ClientAddress'.
328-- If there is no associated 'ClientState', then perform the supplied fallback
329-- action.
330forClient :: PresenceState stat -> ClientAddress -> IO b -> (ClientState -> IO b) -> IO b
331forClient state k fallback f = do
332 mclient <- atomically $ do
333 cs <- readTVar (clients state)
334 return $ Map.lookup k cs
335 maybe fallback f mclient
336
337tellClientHisName :: PresenceState stat -> ClientAddress -> IO Text
338tellClientHisName state k = forClient state k fallback go
339 where
340 fallback = localJID "nobody" "." "fallback"
341 go client = localJID (clientUser client) (clientProfile client) (clientResource client)
342
343toMapUnit :: Ord k => [k] -> Map k ()
344toMapUnit xs = Map.fromList $ map (,()) xs
345
346resolveAllPeers :: Connection.Manager stat Text -> [Text] -> IO (Map PeerAddress ())
347resolveAllPeers man hosts = fmap (toMapUnit . concat) $ Prelude.mapM (fmap (take 1) . resolvePeer man) hosts
348
349
350-- Read a roster file and start trying to connect to all relevent peers.
351rosterGetStuff
352 :: (ConfigFiles.User -> ConfigFiles.Profile -> IO [L.ByteString])
353 -> PresenceState stat -> ClientAddress -> IO [Text]
354rosterGetStuff what state k = forClient state k (return [])
355 $ \client -> do
356 jids0 <- configText what (clientUser client) (clientProfile client)
357 let jids = map splitJID jids0
358 -- Using case to bring 'status' type variable to Connection.Manager into scope.
359 case state of
360 PresenceState { server = sv } -> do
361 let conns = manager state $ clientProfile client
362 -- Grok peers to associate with from the roster:
363 let isTox = do (me , ".tox") <- Just $ Text.splitAt 43 (clientProfile client)
364 return me
365 noToxUsers (u,h,r)
366 | Text.isSuffixOf ".tox" h = unsplitJID (Nothing,h,r)
367 | otherwise = unsplitJID (u,h,r)
368 forM_ jids $ \(_,host,_) -> do
369 -- We need either conns :: Connection.Manager TCPStatus Text
370 -- or toxman :: ToxManager ClientAddress
371 -- It is decided by checking hostnames for .tox ending.
372 let policySetter = fromMaybe (Connection.setPolicy conns host) $ do
373 isTox
374 toxman <- toxManager state
375 (them, ".tox") <- Just $ Text.splitAt 43 host
376 meid <- readMaybe $ Text.unpack $ Text.take 43 (clientProfile client)
377 themid <- readMaybe $ Text.unpack them
378 return $ Connection.setPolicy (toxConnections toxman)
379 (ToxContact meid themid)
380 policySetter Connection.TryingToConnect
381 return $ fromMaybe jids0 $ do isTox
382 Just $ map noToxUsers jids
383
384rosterGetBuddies :: PresenceState stat -> ClientAddress -> IO [Text]
385rosterGetBuddies state k = rosterGetStuff ConfigFiles.getBuddies state k
386
387rosterGetSolicited :: PresenceState stat -> ClientAddress -> IO [Text]
388rosterGetSolicited = rosterGetStuff ConfigFiles.getSolicited
389
390-- XXX: Should we be connecting to these peers?
391rosterGetOthers :: PresenceState stat -> ClientAddress -> IO [Text]
392rosterGetOthers = rosterGetStuff ConfigFiles.getOthers
393
394rosterGetSubscribers :: PresenceState stat -> ClientAddress -> IO [Text]
395rosterGetSubscribers = rosterGetStuff ConfigFiles.getSubscribers
396
397data Conn = Conn { connChan :: TChan Stanza
398 , auxData :: ConnectionData }
399
400-- Read config file as Text content rather than UTF8 bytestrings.
401configText :: Functor f =>
402 (ConfigFiles.User -> ConfigFiles.Profile -> f [L.ByteString])
403 -> Text -- user
404 -> Text -- profile
405 -> f [Text] -- items
406configText what u p = fmap (map lazyByteStringToText)
407 $ what (textToLazyByteString u) (Text.unpack p)
408
409getBuddies' :: Text -> Text -> IO [Text]
410getBuddies' = configText ConfigFiles.getBuddies
411getSolicited' :: Text -> Text -> IO [Text]
412getSolicited' = configText ConfigFiles.getSolicited
413
414-- | Obtain from roster all buddies and pending buddies (called solicited
415-- regardless of whether we've yet delivered a friend-request) matching the
416-- supplied side-effecting predicate.
417--
418-- Returned tuple:
419--
420-- * Bool - True if buddy (should send probe).
421-- False if solicited (should send friend-request).
422--
423-- * Maybe Username - Username field of contact.
424--
425-- * Text - Unix user who owns this roster entry.
426--
427-- * Text - Hostname as it appears in roster.
428--
429getBuddiesAndSolicited :: PresenceState stat
430 -> Text -- ^ Config profile: "." or tox host.
431 -> (Text -> IO Bool) -- ^ Return True if you want this hostname.
432 -> IO [(Bool, Maybe UserName, Text, Text)]
433getBuddiesAndSolicited state profile pred
434 -- XXX: The following O(n²) nub may be a little
435 -- too onerous.
436 = fmap nub $ do
437 cbu <- atomically $ readTVar $ clientsByUser state
438 fmap concat $ sequence $ do
439 (user,LocalPresence cmap) <- Map.toList cbu
440 (isbud, getter) <- [(True ,getBuddies' )
441 ,(False,getSolicited')]
442 return $ do
443 buds <- map splitJID <$> getter user profile
444 fmap concat $ forM buds $ \(u,h,r) -> do
445 interested <- pred h
446 if interested
447 then return [(isbud,u,user,h)]
448 else return []
449
450sendProbesAndSolicitations :: PresenceState stat -> PeerAddress -> Local SockAddr -> TChan Stanza -> IO ()
451sendProbesAndSolicitations state k (Local laddr) chan = do
452 prof <- atomically $ do
453 pktc <- readTVar (pkeyToChan state)
454 return $ maybe "." (cdProfile . auxData) $ Map.lookup k pktc
455 -- get all buddies & solicited matching k for all users
456 xs <- getBuddiesAndSolicited state prof $ \case
457 h | ".tox" `Text.isSuffixOf` h -> return False -- Tox probes/solicitations are handled in ToxToXMPP module.
458 h -> do
459 addrs <- nub <$> resolvePeer (manager state $ prof) h
460 return $ k `elem` addrs -- Roster item resolves to /k/ peer.
461 forM_ xs $ \(isbud,u,user,h) -> do
462 let make = if isbud then presenceProbe
463 else presenceSolicitation
464 toh = peerKeyToText k
465 jid = unsplitJID (u,toh,Nothing)
466 me = addrToText laddr -- xmppTellMyNameToPeer
467 from = if isbud then me -- probe from server
468 else -- solicitation from particular user
469 unsplitJID (Just user,me,Nothing)
470 stanza <- make from jid
471 -- send probes for buddies, solicitations for solicited.
472 dput XJabber $ "probing "++show k++" for: " ++ show (isbud,jid)
473 atomically $ writeTChan chan stanza
474 -- reverse xs `seq` return ()
475
476
477newConn :: PresenceState stat -> SockAddr -> ConnectionData -> TChan Stanza -> IO ()
478newConn state saddr cdta outchan =
479 case classifyConnection saddr cdta of
480 Left (pkey,laddr) -> do
481 atomically $ modifyTVar' (pkeyToChan state)
482 $ Map.insert pkey Conn { connChan = outchan
483 , auxData = cdta }
484 sendProbesAndSolicitations state pkey laddr outchan
485 Right (ckey,_) -> do
486 atomically $ modifyTVar' (ckeyToChan state)
487 $ Map.insert ckey Conn { connChan = outchan
488 , auxData = cdta }
489
490delclient :: (Alternative m, Monad m) =>
491 ClientAddress -> m LocalPresence -> m LocalPresence
492delclient k mlp = do
493 lp <- mlp
494 let nc = Map.delete k $ networkClients lp
495 guard $ not (Map.null nc)
496 return $ lp { networkClients = nc }
497
498eofConn :: PresenceState stat -> SockAddr -> ConnectionData -> IO ()
499eofConn state saddr cdta = do
500 case classifyConnection saddr cdta of
501 Left (k,_) -> do
502 h <- case cdType cdta of
503 -- TODO: This should be cached (perhaps by rewriteJIDForClient?) so that we
504 -- guarantee that the OFFLINE message matches the ONLINE message.
505 -- For now, we reverse-resolve the peer key.
506 XMPP -> -- For XMPP peers, informPeerPresence expects a textual
507 -- representation of the IP address to reverse-resolve.
508 return $ peerKeyToText k
509 Tox -> do
510 -- For Tox peers, informPeerPresence expects the actual hostname
511 -- so we will use the one that the peer told us at greeting time.
512 m <- atomically $ swapTVar (cdRemoteName cdta) Nothing
513 case m of
514 Nothing -> do
515 dput XJabber $ "BUG: Tox peer didn't inform us of its name."
516 -- The following fallback behavior is probably wrong.
517 return $ peerKeyToText k
518 Just toxname -> return toxname
519 -- ioToSource terminated.
520 --
521 -- dhtd: Network.Socket.getAddrInfo
522 -- (called with preferred socket type/protocol: AddrInfo
523 -- { addrFlags = [AI_NUMERICHOST], addrFamily = AF_UNSPEC
524 -- , addrSocketType = NoSocketType, addrProtocol = 0
525 -- , addrAddress = <assumed to be undefined>
526 -- , addrCanonName = <assumed to be undefined>}
527 -- , host name: Just "DdhbLjiwaV0GAiGKgesNPbvj2TbhrBHEWEEc5icfvQN.tox"
528 -- , service name: Just "0")
529 -- : does not exist (Name or service not known)
530
531 jids <- atomically $ do
532 rbp <- readTVar (remotesByPeer state)
533 return $ do
534 umap <- maybeToList $ Map.lookup k rbp
535 (u,rp) <- Map.toList umap
536 r <- Map.keys (resources rp)
537 let excludeEmpty "" = Nothing
538 excludeEmpty x = Just x
539 return $ unsplitJID (excludeEmpty u, h, excludeEmpty r)
540 -- EOF PEER PeerAddress [d768:82dd:3e86:a6ba:8fb3:6f9c:6327:75d8%4236342772]:0:
541 -- ["@[d768:82dd:3e86:a6ba:8fb3:6f9c:6327:75d8%4236342772]/"]
542 -- dput XJabber $ "EOF PEER "++show k++": "++show jids
543 forM_ jids $ \jid -> do
544 stanza <- makePresenceStanza "jabber:client" (Just jid) Offline
545 informPeerPresence state k stanza
546 Right (k,_) -> do
547 forClient state k (return ()) $ \client -> do
548 forM_ (toxManager state) $ \toxman -> do
549 case Text.splitAt 43 (clientProfile client) of
550 (pub,".tox") -> deactivateAccount toxman k (clientProfile client)
551 _ -> return ()
552 stanza <- makePresenceStanza "jabber:server" Nothing Offline
553 informClientPresence state k stanza
554 atomically $ do
555 modifyTVar' (clientsByUser state) $ Map.alter (delclient k) (clientUser client)
556 modifyTVar' (clientsByProfile state) $ Map.alter (delclient k) (clientProfile client)
557 atomically $ case classifyConnection saddr cdta of
558 Left (pkey,_) -> modifyTVar' (pkeyToChan state) $ Map.delete pkey
559 Right (ckey,_) -> modifyTVar' (ckeyToChan state) $ Map.delete ckey
560
561{-
562parseRemoteAddress :: Text -> IO (Maybe (Remote SockAddr))
563parseRemoteAddress s = fmap Remote <$> parseAddress s
564-}
565
566-- This attempts to reverse resolve a peers address to give the human-friendly
567-- domain name as it appears in the roster. It prefers host names that occur
568-- in the given list of JIDs, but will fall back to any reverse-resolved name
569-- and if it was unable to reverse the address, it will yield an ip address.
570peerKeyToResolvedName :: Connection.Manager s Text -> [Text] -> PeerAddress -> IO Text
571peerKeyToResolvedName man buds pk = do
572 ns <- reverseAddress man pk
573 let hs = map (\jid -> let (_,h,_)=splitJID jid in h) buds
574 ns' = sortBy (comparing $ not . flip elem hs) ns
575 return $ fromMaybe (peerKeyToText pk) (listToMaybe ns')
576
577
578-- | The given address is taken to be the local address for the socket this JID
579-- came in on. The returned JID parts are suitable for unsplitJID to create a
580-- valid JID for communicating to a client. The returned Bool is True when the
581-- host part refers to this local host (i.e. it equals the given SockAddr).
582-- If there are multiple results, it will prefer one which is a member of the
583-- given list in the last argument.
584rewriteJIDForClient :: Connection.Manager s Text -> Local SockAddr -> Text -> [Text] -> IO (Bool,(Maybe Text,Text,Maybe Text))
585rewriteJIDForClient man (Local laddr) jid buds = do
586 let (n,h,r) = splitJID jid
587 -- dput XJabber $ "rewriteJIDForClient parsing " ++ show h
588 maddr <- parseAddress (strip_brackets h)
589 fromMaybe (return (False,(n,ip6literal h,r))) $ maddr <&> \saddr -> do
590 let mine = sameAddress laddr saddr
591 h' <- if mine then textHostName
592 else peerKeyToResolvedName man buds (addrToPeerKey $ Remote saddr)
593 return (mine,(n,h',r))
594
595-- Given a local address and an IP-address JID, we return True if the JID is
596-- local, False otherwise. Additionally, a list of equivalent hostname JIDS
597-- are returned.
598multiplyJIDForClient :: Connection.Manager s Text -> ClientAddress -> Text -> IO (Bool,[(Maybe Text,Text,Maybe Text)])
599multiplyJIDForClient man k jid = do
600 let (n,h,r) = splitJID jid
601 -- dput XJabber $ "multiplyJIDForClient parsing " ++ show h
602 maddr <- parseAddress (strip_brackets h)
603 fromMaybe (return (False,[(n,ip6literal h,r)])) $ maddr <&> \saddr -> do
604 let Local laddr = addrFromClientKey k
605 mine = sameAddress laddr saddr
606 names <- if mine then fmap (:[]) textHostName
607 else reverseAddress man (addrToPeerKey $ Remote saddr)
608 return (mine,map (\h' -> (n,h',r)) names)
609
610
611guardPortStrippedAddress :: Text -> Local SockAddr -> IO (Maybe ())
612guardPortStrippedAddress h (Local laddr) = do
613 -- dput XJabber $ "guardPortStrippedAddress parsing " ++ show h
614 maddr <- fmap (fmap (`withPort` 0)) $ parseAddress (strip_brackets h)
615 let laddr' = laddr `withPort` 0
616 return $ maddr >>= guard . (==laddr')
617
618
619-- | Accepts a textual representation of a domainname
620-- JID suitable for client connections, and returns the
621-- coresponding ipv6 address JID suitable for peers paired
622-- with a PeerAddress with the address part of that JID in
623-- binary form. If no suitable address could be resolved
624-- for the given name, Nothing is returned.
625rewriteJIDForPeer :: Connection.Manager s Text -> Text -> IO (Maybe (Text,PeerAddress))
626rewriteJIDForPeer man jid = do
627 let (n,h,r) = splitJID jid
628 maddr <- fmap listToMaybe $ resolvePeer man h
629 return $ flip fmap maddr $ \addr ->
630 let h' = peerKeyToText addr
631 to' = unsplitJID (n,h',r)
632 in (to',addr)
633
634deliverToConsole :: PresenceState stat -> IO () -> Stanza -> IO ()
635deliverToConsole PresenceState{ consoleWriter = Just cw } fail msg = do
636 did1 <- writeActiveTTY cw msg
637 did2 <- writeAllPty cw msg
638 if not (did1 || did2) then fail else return ()
639deliverToConsole _ fail _ = fail
640
641-- | deliver <message/> or error stanza
642deliverMessage :: PresenceState stat
643 -> IO ()
644 -> StanzaWrap (LockedChan Event)
645 -> IO ()
646deliverMessage state fail msg =
647 case stanzaOrigin msg of
648 ClientOrigin senderk _ -> do
649 -- Case 1. Client -> Peer
650 mto <- join $ atomically $ do
651 mclient <- Map.lookup senderk <$> readTVar (clients state)
652 return $ do
653 dput XJabber $ "deliverMessage: to="++show (stanzaTo msg,fmap clientProfile mclient)
654 fromMaybe -- Resolve XMPP peer.
655 (fmap join $ mapM (uncurry $ rewriteJIDForPeer . manager state)
656 $ (,) <$> (clientProfile <$> mclient) <*> stanzaTo msg)
657 $ do
658 client <- mclient
659 to <- stanzaTo msg
660 let (mu,th,rsc) = splitJID to
661 (toxman,me,_) <- weAreTox state client th
662 return $ do
663 dput XJabber $ "deliverMessage: weAreTox="++show me
664 -- In case the client sends us a lower-cased version of the base64
665 -- tox key hostname, we resolve it by comparing it with roster entries.
666 xs <- getBuddiesAndSolicited state (clientProfile client) $ \case
667 rh | (_,".tox") <- Text.splitAt 43 rh
668 , Text.toLower rh == Text.toLower th
669 -> return True
670 _ -> return False
671 fmap join $ forM (listToMaybe xs) $ \(_,rmu,_,h) -> do
672 let (them,_) = Text.splitAt 43 h
673 maddr <- resolveToxPeer toxman me them
674 let to' = unsplitJID (mu,h,rsc)
675 return $ fmap (to',) maddr
676 fromMaybe (do dput XJabber $ "Unable to resolve "++show (stanzaTo msg)
677 fail {- reverse lookup failure -})
678 $ mto <&> \(to',k) -> do
679 chans <- atomically $ readTVar (pkeyToChan state)
680 fromMaybe (do dput XJabber $ "Peer unavailable: "++ show k
681 fail)
682 $ (Map.lookup k chans) <&> \conn -> do
683 -- original 'from' address is discarded.
684 from' <- forClient state senderk (return Nothing)
685 $ return . Just . clientJID conn
686 -- dup <- atomically $ cloneStanza (msg { stanzaTo=Just to', stanzaFrom=Just from' })
687 let dup = (msg { stanzaTo=Just to', stanzaFrom=from' })
688 sendModifiedStanzaToPeer dup (connChan conn)
689 PeerOrigin senderk _ -> do
690 (pchans,cchans) <- atomically $ do
691 pc <- readTVar (pkeyToChan state)
692 cc <- readTVar (ckeyToChan state)
693 return (pc,cc)
694 fromMaybe (do dput XJabber $ "Unknown peer " ++ show senderk
695 fail)
696 $ Map.lookup senderk pchans
697 <&> \(Conn { connChan = sender_chan
698 , auxData = ConnectionData (Left laddr) ctyp cprof _ }) -> do
699 fromMaybe (do dput XJabber $ "Message missing \"to\" attribute."
700 fail)
701 $ (stanzaTo msg) <&> \to -> do
702 (mine,(n,h,r)) <- case (ctyp,cprof) of
703 (Tox,prof) -> let (n,h,r) = splitJID to
704 in return ( h==prof, (n,h,r) )
705 _ -> rewriteJIDForClient (manager state cprof) laddr to []
706 if not mine then do dput XJabber $ "Address mis-match " ++ show (laddr,to)
707 fail
708 else do
709 let to' = unsplitJID (n,h,r)
710 let (cmapVar,ckey) = case ctyp of
711 Tox -> (clientsByProfile state , Just cprof )
712 XMPP -> (clientsByUser state , n )
713 cmap <- atomically . readTVar $ cmapVar
714 chans <- fmap (fromMaybe []) $ do
715 forM (ckey >>= flip Map.lookup cmap) $ \presence_container -> do
716 let ks = Map.keys (networkClients presence_container)
717 chans = do
718 (k,client) <- Map.toList $ networkClients presence_container
719 chan <- maybeToList $ Map.lookup k cchans
720 return (clientProfile client, clientUser client, chan)
721 forM chans $ \(profile,user,chan) -> do
722 buds <- configText ConfigFiles.getBuddies user profile
723 from' <- case ctyp of
724 Tox -> return $ stanzaFrom msg
725 XMPP -> do
726 forM (stanzaFrom msg) $ \from -> do
727 (_,trip) <- rewriteJIDForClient (manager state cprof) laddr from buds
728 return $ unsplitJID trip
729 to' <- case ctyp of
730 XMPP -> return $ stanzaTo msg
731 Tox -> return $ Just $ unsplitJID (Just user, profile, Nothing)
732 return (from',chan)
733 dput XJabber $ "chan count: " ++ show (length chans)
734 if null chans then when (ctyp == XMPP) $ do
735 forM_ (stanzaFrom msg) $ \from -> do
736 from' <- do
737 -- Fallback to "." profile when no clients.
738 buds <- maybe (return [])
739 (\n -> configText ConfigFiles.getBuddies n ".")
740 n
741 (_,trip) <- rewriteJIDForClient (manager state cprof) laddr from buds
742 return . Just $ unsplitJID trip
743 let msg' = msg { stanzaTo=Just to'
744 , stanzaFrom=from' }
745 deliverToConsole state fail msg'
746 else do
747 forM_ chans $ \(from',Conn { connChan=chan}) -> do
748 -- TODO: Cloning isn't really necessary unless there are multiple
749 -- destinations and we should probably transition to minimal cloning,
750 -- or else we should distinguish between announcable stanzas and
751 -- consumable stanzas and announcables use write-only broadcast
752 -- channels that must be cloned in order to be consumed.
753 -- For now, we are doing redundant cloning.
754 let msg' = msg { stanzaTo=Just to'
755 , stanzaFrom=from' }
756 dup <- cloneStanza msg'
757 sendModifiedStanzaToClient dup
758 chan
759
760
761setClientFlag :: PresenceState stat -> ClientAddress -> Int8 -> IO ()
762setClientFlag state k flag =
763 atomically $ do
764 cmap <- readTVar (clients state)
765 forM_ (Map.lookup k cmap) $ \client -> do
766 setClientFlag0 client flag
767
768setClientFlag0 :: ClientState -> Int8 -> STM ()
769setClientFlag0 client flag =
770 modifyTVar' (clientFlags client) (\flgs -> flgs .|. flag)
771
772informSentRoster :: PresenceState stat -> ClientAddress -> IO ()
773informSentRoster state k = do
774 setClientFlag state k cf_interested
775
776
777subscribedPeers :: Connection.Manager s Text -> Text -> Text -> IO [PeerAddress]
778subscribedPeers man user profile = do
779 jids <- configText ConfigFiles.getSubscribers user profile
780 let hosts = map ((\(_,h,_)->h) . splitJID) jids
781 fmap Map.keys $ resolveAllPeers man hosts
782
783-- | this JID is suitable for peers, not clients.
784clientJID :: Conn -> ClientState -> Text
785clientJID con client = unsplitJID ( Just $ clientUser client
786 , either (\(Local a) -> addrToText a) -- my host name, for peers
787 (error $ unlines [ "clientJID wrongly used for client connection!"
788 , "TODO: my host name for clients? nameForClient? localJID?"])
789 $ cdAddr $ auxData con
790 , Just $ clientResource client)
791
792-- | Send presence notification to subscribed peers.
793-- Note that a full JID from address will be added to the
794-- stanza if it is not present.
795informClientPresence :: PresenceState stat
796 -> ClientAddress -> StanzaWrap (LockedChan Event) -> IO ()
797informClientPresence state k stanza = do
798 forClient state k (return ()) $ \client -> do
799 informClientPresence0 state (Just k) client stanza
800
801informClientPresence0 :: PresenceState stat
802 -> Maybe ClientAddress
803 -> ClientState
804 -> StanzaWrap (LockedChan Event)
805 -> IO ()
806informClientPresence0 state mbk client stanza = do
807 dup <- cloneStanza stanza
808 atomically $ writeTVar (clientStatus client) $ Just dup
809 is_avail <- atomically $ clientIsAvailable client
810 when (not is_avail) $ do
811 atomically $ setClientFlag0 client cf_available
812 maybe (return ()) (sendCachedPresence state) mbk
813 addrs <- subscribedPeers (manager state $ clientProfile client) (clientUser client) (clientProfile client)
814 dput XJabber $ "informClientPresence(subscribedPeers) "++show (clientProfile client,addrs)
815 ktc <- atomically $ readTVar (pkeyToChan state)
816 let connected = mapMaybe (flip Map.lookup ktc) addrs
817 forM_ connected $ \con -> do
818 let from' = clientJID con client
819 mto <- maybe (return Nothing)
820 (fmap (fmap fst) . rewriteJIDForPeer (manager state $ clientProfile client))
821 (stanzaTo stanza)
822 dup <- cloneStanza stanza
823 sendModifiedStanzaToPeer dup { stanzaFrom = Just from'
824 , stanzaTo = mto }
825 (connChan con)
826
827informPeerPresence :: PresenceState stat
828 -> PeerAddress
829 -> StanzaWrap (LockedChan Event)
830 -> IO ()
831informPeerPresence state k stanza = do
832 -- Presence must indicate full JID with resource...
833 dput XJabber $ "xmppInformPeerPresence checking from address..."
834 forM_ (stanzaFrom stanza) $ \from -> do
835 let (muser0,h,mresource0) = splitJID from
836 -- We'll allow the case that user and resource are simultaneously
837 -- absent. They will be stored in the remotesByPeer map using the
838 -- empty string. This is to accommodate the tox protocol which didn't
839 -- anticipate a single peer would have multiple users or front-ends.
840 (muser,mresource) = case (muser0,mresource0) of
841 (Nothing,Nothing) -> (Just "", Just "")
842 _ -> (muser0,mresource0)
843 dput XJabber $ "xmppInformPeerPresence from = " ++ show from
844 -- forM_ mresource $ \resource -> do
845 forM_ muser $ \user -> do
846
847 clients <- atomically $ do
848
849 -- Update remotesByPeer...
850 rbp <- readTVar (remotesByPeer state)
851 let umap = maybe Map.empty id $ Map.lookup k rbp
852 rp = case (presenceShow $ stanzaType stanza) of
853 Offline ->
854 maybe Map.empty
855 (\resource ->
856 maybe (Map.empty)
857 (Map.delete resource . resources)
858 $ Map.lookup user umap)
859 mresource
860
861 _ ->maybe Map.empty
862 (\resource ->
863 maybe (Map.singleton resource stanza)
864 (Map.insert resource stanza . resources )
865 $ Map.lookup user umap)
866 mresource
867 umap' = Map.insert user (RemotePresence rp) umap
868
869 fromMaybe (return []) $ case presenceShow $ stanzaType stanza of
870 Offline -> Just ()
871 _ -> mresource >> Just ()
872 <&> \_ -> do
873 writeTVar (remotesByPeer state) $ Map.insert k umap' rbp
874 -- TODO: Store or delete the stanza (remotesByPeer)
875
876 -- all clients, we'll filter available/authorized later
877
878 ktc <- readTVar (ckeyToChan state)
879 cmap <- readTVar (clients state)
880 return $ do
881 (ck,client) <- Map.toList cmap
882 con <- maybeToList $ Map.lookup ck ktc
883 return (ck,con,client)
884 dput XJabber $ "xmppInformPeerPresence (length clients="++show (length clients)++")"
885 (ctyp,cprof) <- atomically $ do
886 mconn <- Map.lookup k <$> readTVar (pkeyToChan state)
887 return $ fromMaybe (XMPP,".") $ do
888 ConnectionData _ ctyp cprof _ <- auxData <$> mconn
889 return (ctyp,cprof)
890 forM_ clients $ \(ck,con,client) -> do
891 -- (TODO: appropriately authorized clients only.)
892 -- For now, all "available" clients (available = sent initial presence)
893 is_avail <- atomically $ clientIsAvailable client
894 when is_avail $ do
895 -- reversing for client: ("DdhbLjiwaV0GAiGKgesNPbvj2TbhrBHEWEEc5icfvQN.tox"
896 -- ,XMPP,"OrjBG.GyWuQhGc1pb0KssgmYAocohFh35Vx8mREC9Nu.tox",".")
897 dput XJabber $ "reversing for client: " ++ show (from,ctyp,clientProfile client,cprof)
898 froms <- case ctyp of
899 Tox | clientProfile client == cprof -> return [from]
900 _ -> do -- flip (maybe $ return [from]) k . const $ do
901 (_,trip) <- multiplyJIDForClient (manager state $ clientProfile client) ck from
902 return (map unsplitJID trip)
903
904 dput XJabber $ "sending to client: " ++ show (stanzaType stanza,froms)
905 forM_ froms $ \from' -> do
906 dup <- cloneStanza stanza
907 sendModifiedStanzaToClient (dup { stanzaFrom=Just from' })
908 (connChan con)
909
910consoleClients :: PresenceState stat -> STM (Map Text ClientState)
911consoleClients PresenceState{ consoleWriter = Just cw } = readTVar (cwClients cw)
912consoleClients _ = return Map.empty
913
914
915answerProbe :: PresenceState stat -> Maybe Text -> PeerAddress -> TChan Stanza -> IO ()
916answerProbe state mto k chan = do
917 -- dput XJabber $ "answerProbe! " ++ show (stanzaType stanza)
918 ktc <- atomically $ readTVar (pkeyToChan state)
919 muser <- fmap join $ sequence $ do
920 to <- mto
921 conn <- Map.lookup k ktc
922 let (mu,h,_) = splitJID to -- TODO: currently resource-id is ignored on presence
923 -- probes. Is this correct? Check the spec.
924 Left laddr = cdAddr $ auxData conn
925 ch = addrToText a where Local a = laddr
926 u <- mu
927 Just $ do
928 guardPortStrippedAddress h laddr
929 <&> maybe Nothing (\_ -> Just (u,conn,ch))
930
931 forM_ muser $ \(u,conn,ch) -> do
932
933 profiles <- releventProfiles (cdType $ auxData conn) u
934 forM_ profiles $ \profile -> do
935
936 -- only subscribed peers should get probe replies
937 let man = manager state $ cdProfile $ auxData conn
938 resolved_subs <- resolvedFromRoster man ConfigFiles.getSubscribers u profile
939 let gaddrs = groupBy sameHost (sort resolved_subs)
940 sameHost a b = (snd a == snd b) -- (==) `on` snd
941 whitelist = do
942 xs <- gaddrs -- group of subscribed jids on the same host
943 x <- take 1 xs -- the host from the group
944 guard $ snd x==k -- only hosts matching the key /k/
945 mapMaybe fst xs -- all users subscribed at the remote peer /k/
946
947 -- TODO: notify remote peer that they are unsubscribed?
948 -- reply <- makeInformSubscription "jabber:server" to from False
949 when (not $ null whitelist) $ do
950
951 replies <- catMaybes <$> do -- runTraversableT $ do
952 cbu <- atomically $ readTVar (clientsByUser state) -- Map Text LocalPresence
953 let lpres = maybeToList $ Map.lookup u cbu
954 cw <- atomically $ consoleClients state -- Map Text ClientState
955 forM ((lpres >>= Map.elems . networkClients) ++ Map.elems cw) $ \clientState -> do
956 -- liftIOMaybe :: IO (Maybe a) -> TraversableT [] IO a
957 mstanza <- atomically $ readTVar (clientStatus clientState)
958 forM mstanza $ \stanza0 -> do
959 stanza <- cloneStanza stanza0
960 let jid = unsplitJID (Just $ clientUser clientState
961 , ch
962 ,Just $ clientResource clientState)
963 return stanza { stanzaFrom = Just jid
964 , stanzaType = (stanzaType stanza)
965 { presenceWhiteList = whitelist }
966 }
967
968 forM_ replies $ \reply -> do
969 sendModifiedStanzaToPeer reply chan
970
971 -- if no presence, send offline message
972 when (null replies) $ do
973 let jid = unsplitJID (Just u,ch,Nothing)
974 pstanza <- makePresenceStanza "jabber:server" (Just jid) Offline
975 atomically $ writeTChan (connChan conn) pstanza
976
977-- Send friend requests and remote presences stored in remotesByPeer to XMPP
978-- clients.
979sendCachedPresence :: PresenceState stat -> ClientAddress -> IO ()
980sendCachedPresence state k = do
981 forClient state k (return ()) $ \client -> do
982 rbp <- atomically $ readTVar (remotesByPeer state)
983 jids <- configText ConfigFiles.getBuddies (clientUser client) (clientProfile client)
984 let hosts = map ((\(_,h,_)->h) . splitJID) jids
985 addrs <- resolveAllPeers (manager state $ clientProfile client) hosts
986 let onlines = rbp `Map.intersection` addrs
987 mcon <- atomically $ do ktc <- readTVar (ckeyToChan state)
988 return $ Map.lookup k ktc
989 forM_ mcon $ \con -> do
990 forM_ (Map.toList onlines) $ \(pk, umap) -> do
991 forM_ (Map.toList umap) $ \(user,rp) -> do
992 let h = peerKeyToText pk
993 forM_ (Map.toList $ resources rp) $ \(resource,stanza) -> do
994 let jid = unsplitJID (Just user,h,Just resource)
995 (mine,js) <- multiplyJIDForClient (manager state $ clientProfile client) k jid
996 forM_ js $ \jid -> do
997 let from' = unsplitJID jid
998 dup <- cloneStanza stanza
999 sendModifiedStanzaToClient (dup { stanzaFrom=Just from' })
1000 (connChan con)
1001
1002 pending <- configText ConfigFiles.getPending (clientUser client) (clientProfile client)
1003 hostname <- nameForClient state k
1004 forM_ pending $ \pending_jid -> do
1005 let cjid = unsplitJID ( Just $ clientUser client
1006 , hostname
1007 , Nothing )
1008 ask <- presenceSolicitation pending_jid cjid
1009 sendModifiedStanzaToClient ask (connChan con)
1010
1011 -- Note: relying on self peer connection to send
1012 -- send local buddies.
1013 return ()
1014
1015addToRosterFile ::
1016 Connection.Manager s Text
1017 -> (ConfigFiles.User
1018 -> ConfigFiles.Profile
1019 -> (L.ByteString -> IO (Maybe L.ByteString))
1020 -> Maybe L.ByteString
1021 -> t1)
1022 -> Text -- user
1023 -> Text -- profile
1024 -> Text -> [PeerAddress] -> t1
1025addToRosterFile man doit whose profile to addrs =
1026 modifyRosterFile man doit whose profile to addrs True False
1027
1028removeFromRosterFile ::
1029 Connection.Manager s Text
1030 -> (ConfigFiles.User
1031 -> ConfigFiles.Profile
1032 -> (L.ByteString -> IO (Maybe L.ByteString))
1033 -> Maybe L.ByteString
1034 -> t1)
1035 -> Text -- user
1036 -> Text -- profile
1037 -> Text -> [PeerAddress] -> t1
1038removeFromRosterFile man doit whose profile to addrs =
1039 modifyRosterFile man doit whose profile to addrs False False
1040
1041-- | Sanity-checked roster file manipulation. Primarily, this function handles
1042-- hostname aliases.
1043modifyRosterFile ::
1044 Connection.Manager s Text
1045 -> (ConfigFiles.User
1046 -> ConfigFiles.Profile
1047 -> (L.ByteString -> IO (Maybe L.ByteString))
1048 -> Maybe L.ByteString
1049 -> t1) -- ^ Lower-level modification function
1050 -- indicating which file is being modified.
1051 -- Valid choices from ConfigFiles module:
1052 --
1053 -- * modifySolicited
1054 --
1055 -- * modifyBuddies
1056 --
1057 -- * modifyPending
1058 --
1059 -- * modifySubscribers
1060 -> Text -- ^ user
1061 -> Text -- ^ profile
1062 -> Text -- ^ JID that will be added or removed a hostname
1063 -> [PeerAddress] -- ^ Alias addresses for hostname in the JID.
1064 -> Bool -- ^ True if adding, otherwise False
1065 -> Bool -- ^ True to allow deleting all users at a host.
1066 -> t1
1067modifyRosterFile man doit whose profile to addrs bAdd bWildCard = do
1068 let (mu,_,_) = splitJID to
1069 -- For each jid in the file, this function will decide whether to keep
1070 -- it (possibly modified) which is indicated by Just _ or to remove the
1071 -- item from the file which is indicated by Nothing.
1072 cmp :: L.ByteString -> IO (Maybe L.ByteString)
1073 cmp jid = do
1074 let (msu,stored_h,mr) = splitJID (lazyByteStringToText jid)
1075 keep = return (Just jid) :: IO (Maybe L.ByteString)
1076 delete = return Nothing :: IO (Maybe L.ByteString)
1077 iocheck = do
1078 stored_addrs <- resolvePeer man stored_h -- TODO: don't resolve .tox peers.
1079 case stored_addrs of
1080 [] -> keep -- do not delete if failed to resolve
1081 xs | null (xs \\ addrs) -> delete -- hostname alias, delete
1082 _ -> keep
1083 fmap join $ sequence $ do
1084 guard $ isNothing mr -- delete if resource specified in file.
1085 if mu == msu || bWildCard
1086 then Just iocheck -- do not delete unless hostname alias
1087 else Just keep -- do not delete if user field doesn't match.
1088 doit (textToLazyByteString whose) (Text.unpack profile)
1089 cmp
1090 (guard bAdd >> Just (textToLazyByteString to))
1091
1092
1093clientSubscriptionRequest :: PresenceState stat -> IO () -> ClientAddress -> Stanza -> TChan Stanza -> IO ()
1094clientSubscriptionRequest state fail k stanza chan = do
1095 forClient state k fail $ \client -> do
1096 fromMaybe fail $ (splitJID <$> stanzaTo stanza) <&> \(mu,h,_) -> do
1097 dput XJabber $ "Forwarding solicitation to peer"
1098 let to0 = unsplitJID (mu,h,Nothing) -- deleted resource
1099 cuser = clientUser client
1100 cprof = clientProfile client
1101 man = manager state cprof
1102 mto = if ".tox" `Text.isSuffixOf` cprof
1103 then case parseNoSpamId to0 of
1104 Right toxjid@(NoSpamId nspam _) -> Just ( Text.pack $ '$' : nospam64 nspam
1105 , Text.pack $ show toxjid
1106 , return [] )
1107 Left _ | Text.isSuffixOf ".tox" h -> Nothing
1108 Left _ | Text.all isHexDigit h
1109 && Text.length h == 76 -> Nothing
1110 Left _ -> fmap (\u -> (u, to0 ,resolvePeer man h)) mu
1111 else fmap (\u -> (u, to0 ,resolvePeer man h)) mu
1112 fromMaybe fail $ mto <&> \(u,to,resolv) -> do
1113 -- add to-address to from's solicited
1114 dput XJabber $ unlines [ "to0=" ++ Text.unpack to0
1115 , "to=" ++ show (Text.unpack to) ]
1116 addrs <- resolv
1117 addToRosterFile man ConfigFiles.modifySolicited cuser cprof to addrs
1118 removeFromRosterFile man ConfigFiles.modifyBuddies cuser cprof to addrs
1119 resolved_subs <- resolvedFromRoster man ConfigFiles.getSubscribers cuser cprof
1120 let is_subscribed = not . null $ [ (mu, a) | a <- addrs ]
1121 `intersect` resolved_subs
1122 -- subscribers: "from"
1123 -- buddies: "to"
1124
1125 case state of
1126 PresenceState { server = svVar } -> do
1127
1128 (cktc,pktc,(sv,conns)) <- atomically $ do
1129 cktc <- readTVar $ ckeyToChan state
1130 pktc <- readTVar $ pkeyToChan state
1131 return (cktc,pktc,(server state,man))
1132
1133 -- Update roster for each client.
1134 case stanzaType stanza of
1135 PresenceRequestSubscription True -> do
1136 hostname <- nameForClient state k
1137 let cjid = unsplitJID (Just $ clientUser client, hostname,Nothing)
1138 chans <- clientCons state cktc (clientUser client)
1139 forM_ chans $ \( Conn { connChan=chan }, client ) -> do
1140 -- roster update ask="subscribe"
1141 update <- myMakeRosterUpdate (clientProfile client) cjid to
1142 [ ("ask","subscribe")
1143 , if is_subscribed then ("subscription","from")
1144 else ("subscription","none")
1145 ]
1146 sendModifiedStanzaToClient update chan
1147 when (to /= to0) $ do
1148 removal <- myMakeRosterUpdate (clientProfile client) cjid to0
1149 [ ("subscription","remove") ]
1150 sendModifiedStanzaToClient removal chan
1151 _ -> return ()
1152
1153 -- Send friend request to peer.
1154 let dsts = pktc `Map.intersection` toMapUnit addrs
1155 forM_ (Map.toList dsts) $ \(pk,con) -> do
1156 -- if already connected, send solicitation ...
1157 -- let from = clientJID con client
1158 let Left laddr = cdAddr $ auxData con
1159 from = unsplitJID ( Just $ clientUser client
1160 , (\(Local a) -> addrToText a) $ laddr
1161 , Nothing )
1162 mb <- rewriteJIDForPeer (manager state $ cdProfile $ auxData con) to
1163 forM_ mb $ \(to',addr) -> do
1164 dup <- cloneStanza stanza
1165 sendModifiedStanzaToPeer (dup { stanzaTo = Just to'
1166 , stanzaFrom = Just from })
1167 (connChan con)
1168 let policySetter = fromMaybe (Connection.setPolicy conns h) $ do
1169 (toxman,_,_) <- weAreTox state client h
1170 meid <- readMaybe $ Text.unpack $ Text.take 43 (clientProfile client)
1171 themid <- readMaybe $ Text.unpack h
1172 Just $ Connection.setPolicy (toxConnections toxman) (ToxContact meid themid)
1173 -- Add peer if we are not already associated ...
1174 policySetter Connection.TryingToConnect
1175
1176weAreTox :: PresenceState stat -> ClientState -> Text -> Maybe (ToxManager ClientAddress,Text{- me -},Text{- them -})
1177weAreTox state client h = do
1178 toxman <- toxManager state
1179 (me , ".tox") <- Just $ Text.splitAt 43 (clientProfile client)
1180 (them, ".tox") <- Just $ Text.splitAt 43 h
1181 return (toxman,me,them)
1182
1183resolvedFromRoster
1184 :: Connection.Manager s Text
1185 -> (ConfigFiles.User -> ConfigFiles.Profile -> IO [L.ByteString])
1186 -> UserName -> Text -> IO [(Maybe UserName, PeerAddress)]
1187resolvedFromRoster man doit u profile = concat <$> do
1188 subs <- configText doit u profile
1189 forM (splitJID `fmap` subs) $ \(mu,h,_) -> do
1190 addrs <- fmap nub $ resolvePeer man h
1191 return $ map (mu,) addrs
1192
1193clientCons :: PresenceState stat
1194 -> Map ClientAddress t -> Text -> IO [(t, ClientState)]
1195clientCons state ktc u = map snd <$> clientCons' state ktc u
1196
1197clientCons' :: PresenceState stat
1198 -> Map ClientAddress t -> Text -> IO [(ClientAddress,(t, ClientState))]
1199clientCons' state ktc u = do
1200 mlp <- atomically $ do
1201 cmap <- readTVar $ clientsByUser state
1202 return $ Map.lookup u cmap
1203 let ks = do lp <- maybeToList mlp
1204 Map.toList (networkClients lp)
1205 doit (k,client) = do
1206 con <- Map.lookup k ktc
1207 return (k,(con,client))
1208 return $ mapMaybe doit ks
1209
1210releventProfiles :: ConnectionType -> Text -> IO [Text]
1211releventProfiles XMPP _ = return ["."]
1212releventProfiles ctyp user = do
1213 -- TODO: Return all the ".tox" profiles that a user has under his
1214 -- .presence/ directory.
1215 return []
1216
1217peerSubscriptionRequest :: PresenceState stat -> IO () -> PeerAddress -> Stanza -> TChan Stanza -> IO ()
1218peerSubscriptionRequest state fail k stanza chan = do
1219 dput XJabber $ "Handling pending subscription from remote"
1220 fromMaybe fail $ (stanzaFrom stanza) <&> \from -> do
1221 fromMaybe fail $ (stanzaTo stanza) <&> \to -> do
1222 let (mto_u,h,_) = splitJID to
1223 (mfrom_u,from_h,_) = splitJID from
1224 to <- return $ unsplitJID (mto_u,h,Nothing) -- delete resource
1225 from <- return $ unsplitJID (mfrom_u,from_h,Nothing) -- delete resource
1226 (pktc,cktc,cmap) <- atomically $ do
1227 cktc <- readTVar (ckeyToChan state)
1228 pktc <- readTVar (pkeyToChan state)
1229 cmap <- readTVar (clients state)
1230 return (pktc,cktc,cmap)
1231 fromMaybe fail $ (Map.lookup k pktc)
1232 <&> \Conn { auxData=ConnectionData (Left laddr) ctyp profile _ } -> do
1233 (mine,totup) <- case (ctyp,profile) of
1234 (Tox,p) -> let (u,h,r) = splitJID to
1235 in return ( h == p, (u,h,r) )
1236 _ -> rewriteJIDForClient (manager state profile) laddr to []
1237 if not mine then fail else do
1238 (_,fromtup) <- rewriteJIDForClient (manager state profile) laddr from []
1239 fromMaybe fail $ mto_u <&> \u -> do
1240 fromMaybe fail $ mfrom_u <&> \from_u -> do
1241 resolved_subs <- resolvedFromRoster (manager state profile) ConfigFiles.getSubscribers u profile
1242 let already_subscribed = elem (mfrom_u,k) resolved_subs
1243 is_wanted = case stanzaType stanza of
1244 PresenceRequestSubscription b -> b
1245 _ -> False -- Shouldn't happen.
1246 -- Section 8 says (for presence of type "subscribe", the server MUST
1247 -- adhere to the rules defined under Section 3 and summarized under
1248 -- see Appendix A. (pariticularly Appendex A.3.1)
1249 if already_subscribed == is_wanted
1250 then do
1251 -- contact ∈ subscribers --> SHOULD NOT, already handled
1252 -- already subscribed, reply and quit
1253 -- (note: swapping to and from for reply)
1254 reply <- makeInformSubscription "jabber:server" to from is_wanted
1255 sendModifiedStanzaToPeer reply chan
1256 answerProbe state (Just to) k chan
1257 else do
1258
1259 -- TODO: if peer-connection is to self, then auto-approve local user.
1260
1261 -- add from-address to to's pending
1262 addrs <- resolvePeer (manager state profile) from_h
1263
1264 -- Catch exception in case the user does not exist
1265 if null addrs then fail else do
1266
1267 let from' = unsplitJID fromtup
1268
1269 -- Update roster files (subscribe: add to pending, unsubscribe: remove from subscribers).
1270 already_pending <-
1271 if is_wanted then
1272 addToRosterFile (manager state profile) ConfigFiles.modifyPending u profile from' addrs
1273 else do
1274 removeFromRosterFile (manager state profile) ConfigFiles.modifySubscribers u profile from' addrs
1275 reply <- makeInformSubscription "jabber:server" to from is_wanted
1276 sendModifiedStanzaToPeer reply chan
1277 return False
1278
1279 -- contact ∉ subscribers & contact ∈ pending --> SHOULD NOT
1280 when (not already_pending) $ do
1281 -- contact ∉ subscribers & contact ∉ pending --> MUST
1282
1283 chans <- clientCons state cktc u
1284 forM_ chans $ \( Conn { connChan=chan }, client ) -> do
1285 -- send to clients
1286 -- TODO: interested/available clients only?
1287 dup <- cloneStanza stanza
1288 sendModifiedStanzaToClient dup { stanzaFrom = Just $ from'
1289 , stanzaTo = Just $ unsplitJID totup }
1290 chan
1291
1292myMakeRosterUpdate prf tojid contact as
1293 | ".tox" `Text.isSuffixOf` prf
1294 , (Just u,h,r) <- splitJID contact
1295 , ".tox" `Text.isSuffixOf` u = XMPPServer.makeRosterUpdate tojid (unsplitJID (Nothing,h,r)) as
1296myMakeRosterUpdate _ tojid contact as = XMPPServer.makeRosterUpdate tojid contact as
1297
1298
1299clientInformSubscription :: PresenceState stat
1300 -> IO ()
1301 -> ClientAddress
1302 -> StanzaWrap (LockedChan Event)
1303 -> IO ()
1304clientInformSubscription state fail k stanza = do
1305 forClient state k fail $ \client -> do
1306 fromMaybe fail $ (stanzaTo stanza) <&> \to -> do
1307 dput XJabber $ "clientInformSubscription"
1308 let (mu,h,mr) = splitJID to
1309 man = manager state $ clientProfile client
1310 addrs <- resolvePeer man h
1311 -- remove from pending
1312 buds <- resolvedFromRoster man ConfigFiles.getBuddies (clientUser client) (clientProfile client)
1313 let is_buddy = not . null $ map (mu,) addrs `intersect` buds
1314 removeFromRosterFile man ConfigFiles.modifyPending (clientUser client) (clientProfile client) to addrs
1315 let (relationship,addf,remf) =
1316 case stanzaType stanza of
1317 PresenceInformSubscription True ->
1318 ( ("subscription", if is_buddy then "both"
1319 else "from" )
1320 , ConfigFiles.modifySubscribers
1321 , ConfigFiles.modifyOthers )
1322 _ -> ( ("subscription", if is_buddy then "to"
1323 else "none" )
1324 , ConfigFiles.modifyOthers
1325 , ConfigFiles.modifySubscribers )
1326 addToRosterFile man addf (clientUser client) (clientProfile client) to addrs
1327 removeFromRosterFile man remf (clientUser client) (clientProfile client) to addrs
1328
1329 do
1330 cbu <- atomically $ readTVar (clientsByUser state)
1331 dput XJabber $ "cbu = " ++ show (fmap (fmap clientPid . networkClients) cbu)
1332
1333 -- send roster update to clients
1334 (clients,ktc,pktc) <- atomically $ do
1335 cbu <- readTVar (clientsByUser state)
1336 let mlp = Map.lookup (clientUser client) cbu
1337 let cs = maybe [] (Map.toList . networkClients) mlp
1338 ktc <- readTVar (ckeyToChan state)
1339 pktc <- readTVar (pkeyToChan state)
1340 return (cs,ktc,pktc)
1341 forM_ clients $ \(ck, client) -> do
1342 is_intereseted <- atomically $ clientIsInterested client
1343 dput XJabber $ "clientIsInterested: "++show is_intereseted
1344 is_intereseted <- atomically $ clientIsInterested client
1345 when is_intereseted $ do
1346 forM_ (Map.lookup ck ktc) $ \con -> do
1347 hostname <- nameForClient state ck
1348 -- TODO: Should cjid include the resource?
1349 let cjid = unsplitJID (mu, hostname, Nothing)
1350 update <- myMakeRosterUpdate (clientProfile client) cjid to [relationship]
1351 sendModifiedStanzaToClient update (connChan con)
1352
1353 -- notify peer
1354 let dsts = toMapUnit addrs
1355 cdsts = pktc `Map.intersection` dsts
1356 forM_ (Map.toList cdsts) $ \(pk,con) -> do
1357 let from = clientJID con client
1358 to' = unsplitJID (mu, peerKeyToText pk, Nothing)
1359 dup <- cloneStanza stanza
1360 sendModifiedStanzaToPeer (dup { stanzaTo = Just $ to'
1361 , stanzaFrom = Just from })
1362 (connChan con)
1363 answerProbe state (Just from) pk (connChan con)
1364
1365peerInformSubscription :: PresenceState stat
1366 -> IO ()
1367 -> PeerAddress
1368 -> StanzaWrap (LockedChan Event)
1369 -> IO ()
1370peerInformSubscription state fail k stanza = do
1371 dput XJabber $ "TODO: peerInformSubscription"
1372 -- remove from solicited
1373 fromMaybe fail $ (stanzaFrom stanza) <&> \from -> do
1374 (ktc,cktc,cmap) <- atomically $ do
1375 pktc <- readTVar (pkeyToChan state)
1376 cktc <- readTVar (ckeyToChan state)
1377 cmap <- readTVar (clients state)
1378 return (pktc,cktc,cmap)
1379 fromMaybe fail $ Map.lookup k ktc
1380 <&> \(Conn { connChan=sender_chan
1381 , auxData =ConnectionData (Left laddr) ctyp profile _ }) -> do
1382 let man = manager state profile
1383 (from_u,from_h,_) <- case ctyp of
1384 Tox -> return $ splitJID from
1385 XMPP -> snd <$> rewriteJIDForClient man laddr from []
1386 let from'' = unsplitJID (from_u,from_h,Nothing)
1387 muser = do
1388 to <- stanzaTo stanza
1389 let (mu,to_h,to_r) = splitJID to
1390 mu
1391 -- TODO muser = Nothing when wanted=False
1392 -- should probably mean unsubscribed for all users.
1393 -- This would allow us to answer anonymous probes with 'unsubscribed'.
1394 fromMaybe fail $ muser <&> \user -> do
1395
1396 addrs <- resolvePeer man from_h
1397 was_solicited <- removeFromRosterFile man ConfigFiles.modifySolicited user profile from'' addrs
1398
1399 subs <- resolvedFromRoster man ConfigFiles.getSubscribers user profile
1400 let is_sub = not . null $ map (from_u,) addrs `intersect` subs
1401 dput XJabber $ "DEBUG peerInformSubscription (is_sub,typ)=" ++ show (is_sub,stanzaType stanza)
1402 let (relationship,addf,remf) =
1403 case stanzaType stanza of
1404 PresenceInformSubscription True ->
1405 ( ("subscription", if is_sub then "both"
1406 else "to" )
1407 , ConfigFiles.modifyBuddies
1408 , ConfigFiles.modifyOthers )
1409 _ -> ( ("subscription", if is_sub then "from"
1410 else "none")
1411 , ConfigFiles.modifyOthers
1412 , ConfigFiles.modifyBuddies )
1413 addToRosterFile man addf user profile from'' addrs
1414 removeFromRosterFile man remf user profile from'' addrs
1415
1416 chans <- clientCons' state cktc user
1417 forM_ chans $ \(ckey,(Conn { connChan=chan }, client)) -> do
1418 hostname <- nameForClient state ckey
1419 let to' = unsplitJID (Just user, hostname, Nothing)
1420 update <- myMakeRosterUpdate (clientProfile client) to' from'' [relationship]
1421 is_intereseted <- atomically $ clientIsInterested client
1422 when is_intereseted $ do
1423 sendModifiedStanzaToClient update chan
1424 -- TODO: interested/availabe clients only?
1425 dup <- cloneStanza stanza
1426 sendModifiedStanzaToClient dup { stanzaFrom = Just $ from''
1427 , stanzaTo = Just to' }
1428 chan
diff --git a/Presence/SockAddr.hs b/Presence/SockAddr.hs
deleted file mode 100644
index b5fbf16e..00000000
--- a/Presence/SockAddr.hs
+++ /dev/null
@@ -1,14 +0,0 @@
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE StandaloneDeriving #-}
3module SockAddr () where
4
5#if MIN_VERSION_network(2,4,0)
6import Network.Socket ()
7#else
8import Network.Socket ( SockAddr(..) )
9
10deriving instance Ord SockAddr
11#endif
12
13
14
diff --git a/Presence/Stanza/Build.hs b/Presence/Stanza/Build.hs
deleted file mode 100644
index 16552428..00000000
--- a/Presence/Stanza/Build.hs
+++ /dev/null
@@ -1,155 +0,0 @@
1{-# LANGUAGE CPP #-}
2module Stanza.Build where
3
4import Control.Monad
5import Control.Concurrent.STM
6import Data.Maybe
7import Data.Text (Text)
8import Data.XML.Types as XML
9
10#ifdef THREAD_DEBUG
11import Control.Concurrent.Lifted.Instrument
12#else
13import Control.Concurrent
14import GHC.Conc (labelThread)
15#endif
16
17import EventUtil
18import LockedChan
19import Stanza.Types
20
21makeMessage :: Text -> Text -> Text -> Text -> IO Stanza
22makeMessage namespace from to bod = makeMessageEx namespace from to NormalMsg bod
23
24makeMessageEx :: Text -> Text -> Text -> MessageType -> Text -> IO Stanza
25makeMessageEx namespace from to msgtyp bod =
26 stanzaFromList typ
27 $ [ EventBeginElement (mkname namespace "message")
28 $ addMessageType msgtyp
29 [ attr "from" from
30 , attr "to" to
31 ]
32 , EventBeginElement (mkname namespace "body") []
33 , EventContent (ContentText bod)
34 , EventEndElement (mkname namespace "body")
35 , EventEndElement (mkname namespace "message") ]
36 where
37 typ = Message { msgThread = Nothing
38 , msgLangMap = [("", lsm)]
39 , msgType = msgtyp
40 }
41 lsm = LangSpecificMessage
42 { msgBody = Just bod
43 , msgSubject = Nothing }
44
45addMessageType ChatMsg attrs = ("type",[ContentText "chat"]) : attrs
46addMessageType GroupChatMsg attrs = ("type",[ContentText "groupchat"]) : attrs
47addMessageType HeadlineMsg attrs = ("type",[ContentText "headline"]) : attrs
48addMessageType _ attrs = attrs
49
50makeInformSubscription :: Text -> Text -> Text -> Bool -> IO Stanza
51makeInformSubscription namespace from to approved =
52 stanzaFromList (PresenceInformSubscription approved)
53 $ [ EventBeginElement (mkname namespace "presence")
54 [ attr "from" from
55 , attr "to" to
56 , attr "type" $ if approved then "subscribed"
57 else "unsubscribed" ]
58 , EventEndElement (mkname namespace "presence")]
59
60makePresenceStanza :: Text -> Maybe Text -> JabberShow -> IO Stanza
61makePresenceStanza ns mjid pstat = makePresenceStanzaEx ns mjid pstat []
62
63makePresenceStanzaEx :: Text -> Maybe Text -> JabberShow -> [XML.Event]-> IO Stanza
64makePresenceStanzaEx namespace mjid pstat es = do
65 stanzaFromList PresenceStatus { presenceShow = pstat
66 , presencePriority = Nothing
67 , presenceStatus = []
68 , presenceWhiteList = []
69 }
70 $ [ EventBeginElement (mkname namespace "presence")
71 (setFrom $ typ pstat) ]
72 ++ (shw pstat >>= jabberShow) ++ es ++
73 [ EventEndElement (mkname namespace "presence")]
74 where
75 setFrom = maybe id
76 (\jid -> (attr "from" jid :) )
77 mjid
78 typ Offline = [attr "type" "unavailable"]
79 typ _ = []
80 shw ExtendedAway = ["xa"]
81 shw Chatty = ["chat"]
82 shw Away = ["away"]
83 shw DoNotDisturb = ["dnd"]
84 shw _ = []
85 jabberShow stat =
86 [ EventBeginElement "{jabber:client}show" []
87 , EventContent (ContentText stat)
88 , EventEndElement "{jabber:client}show" ]
89
90makeRosterUpdate :: Text -> Text -> [(Name, Text)] -> IO Stanza
91makeRosterUpdate tojid contact as = do
92 let attrs = map (uncurry attr) as
93 stanzaFromList Unrecognized
94 [ EventBeginElement "{jabber:client}iq"
95 [ attr "to" tojid
96 , attr "id" "someid"
97 , attr "type" "set"
98 ]
99 , EventBeginElement "{jabber:iq:roster}query" []
100 , EventBeginElement "{jabber:iq:roster}item" (attr "jid" contact : attrs)
101 , EventEndElement "{jabber:iq:roster}item"
102 , EventEndElement "{jabber:iq:roster}query"
103 , EventEndElement "{jabber:client}iq"
104 ]
105
106makePong :: Text -> Maybe Text -> Text -> Text -> [XML.Event]
107makePong namespace mid to from =
108 -- Note: similar to session reply
109 [ EventBeginElement (mkname namespace "iq")
110 $(case mid of
111 Just c -> (("id",[ContentText c]):)
112 _ -> id)
113 [ attr "type" "result"
114 , attr "to" to
115 , attr "from" from
116 ]
117 , EventEndElement (mkname namespace "iq")
118 ]
119
120
121mkname :: Text -> Text -> XML.Name
122mkname namespace name = (Name name (Just namespace) Nothing)
123
124
125stanzaFromList :: StanzaType -> [Event] -> IO Stanza
126stanzaFromList stype reply = do
127 let stanzaTag = listToMaybe reply
128 mid = stanzaTag >>= lookupAttrib "id" . tagAttrs
129 mfrom = stanzaTag >>= lookupAttrib "from" . tagAttrs
130 mto = stanzaTag >>= lookupAttrib "to" . tagAttrs
131 {-
132 isInternal (InternalEnableHack {}) = True
133 isInternal (InternalCacheId {}) = True
134 isInternal _ = False
135 -}
136 (donevar,replyChan,replyClsrs) <- atomically $ do
137 donevar <- newEmptyTMVar -- TMVar ()
138 replyChan <- newLockedChan
139 replyClsrs <- newTVar (Just [])
140 return (donevar,replyChan, replyClsrs)
141 t <- forkIO $ do
142 forM_ reply $ atomically . writeLChan replyChan
143 atomically $ do putTMVar donevar ()
144 writeTVar replyClsrs Nothing
145 labelThread t $ concat $ "stanza." : take 1 (words $ show stype)
146 return Stanza { stanzaType = stype
147 , stanzaId = mid
148 , stanzaTo = mto -- as-is from reply list
149 , stanzaFrom = mfrom -- as-is from reply list
150 , stanzaChan = replyChan
151 , stanzaClosers = replyClsrs
152 , stanzaInterrupt = donevar
153 , stanzaOrigin = LocalPeer
154 }
155
diff --git a/Presence/Stanza/Parse.hs b/Presence/Stanza/Parse.hs
deleted file mode 100644
index 58bf7c51..00000000
--- a/Presence/Stanza/Parse.hs
+++ /dev/null
@@ -1,277 +0,0 @@
1module Stanza.Parse (grokStanza,errorTagLocalName) where
2
3import Control.Concurrent.STM
4import Control.Monad
5import Data.Char
6import Data.Function
7import Data.Maybe
8import qualified Data.Text as Text (pack, unpack, words)
9 ;import Data.Text (Text)
10
11import Control.Monad.Catch (MonadThrow)
12import Control.Monad.IO.Class (MonadIO, liftIO)
13import qualified Data.Map as Map
14import Data.XML.Types as XML
15import qualified Text.XML.Stream.Parse as XML
16
17import Control.Concurrent.STM.Util
18import ControlMaybe (handleIO_, (<&>))
19import EventUtil
20import Nesting
21import Stanza.Types
22
23-- | Identify an XMPP stanza based on the open-tag.
24grokStanza :: Text -> XML.Event -> NestingXML o IO (Maybe StanzaType)
25grokStanza "jabber:server" stanzaTag =
26 case () of
27 _ | stanzaTag `isServerIQOf` "get" -> grokStanzaIQGet stanzaTag
28 _ | stanzaTag `isServerIQOf` "result" -> grokStanzaIQResult stanzaTag
29 _ | tagName stanzaTag == "{jabber:server}presence" -> grokPresence "jabber:server" stanzaTag
30 _ | tagName stanzaTag == "{jabber:server}message" -> grokMessage "jabber:server" stanzaTag
31 _ -> return $ Just Unrecognized
32
33grokStanza "jabber:client" stanzaTag =
34 case () of
35 _ | stanzaTag `isClientIQOf` "get" -> grokStanzaIQGet stanzaTag
36 _ | stanzaTag `isClientIQOf` "set" -> grokStanzaIQSet stanzaTag
37 _ | stanzaTag `isClientIQOf` "result" -> grokStanzaIQResult stanzaTag
38 _ | tagName stanzaTag == "{jabber:client}presence" -> grokPresence "jabber:client" stanzaTag
39 _ | tagName stanzaTag == "{jabber:client}message" -> grokMessage "jabber:client" stanzaTag
40 _ -> return $ Just Unrecognized
41
42grokStanzaIQGet :: Monad m => XML.Event -> NestingXML o m (Maybe StanzaType)
43grokStanzaIQGet stanza = do
44 mtag <- nextElement
45 forM mtag $ \tag -> do
46 case tagName tag of
47 "{urn:xmpp:ping}ping" -> return Ping
48 "{jabber:iq:roster}query" -> return RequestRoster
49 "{http://jabber.org/protocol/disco#items}query"
50 -> return $ RequestItems $ lookupAttrib "node" $ tagAttrs tag
51 "{http://jabber.org/protocol/disco#info}query"
52 -> return $ RequestInfo $ lookupAttrib "node" $ tagAttrs tag
53 name -> return $ UnrecognizedQuery name
54
55grokStanzaIQResult :: XML.Event -> NestingXML o IO (Maybe StanzaType)
56grokStanzaIQResult stanza = do
57 mtag <- nextElement
58 fromMaybe (return $ Just Pong) $ mtag <&> \tag -> do
59 case tagName tag of
60 "{jabber:iq:version}query" | nameNamespace (tagName stanza)==Just "jabber:client"
61 -> parseClientVersion
62 "{http://jabber.org/protocol/disco#items}query"
63 -> return $ Just Items
64 "{http://jabber.org/protocol/disco#info}query"
65 -> return $ Just Info
66 _ -> return Nothing
67
68grokStanzaIQSet :: XML.Event -> NestingXML o IO (Maybe StanzaType)
69grokStanzaIQSet stanza = do
70 mtag <- nextElement
71 case tagName <$> mtag of
72 Just "{urn:ietf:params:xml:ns:xmpp-bind}bind"
73 -> do mchild <- nextElement
74 case tagName <$> mchild of
75 Just "{urn:ietf:params:xml:ns:xmpp-bind}resource"
76 -> do rsc <- XML.content -- TODO: MonadThrow???
77 return . Just $ RequestResource Nothing (Just rsc)
78 Just _ -> return Nothing
79 Nothing -> return . Just $ RequestResource Nothing Nothing
80 Just "{urn:ietf:params:xml:ns:xmpp-session}session"
81 -> return $ Just SessionRequest
82 _ -> return Nothing
83
84grokPresence
85 :: ( MonadThrow m
86 , MonadIO m
87 ) => Text -> XML.Event -> NestingXML o m (Maybe StanzaType)
88grokPresence ns stanzaTag = do
89 let typ = lookupAttrib "type" (tagAttrs stanzaTag)
90 case typ of
91 Nothing -> -- Note: Possibly join-chat stanza.
92 parsePresenceStatus ns stanzaTag
93 Just "unavailable" -> fmap (fmap (\p -> p {presenceShow=Offline}))
94 $ parsePresenceStatus ns stanzaTag
95 Just "error" -> return . Just $ PresenceInformError
96 Just "unsubscribed" -> return . Just $ PresenceInformSubscription False
97 Just "subscribed" -> return . Just $ PresenceInformSubscription True
98 Just "probe" -> return . Just $ PresenceRequestStatus
99 Just "unsubscribe" -> return . Just $ PresenceRequestSubscription False
100 Just "subscribe" -> return . Just $ PresenceRequestSubscription True
101 _ -> return Nothing
102
103grokMessage
104 :: ( MonadThrow m
105 , MonadIO m
106 ) => Text -> XML.Event -> NestingXML o m (Maybe StanzaType)
107grokMessage ns stanzaTag = do
108 let typ = lookupAttrib "type" (tagAttrs stanzaTag)
109 case typ of
110 Just "error" -> do
111 mb <- findErrorTag ns
112 return $ do
113 e <- mb
114 return $ Error e stanzaTag
115 _ -> do t <- parseMessage ns stanzaTag
116 return $ Just t
117
118parseClientVersion :: NestingXML o IO (Maybe StanzaType)
119parseClientVersion = parseit Nothing Nothing
120 where
121 reportit mname mver = return $ do
122 name <- mname
123 ver <- mver
124 return NotifyClientVersion { versionName=name, versionVersion=ver }
125 parseit :: Maybe Text -> Maybe Text -> NestingXML o IO (Maybe StanzaType)
126 parseit mname mver = do
127 mtag <- nextElement
128 fromMaybe (reportit mname mver) $ mtag <&> \tag -> do
129 case tagName tag of
130 "{jabber:iq:version}name" -> do
131 x <- XML.content
132 parseit (Just x) mver
133 "{jabber:iq:version}version" -> do
134 x <- XML.content
135 parseit mname (Just x)
136 _ -> parseit mname mver
137
138parsePresenceStatus
139 :: ( MonadThrow m
140 , MonadIO m
141 ) => Text -> XML.Event -> NestingXML o m (Maybe StanzaType)
142parsePresenceStatus ns stanzaTag = do
143
144 let toStat "away" = Away
145 toStat "xa" = ExtendedAway
146 toStat "dnd" = DoNotDisturb
147 toStat "chat" = Chatty
148
149 showv <- liftIO . atomically $ newTVar Available
150 priov <- liftIO . atomically $ newTVar Nothing
151 statusv <- liftIO . atomically $ newTChan
152 fix $ \loop -> do
153 mtag <- nextElement
154 forM_ mtag $ \tag -> do
155 when (nameNamespace (tagName tag) == Just ns) $ do
156 case nameLocalName (tagName tag) of
157 "show" -> do t <- XML.content
158 liftIO . atomically $ writeTVar showv (toStat t)
159 "priority" -> do t <- XML.content
160 liftIO . handleIO_ (return ()) $ do
161 prio <- readIO (Text.unpack t)
162 atomically $ writeTVar priov (Just prio)
163 "status" -> do t <- XML.content
164 lang <- xmlLang
165 ioWriteChan statusv (maybe "" id lang,t)
166 _ -> return ()
167 loop
168 show <- liftIO . atomically $ readTVar showv
169 prio <- liftIO . atomically $ readTVar priov
170 status <- liftIO $ chanContents statusv -- Could use unsafeInterleaveIO to
171 -- avoid multiple passes, but whatever.
172 let wlist = do
173 w <- maybeToList $ lookupAttrib "whitelist" (tagAttrs stanzaTag)
174 Text.words w
175 return . Just $ PresenceStatus { presenceShow = show
176 , presencePriority = prio
177 , presenceStatus = status
178 , presenceWhiteList = wlist
179 }
180parseMessage
181 :: ( MonadThrow m
182 , MonadIO m
183 ) => Text -> XML.Event -> NestingXML o m StanzaType
184parseMessage ns stanza = do
185 let bodytag = Name { nameNamespace = Just ns
186 , nameLocalName = "body"
187 , namePrefix = Nothing }
188 subjecttag = Name { nameNamespace = Just ns
189 , nameLocalName = "subject"
190 , namePrefix = Nothing }
191 threadtag = Name { nameNamespace = Just ns
192 , nameLocalName = "thread"
193 , namePrefix = Nothing }
194 let emptyMsg = LangSpecificMessage { msgBody=Nothing, msgSubject=Nothing }
195 parseChildren (th,cmap) = do
196 child <- nextElement
197 lvl <- nesting
198 xmllang <- xmlLang
199 let lang = maybe "" id xmllang
200 let c = maybe emptyMsg id (Map.lookup lang cmap)
201 -- log $ " child: "<> bshow child
202 case child of
203 Just tag | tagName tag==bodytag
204 -> do
205 txt <- XML.content
206 awaitCloser lvl
207 parseChildren (th,Map.insert lang (c { msgBody=Just txt }) cmap)
208 Just tag | tagName tag==subjecttag
209 -> do
210 txt <- XML.content
211 awaitCloser lvl
212 parseChildren (th,Map.insert lang (c { msgSubject=Just txt }) cmap)
213 Just tag | tagName tag==threadtag
214 -> do
215 txt <- XML.content
216 awaitCloser lvl
217 parseChildren (th {msgThreadContent=txt},cmap)
218 Just tag -> do
219 -- let nm = tagName tag
220 -- attrs = tagAttrs tag
221 -- -- elems = msgElements c
222 -- txt <- XML.content
223 awaitCloser lvl
224 parseChildren (th,Map.insert lang c cmap)
225 Nothing -> return (th,cmap)
226 (th,langmap) <- parseChildren ( MessageThread {msgThreadParent=Nothing, msgThreadContent=""}
227 , Map.empty )
228 return Message {
229 msgLangMap = Map.toList langmap,
230 msgThread = if msgThreadContent th/="" then Just th else Nothing,
231 msgType = parseMessageType $ lookupAttrib "type" (tagAttrs stanza)
232 }
233
234parseMessageType :: Maybe Text -> MessageType
235parseMessageType (Just "chat") = ChatMsg
236parseMessageType (Just "groupchat") = GroupChatMsg
237parseMessageType (Just "headline") = HeadlineMsg
238parseMessageType _ = NormalMsg
239
240findErrorTag :: Monad m => Text -> NestingXML o m (Maybe StanzaError)
241findErrorTag ns = do
242 x <- nextElement
243 fmap join $ forM x $ \x ->
244 case tagName x of
245 n | nameNamespace n==Just ns && nameLocalName n=="error"
246 -> do
247 mtag <- findConditionTag
248 return $ do
249 tag <- {- trace ("mtag = "++show mtag) -} mtag
250 let t = nameLocalName (tagName tag)
251 conditionFromText t
252 _ -> findErrorTag ns
253
254findConditionTag :: Monad m => NestingXML o m (Maybe XML.Event)
255findConditionTag = do
256 mx <- nextElement
257 fmap join $ forM mx $ \x -> do
258 case nameNamespace (tagName x) of
259 Just "urn:ietf:params:xml:ns:xmpp-stanzas" -> return (Just x)
260 _ -> findConditionTag
261
262conditionFromText :: Text -> Maybe StanzaError
263conditionFromText t = fmap fst $ listToMaybe ss
264 where
265 es = [BadRequest .. UnexpectedRequest]
266 ts = map (\e->(e,errorTagLocalName e)) es
267 ss = dropWhile ((/=t) . snd) ts
268
269-- | Converts a CamelCase constructor to a hyphenated lower-case name for use
270-- as an xml tag.
271errorTagLocalName :: StanzaError -> Text
272errorTagLocalName e = Text.pack . drop 1 $ do
273 c <- show e
274 if 'A' <= c && c <= 'Z'
275 then [ '-', chr( ord c - ord 'A' + ord 'a') ]
276 else return c
277
diff --git a/Presence/Stanza/Types.hs b/Presence/Stanza/Types.hs
deleted file mode 100644
index 7275c8ab..00000000
--- a/Presence/Stanza/Types.hs
+++ /dev/null
@@ -1,257 +0,0 @@
1{-# LANGUAGE FlexibleInstances #-}
2module Stanza.Types where
3
4import Control.Concurrent.STM
5import Data.Int
6import Data.Text
7import Data.XML.Types as XML
8
9import Connection (PeerAddress(..))
10import ConnectionKey (ClientAddress(..))
11import LockedChan
12import Nesting (Lang)
13
14type Stanza = StanzaWrap (LockedChan XML.Event)
15
16data StanzaWrap a = Stanza
17 { stanzaType :: StanzaType
18 , stanzaId :: Maybe Text
19 , stanzaTo :: Maybe Text
20 , stanzaFrom :: Maybe Text
21 , stanzaChan :: a
22 , stanzaClosers :: TVar (Maybe [XML.Event])
23 , stanzaInterrupt :: TMVar ()
24 , stanzaOrigin :: StanzaOrigin
25 }
26
27data StanzaOrigin = LocalPeer
28 | PeerOrigin PeerAddress (TChan Stanza)
29 | ClientOrigin ClientAddress (TChan Stanza)
30
31data StanzaType
32 = Unrecognized
33 | Ping
34 | Pong
35 | RequestResource (Maybe Text) (Maybe Text) -- ^ Client's name for this host followed by client's requested resource id.
36 | SetResource
37 | RequestItems (Maybe Text)
38 | Items
39 | RequestInfo (Maybe Text)
40 | Info
41 | SessionRequest
42 | UnrecognizedQuery Name
43 | RequestRoster
44 | Roster
45 | RosterEvent { rosterEventType :: RosterEventType
46 , rosterUser :: Text
47 , rosterContact :: Text }
48 | Error StanzaError XML.Event
49 | PresenceStatus { presenceShow :: JabberShow
50 , presencePriority :: Maybe Int8
51 , presenceStatus :: [(Lang,Text)]
52 , presenceWhiteList :: [Text]
53 -- ^ A custom extension extension we are using. When a
54 -- peer answers a presence probe, it also communicates
55 -- to the remote peer which remote users it believes
56 -- are subscribed to that presence.
57 --
58 -- This is communicated via a space-delimited list in
59 -- the nonstandard "whitelist" attribute for a
60 -- <{jabber:server}presence> tag.
61 --
62 -- TODO: Use this to update the buddies file so that a
63 -- client is made aware when a subscription was
64 -- canceled.
65 }
66
67 | PresenceInformError
68 | PresenceInformSubscription Bool
69 | PresenceRequestStatus
70 | PresenceRequestSubscription Bool
71 | Message { msgThread :: Maybe MessageThread
72 , msgLangMap :: [(Lang,LangSpecificMessage)]
73 , msgType :: MessageType
74 }
75 | NotifyClientVersion { versionName :: Text
76 , versionVersion :: Text }
77 | InternalEnableHack ClientHack
78 | InternalCacheId Text
79 deriving (Show,Eq)
80
81data MessageType
82 = NormalMsg -- ^ The message is a standalone message that is sent outside
83 -- the context of a one-to-one conversation or groupchat, and
84 -- to which it is expected that the recipient will reply.
85 -- Typically a receiving client will present a message of type
86 -- "normal" in an interface that enables the recipient to
87 -- reply, but without a conversation history. The default
88 -- value of the 'type' attribute is "normal".
89
90 | ChatMsg -- ^ The message is sent in the context of a one-to-one chat
91 -- session. Typically an interactive client will present a
92 -- message of type "chat" in an interface that enables one-to-one
93 -- chat between the two parties, including an appropriate
94 -- conversation history. Detailed recommendations regarding
95 -- one-to-one chat sessions are provided under Section 5.1.
96
97 | GroupChatMsg -- ^ The message is sent in the context of a multi-user chat
98 -- environment (similar to that of [IRC]). Typically a
99 -- receiving client will present a message of type
100 -- "groupchat" in an interface that enables many-to-many
101 -- chat between the parties, including a roster of parties
102 -- in the chatroom and an appropriate conversation history.
103 -- For detailed information about XMPP-based groupchat,
104 -- refer to [XEP‑0045].
105
106 | HeadlineMsg -- ^ The message provides an alert, a notification, or other
107 -- transient information to which no reply is expected (e.g.,
108 -- news headlines, sports updates, near-real-time market
109 -- data, or syndicated content). Because no reply to the
110 -- message is expected, typically a receiving client will
111 -- present a message of type "headline" in an interface that
112 -- appropriately differentiates the message from standalone
113 -- messages, chat messages, and groupchat messages (e.g., by
114 -- not providing the recipient with the ability to reply). If
115 -- the 'to' address is the bare JID, the receiving server
116 -- SHOULD deliver the message to all of the recipient's
117 -- available resources with non-negative presence priority
118 -- and MUST deliver the message to at least one of those
119 -- resources; if the 'to' address is a full JID and there is
120 -- a matching resource, the server MUST deliver the message
121 -- to that resource; otherwise the server MUST either
122 -- silently ignore the message or return an error (see
123 -- Section 8).
124
125 -- | ErrorMsg -- The message is generated by an entity that experiences an
126 -- error when processing a message received from another entity (for
127 -- details regarding stanza error syntax, refer to [XMPP‑CORE]). A client
128 -- that receives a message of type "error" SHOULD present an appropriate
129 -- interface informing the original sender regarding the nature of the
130 -- error.
131
132 deriving (Show,Read,Ord,Eq,Enum)
133
134
135data RosterEventType
136 = RequestedSubscription
137 | NewBuddy -- preceded by PresenceInformSubscription True
138 | RemovedBuddy -- preceded by PresenceInformSubscription False
139 | PendingSubscriber -- same as PresenceRequestSubscription
140 | NewSubscriber
141 | RejectSubscriber
142 deriving (Show,Read,Ord,Eq,Enum)
143
144data ClientHack = SimulatedChatErrors
145 deriving (Show,Read,Ord,Eq,Enum)
146
147
148data LangSpecificMessage =
149 LangSpecificMessage { msgBody :: Maybe Text
150 , msgSubject :: Maybe Text
151 }
152 deriving (Show,Eq)
153
154data MessageThread = MessageThread {
155 msgThreadParent :: Maybe Text,
156 msgThreadContent :: Text
157 }
158 deriving (Show,Eq)
159
160
161data JabberShow = Offline
162 | ExtendedAway
163 | Away
164 | DoNotDisturb
165 | Available
166 | Chatty
167 deriving (Show,Enum,Ord,Eq,Read)
168
169class StanzaFirstTag a where
170 -- Peek at the stanza open tag.
171 stanzaFirstTag :: StanzaWrap a -> IO XML.Event
172instance StanzaFirstTag (TChan XML.Event) where
173 stanzaFirstTag stanza = do
174 e <-atomically $ peekTChan (stanzaChan stanza)
175 return e
176instance StanzaFirstTag (LockedChan XML.Event) where
177 stanzaFirstTag stanza = do
178 e <-atomically $ peekLChan (stanzaChan stanza)
179 return e
180instance StanzaFirstTag XML.Event where
181 stanzaFirstTag stanza = return (stanzaChan stanza)
182
183data StanzaError
184 = BadRequest
185 | Conflict
186 | FeatureNotImplemented
187 | Forbidden
188 | Gone
189 | InternalServerError
190 | ItemNotFound
191 | JidMalformed
192 | NotAcceptable
193 | NotAllowed
194 | NotAuthorized
195 | PaymentRequired
196 | RecipientUnavailable
197 | Redirect
198 | RegistrationRequired
199 | RemoteServerNotFound
200 | RemoteServerTimeout
201 | ResourceConstraint
202 | ServiceUnavailable
203 | SubscriptionRequired
204 | UndefinedCondition
205 | UnexpectedRequest
206 deriving (Show,Enum,Ord,Eq)
207
208xep0086 :: StanzaError -> (Text, Int)
209xep0086 e = case e of
210 BadRequest -> ("modify", 400)
211 Conflict -> ("cancel", 409)
212 FeatureNotImplemented -> ("cancel", 501)
213 Forbidden -> ("auth", 403)
214 Gone -> ("modify", 302)
215 InternalServerError -> ("wait", 500)
216 ItemNotFound -> ("cancel", 404)
217 JidMalformed -> ("modify", 400)
218 NotAcceptable -> ("modify", 406)
219 NotAllowed -> ("cancel", 405)
220 NotAuthorized -> ("auth", 401)
221 PaymentRequired -> ("auth", 402)
222 RecipientUnavailable -> ("wait", 404)
223 Redirect -> ("modify", 302)
224 RegistrationRequired -> ("auth", 407)
225 RemoteServerNotFound -> ("cancel", 404)
226 RemoteServerTimeout -> ("wait", 504)
227 ResourceConstraint -> ("wait", 500)
228 ServiceUnavailable -> ("cancel", 503)
229 SubscriptionRequired -> ("auth", 407)
230 UndefinedCondition -> ("", 500)
231 UnexpectedRequest -> ("wait", 400)
232
233errorText :: StanzaError -> Text
234errorText e = case e of
235 BadRequest -> "Bad request"
236 Conflict -> "Conflict"
237 FeatureNotImplemented -> "This feature is not implemented"
238 Forbidden -> "Forbidden"
239 Gone -> "Recipient can no longer be contacted"
240 InternalServerError -> "Internal server error"
241 ItemNotFound -> "Item not found"
242 JidMalformed -> "JID Malformed"
243 NotAcceptable -> "Message was rejected"
244 NotAllowed -> "Not allowed"
245 NotAuthorized -> "Not authorized"
246 PaymentRequired -> "Payment is required"
247 RecipientUnavailable -> "Recipient is unavailable"
248 Redirect -> "Redirect"
249 RegistrationRequired -> "Registration required"
250 RemoteServerNotFound -> "Recipient's server not found"
251 RemoteServerTimeout -> "Remote server timeout"
252 ResourceConstraint -> "The server is low on resources"
253 ServiceUnavailable -> "The service is unavailable"
254 SubscriptionRequired -> "A subscription is required"
255 UndefinedCondition -> "Undefined condition"
256 UnexpectedRequest -> "Unexpected request"
257
diff --git a/Presence/UTmp.hs b/Presence/UTmp.hs
deleted file mode 100644
index fcfe529a..00000000
--- a/Presence/UTmp.hs
+++ /dev/null
@@ -1,259 +0,0 @@
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 Data.String
21import System.Posix.Process
22import System.Posix.Signals
23import System.Posix.Types
24import System.Posix.User
25import Control.Monad
26import Data.Word
27import Data.Int
28import Control.Monad.Error.Class
29import System.IO.Error
30import qualified Paths
31import Data.Text ( Text )
32import Unsafe.Coerce ( unsafeCoerce )
33import Network.Socket ( SockAddr(..) )
34import qualified Data.Text.Encoding as Text
35import SockAddr ()
36
37
38utmp_file :: IsString s => s
39utmp_file = fromString $ Paths.utmp -- "/var/run/utmp"
40
41utmp_bs :: IO C.ByteString
42utmp_bs = S.readFile utmp_file
43
44decode_utmp_bytestring ::
45 C.ByteString
46 -> (Word32,
47 Word32,
48 C.ByteString,
49 C.ByteString,
50 C.ByteString,
51 C.ByteString,
52 Word16,
53 Word16,
54 Word32,
55 C.ByteString,
56 Word32,
57 Word32,
58 Word32,
59 Word32)
60decode_utmp_bytestring =
61 runIdentity
62 . $(bitSyn [ UnsignedLE 4 -- type
63 , UnsignedLE 4 -- pid
64 , Fixed 32 -- tty
65 , Fixed 4 -- inittab id
66 , Fixed 32 -- username
67 , Fixed 256 -- remote host
68 , UnsignedLE 2 -- termination status
69 , UnsignedLE 2 -- exit status (int)
70 , UnsignedLE 4 -- session id (int)
71 , Fixed 8 -- time entry was made
72 , Unsigned 4 -- remote addr v6 addr[0]
73 , Unsigned 4 -- remote addr v6 addr[1]
74 , Unsigned 4 -- remote addr v6 addr[2]
75 , Unsigned 4 -- remote addr v6 addr[3]
76 , Skip 20 -- reserved
77 ])
78
79utmp_size :: Int
80utmp_size = 384 -- 768
81
82
83utmp_records :: C.ByteString -> [C.ByteString]
84utmp_records bs | S.length bs >= utmp_size
85 = u:utmp_records us
86 where
87 (u,us) = S.splitAt utmp_size bs
88
89utmp_records bs = [bs]
90
91utmp ::
92 IO
93 [(Word32,
94 Word32,
95 C.ByteString,
96 C.ByteString,
97 C.ByteString,
98 C.ByteString,
99 Word16,
100 Word16,
101 Word32,
102 C.ByteString,
103 Word32,
104 Word32,
105 Word32,
106 Word32)]
107utmp = fmap (map decode_utmp_bytestring . utmp_records) utmp_bs
108
109toStr :: C.ByteString -> [Char]
110toStr = takeWhile (/='\0') . C.unpack
111
112interp_utmp_record ::
113 forall t t1 t2 t3 t4 t5 t6 t7 t8 a.
114 Integral a =>
115 (a,
116 Word32,
117 C.ByteString,
118 t,
119 C.ByteString,
120 C.ByteString,
121 t1,
122 t2,
123 t3,
124 t4,
125 t5,
126 t6,
127 t7,
128 t8)
129 -> (UT_Type, [Char], [Char], CPid, [Char])
130interp_utmp_record (typ,pid,tty,inittab,user,hostv4,term,exit,session,time
131 ,addr0,addr1,addr2,addr3) =
132 ( (toEnum . fromIntegral) typ :: UT_Type
133 , toStr user, toStr tty, processId pid, toStr hostv4 )
134 where
135 processId = CPid . coerceToSigned
136
137coerceToSigned :: Word32 -> Int32
138coerceToSigned = unsafeCoerce
139
140
141data UT_Type
142 = EMPTY -- No valid user accounting information. */
143
144 | RUN_LVL -- The system's runlevel. */
145 | BOOT_TIME -- Time of system boot. */
146 | NEW_TIME -- Time after system clock changed. */
147 | OLD_TIME -- Time when system clock changed. */
148
149 | INIT_PROCESS -- Process spawned by the init process. */
150 | LOGIN_PROCESS -- Session leader of a logged in user. */
151 | USER_PROCESS -- Normal process. */
152 | DEAD_PROCESS -- Terminated process. */
153
154 | ACCOUNTING
155
156 deriving (Enum,Show,Eq,Ord,Read)
157
158processAlive :: ProcessID -> IO Bool
159processAlive pid = do
160 catchError (do { signalProcess nullSignal pid ; return True })
161 $ \e -> do { return (not ( isDoesNotExistError e)); }
162
163type UserName = L.ByteString
164type Tty = L.ByteString
165
166users :: IO [(UserName, Tty, ProcessID)]
167users = utmp_users `catchIOError` \_ -> do
168 -- If we can't read utmp file, then return a list with only the current
169 -- user.
170 uname <- getLoginName
171 pid <- getProcessID -- TODO: XXX: Does this make sense as a fallback?
172 return [(L.pack uname,L.empty,pid)]
173 where
174 utmp_users = fmap (map only3) $ do
175 us <- utmp
176 let us' = map interp_utmp_record us
177 us'' = mapMaybe user_proc us'
178 user_proc (USER_PROCESS, u,tty,pid, hostv4)
179 = Just (L.pack u,L.pack tty,pid,hostv4)
180 user_proc _ = Nothing
181 onThrd f (_,_,pid,_) = f pid
182 us3 <- filterM (onThrd processAlive) us''
183 return us3
184
185only3 :: forall t t1 t2 t3. (t1, t2, t3, t) -> (t1, t2, t3)
186only3 (a,b,c,_) = (a,b,c)
187
188data UtmpRecord = UtmpRecord
189 { utmpType :: UT_Type
190 , utmpUser :: Text
191 , utmpTty :: Text
192 , utmpPid :: CPid
193 , utmpHost :: Text
194 , utmpSession :: Int32
195 , utmpRemoteAddr :: Maybe SockAddr
196 }
197 deriving ( Show, Eq, Ord )
198
199toText :: C.ByteString -> Text
200toText bs = Text.decodeUtf8 $ C.takeWhile (/='\0') bs
201
202interp_utmp_record2 ::
203 forall t t1 t2 t3 a.
204 Integral a =>
205 (a,
206 Word32,
207 C.ByteString,
208 t,
209 C.ByteString,
210 C.ByteString,
211 t1,
212 t2,
213 Word32,
214 t3,
215 Word32,
216 Word32,
217 Word32,
218 Word32)
219 -> UtmpRecord
220interp_utmp_record2 (typ,pid,tty,inittab,user,hostv4
221 ,term,exit,session,time,addr0,addr1,addr2,addr3) =
222 UtmpRecord
223 { utmpType = toEnum (fromIntegral typ) :: UT_Type
224 , utmpUser = toText user
225 , utmpTty = toText tty
226 , utmpPid = processId pid
227 , utmpHost = toText hostv4
228 , utmpSession = coerceToSigned session
229 , utmpRemoteAddr =
230 if all (==0) [addr1,addr2,addr3]
231 then do guard (addr0/=0)
232 Just $ SockAddrInet6 0 0 (0,0,0xFFFF,addr0) 0
233 else Just $ SockAddrInet6 0 0 (addr0,addr1,addr2,addr3) 0
234 }
235 where
236 processId = CPid . coerceToSigned
237
238users2 :: IO [UtmpRecord]
239users2 = do
240 us <- utmp
241 let us' = map interp_utmp_record2 us
242 us3 <- filterM (processAlive . utmpPid) us'
243 return us3
244
245{-
246 - This is how the w command reports idle time:
247/* stat the device file to get an idle time */
248static time_t idletime(const char *restrict const tty)
249{
250 struct stat sbuf;
251 if (stat(tty, &sbuf) != 0)
252 return 0;
253 return time(NULL) - sbuf.st_atime;
254}
255 - THis might be useful fo rimplementing
256 - xep-0012 Last Activity
257 - iq get {jabber:iq:last}query
258 -
259 -}
diff --git a/Presence/Util.hs b/Presence/Util.hs
deleted file mode 100644
index e19b35fd..00000000
--- a/Presence/Util.hs
+++ /dev/null
@@ -1,57 +0,0 @@
1{-# LANGUAGE OverloadedStrings #-}
2module Util where
3
4import qualified Data.ByteString.Lazy as L
5import Data.Monoid
6import qualified Data.Text as Text
7 ;import Data.Text (Text)
8import qualified Data.Text.Encoding as Text
9import qualified Network.BSD as BSD
10import Network.Socket
11
12import Network.Address (setPort)
13
14type UserName = Text
15type ResourceName = Text
16
17stripResource :: Text -> Text
18stripResource jid = let (n,h,_) = splitJID jid
19 in unsplitJID (n,h,Nothing)
20
21unsplitJID :: (Maybe UserName,Text,Maybe ResourceName) -> Text
22unsplitJID (n,h,r) = username <> h <> resource
23 where
24 username = maybe "" (<>"@") n
25 resource = maybe "" ("/"<>) r
26
27splitJID :: Text -> (Maybe UserName,Text,Maybe ResourceName)
28splitJID bjid =
29 let (uATh,slashrsc) = Text.break (=='/') bjid
30 rsrc = if Text.null slashrsc then Nothing
31 else Just $ Text.drop 1 slashrsc
32 (u,atserver) = Text.break (=='@') uATh
33 (name,server) = if Text.null atserver then (Nothing,u)
34 else (Just u,Text.drop 1 atserver)
35 in (name,server,rsrc)
36
37
38textHostName :: IO Text
39textHostName = fmap Text.pack BSD.getHostName
40
41textToLazyByteString :: Text -> L.ByteString
42textToLazyByteString s = L.fromChunks [Text.encodeUtf8 s]
43
44lazyByteStringToText :: L.ByteString -> Text
45lazyByteStringToText = (foldr (<>) mempty . map Text.decodeUtf8 . L.toChunks)
46
47-- | for example: 2001-db8-85a3-8d3-1319-8a2e-370-7348.ipv6-literal.net
48ip6literal :: Text -> Text
49ip6literal addr = Text.map dash addr <> ".ipv6-literal.net"
50 where
51 dash ':' = '-'
52 dash x = x
53
54sameAddress :: SockAddr -> SockAddr -> Bool
55sameAddress laddr addr = setPort 0 laddr == setPort 0 addr
56
57
diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
deleted file mode 100644
index fe099fb8..00000000
--- a/Presence/XMPPServer.hs
+++ /dev/null
@@ -1,1812 +0,0 @@
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE DoAndIfThenElse #-}
3{-# LANGUAGE ExistentialQuantification #-}
4{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE LambdaCase #-}
6{-# LANGUAGE MultiWayIf #-}
7{-# LANGUAGE OverloadedStrings #-}
8{-# LANGUAGE RankNTypes #-}
9{-# LANGUAGE TupleSections #-}
10module XMPPServer
11 ( xmppServer
12 , forkXmpp
13 , quitXmpp
14 , ClientAddress
15 , PeerAddress
16 , Local(..)
17 , Remote(..)
18 , ConnectionData(..)
19 , ConnectionType(..)
20 , MUC(..)
21 , XMPPServerParameters(..)
22 , XMPPServer
23 , classifyConnection
24 , addrToPeerKey
25 , addrFromClientKey
26 , xmppConnections
27 , xmppEventChannel
28 , StanzaWrap(..)
29 , Stanza(..)
30 , StanzaType(..)
31 , StanzaOrigin(..)
32 , cloneStanza
33 , LangSpecificMessage(..)
34 , peerKeyToText
35 , addrToText
36 , sendModifiedStanzaToPeer
37 , sendModifiedStanzaToClient
38 , presenceProbe
39 , presenceSolicitation
40 , makePresenceStanza
41 , makeInformSubscription
42 , makeRosterUpdate
43 , makeMessage
44 , JabberShow(..)
45 , Server
46 , flushPassThrough
47 , greet'
48 , (<&>)
49 ) where
50
51import ConnectionKey
52import qualified Control.Concurrent.STM.UpdateStream as Slotted
53import Nesting
54import Connection.Tcp
55import EventUtil
56import ControlMaybe
57import LockedChan
58import Connection (PeerAddress(..))
59import qualified Connection
60import Util
61import Network.Address (getBindAddress, sockAddrPort)
62
63import Debug.Trace
64import Control.Monad.Trans (lift)
65import Control.Monad.IO.Class (MonadIO, liftIO)
66import Control.Monad.Fix (fix)
67import Control.Monad
68#ifdef THREAD_DEBUG
69import Control.Concurrent.Lifted.Instrument (forkIO,myThreadId,labelThread,ThreadId,MVar,putMVar,takeMVar,newMVar)
70#else
71import Control.Concurrent.Lifted (forkIO,myThreadId,ThreadId)
72import GHC.Conc (labelThread)
73#endif
74import Control.Concurrent.STM
75import Data.List hiding ((\\))
76-- import Control.Concurrent.STM.TChan
77import Network.SocketLike
78import Text.Printf
79import Data.ByteString (ByteString)
80import qualified Data.ByteString.Char8 as Strict8
81-- import qualified Data.ByteString.Lazy.Char8 as Lazy8
82
83import Data.Conduit
84import qualified Data.Conduit.List as CL
85import qualified Data.Conduit.Binary as CB
86#if MIN_VERSION_conduit_extra(1,1,7)
87import Data.Conduit.ByteString.Builder (builderToByteStringFlush)
88#else
89import Data.Conduit.Blaze (builderToByteStringFlush)
90#endif
91
92import Control.Arrow
93import Control.Concurrent.STM.Util
94import DNSCache (withPort)
95import qualified Text.XML.Stream.Render as XML hiding (content)
96import qualified Text.XML.Stream.Parse as XML
97import Data.XML.Types as XML
98import Data.Maybe
99import Data.Monoid ( (<>) )
100import Data.Text (Text)
101import qualified Data.Text as Text
102import qualified Data.Map as Map
103import Data.Set (Set, (\\) )
104import qualified Data.Set as Set
105import Data.String ( IsString(..) )
106import qualified System.Random
107import Data.Void (Void)
108import DPut
109import DebugTag
110import Stanza.Build
111import Stanza.Parse
112import Stanza.Types
113import MUC
114import Chat
115
116-- peerport :: PortNumber
117-- peerport = 5269
118-- clientport :: PortNumber
119-- clientport = 5222
120
121my_uuid :: Text
122my_uuid = "154ae29f-98f2-4af4-826d-a40c8a188574"
123
124
125newtype Local a = Local a deriving (Eq,Ord,Show)
126newtype Remote a = Remote a deriving (Eq,Ord,Show)
127
128data XMPPServerParameters =
129 XMPPServerParameters
130 { -- | Called when a client requests a resource id. The first Maybe indicates
131 -- the name the client referred to this server by. The second Maybe is the
132 -- client's preferred resource name.
133 --
134 -- Note: The returned domain will be discarded and replaced with the result of
135 -- 'xmppTellMyNameToClient'.
136 xmppChooseResourceName :: ClientAddress -> Remote SockAddr -> Maybe Text -> Maybe Text -> IO Text
137 , -- | This should indicate the server's hostname that all client's see.
138 xmppTellMyNameToClient :: ClientAddress -> IO Text
139 , xmppTellMyNameToPeer :: Local SockAddr -> IO Text
140 , xmppTellClientHisName :: ClientAddress -> IO Text
141 , xmppTellPeerHisName :: PeerAddress -> IO Text
142 , xmppNewConnection :: SockAddr -> ConnectionData -> TChan Stanza -> IO ()
143 , xmppEOF :: SockAddr -> ConnectionData -> IO ()
144 , xmppRosterBuddies :: ClientAddress -> IO [Text]
145 , xmppRosterSubscribers :: ClientAddress -> IO [Text]
146 , xmppRosterSolicited :: ClientAddress -> IO [Text]
147 , xmppRosterOthers :: ClientAddress -> IO [Text]
148 , -- | Called when after sending a roster to a client. Usually this means
149 -- the client status should change from "available" to "interested".
150 xmppSubscribeToRoster :: ClientAddress -> IO ()
151 -- , xmppLookupClientJID :: SockAddr -> IO Text
152 , xmppDeliverMessage :: (IO ()) -> Stanza -> IO ()
153 -- | Called whenever a local client's presence changes.
154 , xmppInformClientPresence :: ClientAddress -> Stanza -> IO ()
155 -- | Called whenever a remote peer's presence changes.
156 , xmppInformPeerPresence :: PeerAddress -> Stanza -> IO ()
157 , -- | Called when a remote peer requests our status.
158 xmppAnswerProbe :: PeerAddress -> Stanza -> TChan Stanza -> IO ()
159 , xmppClientSubscriptionRequest :: IO () -> ClientAddress -> Stanza -> TChan Stanza -> IO ()
160 , -- | Called when a remote peer sends subscription request.
161 xmppPeerSubscriptionRequest :: IO () -> PeerAddress -> Stanza -> TChan Stanza -> IO ()
162 , xmppClientInformSubscription :: IO () -> ClientAddress -> Stanza -> IO ()
163 , -- | Called when a remote peer informs us of our subscription status.
164 xmppPeerInformSubscription :: IO () -> PeerAddress -> Stanza -> IO ()
165 , xmppGroupChat :: Map.Map Text MUC -- Key should be lowercase identifier.
166 , xmppVerbosity :: IO Int
167 , xmppClientBind :: Maybe SockAddr
168 , xmppPeerBind :: Maybe SockAddr
169 }
170
171
172enableClientHacks ::
173 forall t a.
174 (Eq a, IsString a) =>
175 a -> t -> TChan Stanza -> IO ()
176enableClientHacks "Pidgin" version replyto = do
177 wlog "Enabling hack SimulatedChatErrors for client Pidgin"
178 donevar <- atomically newEmptyTMVar
179 sendReply donevar
180 (InternalEnableHack SimulatedChatErrors)
181 []
182 replyto
183enableClientHacks "irssi-xmpp" version replyto = do
184 wlog "Enabling hack SimulatedChatErrors for client irssi-xmpp"
185 donevar <- atomically newEmptyTMVar
186 sendReply donevar
187 (InternalEnableHack SimulatedChatErrors)
188 []
189 replyto
190enableClientHacks _ _ _ = return ()
191
192cacheMessageId :: Text -> TChan Stanza -> IO ()
193cacheMessageId id' replyto = do
194 wlog $ "Caching id " ++ Text.unpack id'
195 donevar <- atomically newEmptyTMVar
196 sendReply donevar
197 (InternalCacheId id')
198 []
199 replyto
200
201
202-- TODO: http://xmpp.org/rfcs/rfc6120.html#rules-remote-error
203-- client connection
204-- socat script to send stanza fragment
205-- copyToChannel can keep a stack of closers to append to finish-off a stanza
206-- the TMVar () from forkConnection can be passed and with a stanza to detect interruption
207
208addrToText :: SockAddr -> Text
209addrToText (addr@(SockAddrInet _ _)) = Text.pack $ stripColon (show addr)
210 where stripColon s = pre where (pre,_) = break (==':') s
211addrToText (addr@(SockAddrInet6 _ _ _ _)) = Text.pack $ stripColon (show addr)
212 where stripColon s = if null bracket then pre else pre ++ "]"
213 where
214 (pre,bracket) = break (==']') s
215
216-- Shows (as Text) the IP address associated with the given SockAddr.
217peerKeyToText :: PeerAddress -> Text
218peerKeyToText (PeerAddress addr) = addrToText addr
219
220
221wlog :: String -> IO ()
222wlog = dput XJabber
223
224wlogb :: ByteString -> IO ()
225wlogb = wlog . Strict8.unpack
226
227flushPassThrough :: Monad m => ConduitT a b m () -> ConduitT (Flush a) (Flush b) m ()
228flushPassThrough c = getZipConduit $ ZipConduit (onlyChunks .| mapOutput Chunk c) <* ZipConduit onlyFlushes
229 where
230 onlyChunks :: Monad m => ConduitT (Flush a) a m ()
231 onlyFlushes :: Monad m => ConduitT (Flush a) (Flush b) m ()
232 onlyChunks = awaitForever yieldChunk
233 onlyFlushes = awaitForever yieldFlush
234 yieldFlush Flush = yield Flush
235 yieldFlush _ = return ()
236 yieldChunk (Chunk x) = yield x
237 yieldChunk _ = return ()
238
239xmlStream :: ReadCommand -> WriteCommand -> ( ConduitT () XML.Event IO ()
240 , ConduitT (Flush XML.Event) Void IO () )
241xmlStream conread conwrite = (xsrc,xsnk)
242 where
243 xsrc = src .| XML.parseBytes XML.def
244 xsnk :: ConduitT (Flush Event) Void IO ()
245 xsnk = -- XML.renderBytes XML.def =$ snk
246 flushPassThrough (XML.renderBuilder XML.def)
247 .| builderToByteStringFlush
248 .| discardFlush
249 .| snk
250 where
251 discardFlush :: Monad m => ConduitM (Flush a) a m ()
252 discardFlush = awaitForever yieldChunk
253 yieldChunk (Chunk x) = yield x
254 yieldChunk _ = return ()
255
256 src = do
257 v <- lift conread
258 maybe (return ()) -- lift . wlog $ "conread: Nothing")
259 (yield >=> const src)
260 v
261 snk = awaitForever $ liftIO . conwrite
262
263
264type FlagCommand = STM Bool
265type ReadCommand = IO (Maybe ByteString)
266type WriteCommand = ByteString -> IO Bool
267
268cloneStanza :: StanzaWrap (LockedChan a) -> IO (StanzaWrap (LockedChan a))
269cloneStanza stanza = do
270 dupped <- cloneLChan (stanzaChan stanza)
271 return stanza { stanzaChan = dupped }
272
273copyToChannel
274 :: MonadIO m =>
275 (Event -> a) -> LockedChan a -> TVar (Maybe [Event]) -> ConduitM Event Event m ()
276copyToChannel f chan closer_stack = awaitForever copy
277 where
278 copy x = do
279 liftIO . atomically $ writeLChan chan (f x)
280 case x of
281 EventBeginDocument {} -> do
282 let clsr = closerFor x
283 liftIO . atomically $
284 modifyTVar' closer_stack (fmap (clsr:))
285 EventEndDocument {} -> do
286 liftIO . atomically $
287 modifyTVar' closer_stack (fmap (drop 1))
288 _ -> return ()
289 yield x
290
291
292prettyPrint :: ByteString -> ConduitM Event Void IO ()
293prettyPrint prefix =
294 XML.renderBytes (XML.def { XML.rsPretty=True })
295 .| CB.lines
296 .| CL.mapM_ (wlogb . (prefix <>))
297
298swapNamespace :: Monad m => Text -> Text -> ConduitM Event Event m ()
299swapNamespace old new = awaitForever (yield . swapit old new)
300
301swapit :: Text -> Text -> Event -> Event
302swapit old new (EventBeginElement n as) | nameNamespace n==Just old =
303 EventBeginElement (n { nameNamespace = Just new }) as
304swapit old new (EventEndElement n) | nameNamespace n==Just old =
305 EventEndElement (n { nameNamespace = Just new })
306swapit old new x = x
307
308-- | This is invoked by sendModifiedStanzaTo* before swapping the namespace.
309--
310-- Optionally, when the namespace is jabber:server, this will set a "whitelist"
311-- attribute on a presence tag that indicates a list of users deliminated by
312-- spaces. This is so that a server can communicate to another server which
313-- users are believed to be subscribed.
314fixHeaders :: Monad m => Stanza -> ConduitM Event Event m ()
315fixHeaders Stanza { stanzaType=typ, stanzaTo=mto, stanzaFrom=mfrom } = do
316 x <- await
317 maybe (return ()) f x
318 where
319 f (EventBeginElement n as) = do yield $ EventBeginElement n (update n as)
320 awaitForever yield
321 f x = yield x >> awaitForever yield
322 update n as = as3
323 where
324 as' = maybe as (setAttrib "to" as) mto
325 as'' = maybe as' (setAttrib "from" as') mfrom
326 as3 = case typ of
327 PresenceStatus {} | nameNamespace n == Just "jabber:client"
328 -> delAttrib "whitelist" as'' -- client-to-peer "whitelist" is filtered.
329 PresenceStatus {} | otherwise
330 -- peer-to-client, we may have set a list of subscribed users
331 -- to be communicated to the remote end.
332 -> case presenceWhiteList typ of
333 [] -> delAttrib "whitelist" as''
334 ws -> setAttrib "whitelist" as'' (Text.intercalate " " ws)
335 _ -> as''
336
337 setAttrib akey as aval = attr akey aval:filter ((/=akey) . fst) as
338 delAttrib akey as = filter ((/=akey) . fst) as
339
340conduitToChan
341 :: ConduitT () Event IO ()
342 -> IO (LockedChan Event, TVar (Maybe [Event]), TMVar a)
343conduitToChan c = do
344 chan <- atomically newLockedChan
345 clsrs <- atomically $ newTVar (Just [])
346 quitvar <- atomically $ newEmptyTMVar
347 forkIO $ do
348 runConduit $ c .| copyToChannel id chan clsrs .| awaitForever (const $ return ())
349 atomically $ writeTVar clsrs Nothing
350 return (chan,clsrs,quitvar)
351
352conduitToStanza
353 :: StanzaType
354 -> Maybe Text -- ^ id
355 -> Maybe Text -- ^ from
356 -> Maybe Text -- ^ to
357 -> ConduitT () Event IO ()
358 -> IO Stanza
359conduitToStanza stype mid from to c = do
360 (chan,clsrs,quitvar) <- conduitToChan c
361 return
362 Stanza { stanzaType = stype
363 , stanzaId = mid
364 , stanzaTo = to
365 , stanzaFrom = from
366 , stanzaChan = chan
367 , stanzaClosers = clsrs
368 , stanzaInterrupt = quitvar
369 , stanzaOrigin = LocalPeer
370 }
371
372
373stanzaToConduit :: MonadIO m => Stanza -> ConduitM i Event m ()
374stanzaToConduit stanza = do
375 let xchan = stanzaChan stanza
376 xfin = stanzaClosers stanza
377 rdone = stanzaInterrupt stanza
378 loop = return ()
379 xchan <- liftIO $ unlockChan xchan
380 fix $ \inner -> do
381 what <- liftIO . atomically $ foldr1 orElse
382 [readTChan xchan >>= \xml -> return $ do
383 yield xml -- atomically $ Slotted.push slots Nothing xml
384 inner
385 ,do mb <- readTVar xfin
386 cempty <- isEmptyTChan xchan
387 if isNothing mb
388 then if cempty then return loop else retry
389 else do done <- tryReadTMVar rdone
390 check (isJust done)
391 trace "todo: send closers" retry
392 ,do isEmptyTChan xchan >>= check
393 readTMVar rdone
394 return (return ())]
395 what
396
397
398sendModifiedStanzaToPeer :: Stanza -> TChan Stanza -> IO ()
399sendModifiedStanzaToPeer stanza chan = do
400 (echan,clsrs,quitvar) <- conduitToChan c
401 ioWriteChan chan
402 stanza { stanzaChan = echan
403 , stanzaClosers = clsrs
404 , stanzaInterrupt = quitvar
405 , stanzaType = processedType (stanzaType stanza)
406 -- TODO id? origin?
407 }
408 where
409 old = "jabber:client"
410 new = "jabber:server"
411 c = stanzaToConduit stanza .| swapNamespace old new .| fixHeaders stanza
412 processedType (Error cond tag) = Error cond (swapit old new tag)
413 processedType x = x
414
415
416-- Modifies a server-to-server stanza to send it to a client. This changes the
417-- namespace and also filters some non-supported attributes. Any other
418-- modifications need to be made by the caller.
419sendModifiedStanzaToClient :: Stanza -> TChan Stanza -> IO ()
420sendModifiedStanzaToClient stanza chan = do
421 (echan,clsrs,quitvar) <- conduitToChan c
422 -- wlog $ "send-to-client " ++ show (stanzaId stanza)
423 ioWriteChan chan
424 stanza { stanzaChan = echan
425 , stanzaClosers = clsrs
426 , stanzaInterrupt = quitvar
427 , stanzaType = processedType (stanzaType stanza)
428 -- TODO id? origin?
429 }
430 where
431 old = "jabber:server"
432 new = "jabber:client"
433 c = stanzaToConduit stanza .| swapNamespace old new .| fixHeaders stanza
434 processedType (Error cond tag) = Error cond (swapit old new tag)
435 processedType x = x
436
437
438-- id,to, and from are taken as-is from reply list
439-- todo: this should probably be restricted to IO monad
440sendReply :: (Functor m, MonadIO m) => TMVar () -> StanzaType -> [Event] -> TChan Stanza -> m ()
441sendReply donevar stype reply replychan = do
442 let stanzaTag = listToMaybe reply
443 mid = stanzaTag >>= lookupAttrib "id" . tagAttrs
444 mfrom = stanzaTag >>= lookupAttrib "from" . tagAttrs
445 mto = stanzaTag >>= lookupAttrib "to" . tagAttrs
446 isInternal (InternalEnableHack {}) = True
447 isInternal (InternalCacheId {}) = True
448 isInternal _ = False
449 forM_
450 (fmap (const ()) stanzaTag `mplus` guard (isInternal stype))
451 . const $ do
452 replyStanza <- liftIO . atomically $ do
453 replyChan <- newLockedChan
454 replyClsrs <- newTVar (Just [])
455 return Stanza { stanzaType = stype
456 , stanzaId = mid
457 , stanzaTo = mto -- as-is from reply list
458 , stanzaFrom = mfrom -- as-is from reply list
459 , stanzaChan = replyChan
460 , stanzaClosers = replyClsrs
461 , stanzaInterrupt = donevar
462 , stanzaOrigin = LocalPeer
463 }
464 ioWriteChan replychan replyStanza
465 void . liftIO . forkIO $ do
466 mapM_ (liftIO . atomically . writeLChan (stanzaChan replyStanza)) reply
467 liftIO . atomically $ writeTVar (stanzaClosers replyStanza) Nothing
468 -- liftIO $ wlog "finished reply stanza"
469
470
471
472{-
473C->Unrecognized <iq
474C->Unrecognized type="set"
475C->Unrecognized id="purpleae62d88f"
476C->Unrecognized xmlns="jabber:client">
477C->Unrecognized <bind xmlns="urn:ietf:params:xml:ns:xmpp-bind"/>
478C->Unrecognized </iq>
479-}
480
481
482-- Sends all stanzas to announce channel except ping, for which it sends a pong
483-- to the output channel.
484xmppInbound :: ConnectionData
485 -> (Text, IO Text, IO Text, TChan Stanza -> StanzaOrigin)
486 -> FlagCommand -- ^ action to check whether the connection needs a ping (XXX: unused)
487 -> TChan Stanza -- ^ channel to announce incoming stanzas on
488 -> TChan Stanza -- ^ channel used to send stanzas
489 -> TMVar () -- ^ mvar that is filled when the connection quits
490 -> ConduitM Event o IO ()
491xmppInbound cdta (namespace,tellmyname,tellyourname,mkorigin) pingflag stanzas output donevar = doNestingXML $ do
492 withXML $ \begindoc -> do
493 when (begindoc==EventBeginDocument) $ do
494 whenJust nextElement $ \xml -> do
495 withJust (elementAttrs "stream" xml) $ \stream_attrs -> do
496 -- liftIO $ dput XMisc $ "STREAM ATTRS "++show stream_attrs
497 let stream_name = lookupAttrib "to" stream_attrs
498 stream_remote = lookupAttrib "from" stream_attrs
499 -- xmpp_version = lookupAttrib "version" stream_attrs
500 liftIO $ atomically $ writeTVar (cdRemoteName cdta) stream_remote
501 fix $ \loop -> do
502 -- liftIO . wlog $ "waiting for stanza."
503 (chan,clsrs) <- liftIO . atomically $
504 liftM2 (,) newLockedChan (newTVar (Just []))
505 whenJust nextElement $ \stanzaTag -> do
506 stanza_lvl <- nesting
507 liftIO . atomically $ do
508 writeLChan chan stanzaTag
509 modifyTVar' clsrs (fmap (closerFor stanzaTag:))
510 copyToChannel id chan clsrs .| do
511 let mid = lookupAttrib "id" $ tagAttrs stanzaTag
512 mfrom = lookupAttrib "from" $ tagAttrs stanzaTag
513 mto = lookupAttrib "to" $ tagAttrs stanzaTag
514 dispatch <- grokStanza namespace stanzaTag
515 let unrecog = do
516 let stype = Unrecognized
517 s <- liftIO . atomically $ do
518 return Stanza
519 { stanzaType = stype
520 , stanzaId = mid
521 , stanzaTo = mto
522 , stanzaFrom = mfrom
523 , stanzaChan = chan
524 , stanzaClosers = clsrs
525 , stanzaInterrupt = donevar
526 , stanzaOrigin = mkorigin output
527 }
528 ioWriteChan stanzas s
529 you <- liftIO tellyourname
530 me <- liftIO tellmyname
531 fromMaybe unrecog $ dispatch <&> \dispatch ->
532 case dispatch of
533 -- Checking that the to-address matches this server.
534 -- Otherwise it could be a client-to-client ping or a
535 -- client-to-server for some other server.
536 -- For now, assuming its for the immediate connection.
537 Ping | mto==Just me || mto==Nothing -> do
538 let pongto = maybe you id mfrom
539 pongfrom = maybe me id mto
540 pong = makePong namespace mid pongto pongfrom
541 sendReply donevar Pong pong output
542 do -- TODO: Remove this, it is only to generate a debug print
543 ioWriteChan stanzas Stanza
544 { stanzaType = Ping
545 , stanzaId = mid
546 , stanzaTo = mto
547 , stanzaFrom = mfrom
548 , stanzaChan = chan
549 , stanzaClosers = clsrs
550 , stanzaInterrupt = donevar
551 , stanzaOrigin = mkorigin output
552 }
553 stype -> ioWriteChan stanzas Stanza
554 { stanzaType = case stype of
555 RequestResource _ rsc -> RequestResource stream_name rsc
556 _ -> stype
557 , stanzaId = mid
558 , stanzaTo = mto
559 , stanzaFrom = mfrom
560 , stanzaChan = chan
561 , stanzaClosers = clsrs
562 , stanzaInterrupt = donevar
563 , stanzaOrigin = mkorigin output
564 }
565 awaitCloser stanza_lvl
566 liftIO . atomically $ writeTVar clsrs Nothing
567 loop
568
569
570while :: IO Bool -> IO a -> IO [a]
571while cond body = do
572 b <- cond
573 if b then do x <- body
574 xs <- while cond body
575 return (x:xs)
576 else return []
577
578{-
579readUntilNothing :: TChan (Maybe x) -> IO [x]
580readUntilNothing ch = do
581 x <- atomically $ readTChan ch
582 maybe (return [])
583 (\x -> do
584 xs <- readUntilNothing ch
585 return (x:xs))
586 x
587-}
588
589streamFeatures :: Text -> [XML.Event]
590streamFeatures "jabber:client" =
591 [ EventBeginElement (streamP "features") []
592 , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-bind}bind" []
593 , EventEndElement "{urn:ietf:params:xml:ns:xmpp-bind}bind"
594
595 {-
596 -- , " <session xmlns='urn:ietf:params:xml:ns:xmpp-session'/>"
597 , " <mechanisms xmlns='urn:ietf:params:xml:ns:xmpp-sasl'>"
598 -- , " <mechanism>DIGEST-MD5</mechanism>"
599 , " <mechanism>PLAIN</mechanism>"
600 , " </mechanisms> "
601 -}
602
603 , EventEndElement (streamP "features")
604 ]
605streamFeatures "jabber:server" =
606 []
607
608
609greet' :: Text -> Text -> [XML.Event]
610greet' namespace host = EventBeginDocument : greet'' namespace host
611
612greet'' :: Text -> Text -> [Event]
613greet'' namespace host =
614 [ EventBeginElement (streamP "stream")
615 [("from",[ContentText host])
616 ,("id",[ContentText "someid"])
617 ,("xmlns",[ContentText namespace])
618 ,("xmlns:stream",[ContentText "http://etherx.jabber.org/streams"])
619 ,("version",[ContentText "1.0"])
620 ]
621 ] ++ streamFeatures namespace
622
623consid :: Maybe Text -> [(Name, [Content])] -> [(Name, [Content])]
624consid Nothing = id
625consid (Just sid) = (("id",[ContentText sid]):)
626
627
628data XMPPState
629 = PingSlot
630 deriving (Eq,Ord)
631
632makePing :: Text -> Maybe Text -> Text -> Text -> [XML.Event]
633makePing namespace mid to from =
634 [ EventBeginElement (mkname namespace "iq")
635 $ (case mid of
636 Just c -> (("id",[ContentText c]):)
637 _ -> id )
638 [ ("type",[ContentText "get"])
639 , attr "to" to
640 , attr "from" from
641 ]
642 , EventBeginElement "{urn:xmpp:ping}ping" []
643 , EventEndElement "{urn:xmpp:ping}ping"
644 , EventEndElement $ mkname namespace "iq"]
645
646makeInfo :: Maybe Text -> Text -> Maybe Text -> [Event]
647makeInfo mid from mto = concat
648 [ [ EventBeginElement "{jabber:client}iq"
649 $ consid mid $ maybe id (\to -> (("to", [ContentText to]) :)) mto
650 [("from", [ContentText from])
651 ,("type", [ContentText "result"])]
652 , EventBeginElement "{http://jabber.org/protocol/disco#info}query" []
653 , EventBeginElement "{http://jabber.org/protocol/disco#info}identity"
654 [("category",[ContentText "server"])
655 ,("type",[ContentText "im"])]
656 , EventEndElement "{http://jabber.org/protocol/disco#info}identity"
657 , EventBeginElement "{http://jabber.org/protocol/disco#info}feature"
658 [("var",[ContentText "http://jabber.org/protocol/disco#info"])]
659 , EventEndElement "{http://jabber.org/protocol/disco#info}feature"
660 , EventBeginElement "{http://jabber.org/protocol/disco#info}feature"
661 [("var",[ContentText "http://jabber.org/protocol/disco#items"])]
662 , EventEndElement "{http://jabber.org/protocol/disco#info}feature" ]
663 , [] -- todo
664 , [ EventEndElement "{http://jabber.org/protocol/disco#info}query"
665 , EventEndElement "{jabber:client}iq" ]
666 ]
667
668
669makeNodeInfo :: Maybe Text -> Text -> Text -> Maybe Text -> Maybe Text-> [XML.Event]
670makeNodeInfo mid node from mto mname = concat
671 [ [ EventBeginElement "{jabber:client}iq"
672 $ consid mid $ maybe id (\to -> (("to", [ContentText to]) :)) mto
673 [("from", [ContentText from])
674 ,("type", [ContentText "result"])]
675 , EventBeginElement "{http://jabber.org/protocol/disco#info}query"
676 [("node",[ContentText node])]
677 ]
678 , case mname of
679 Nothing -> []
680 Just name -> [ EventBeginElement "{http://jabber.org/protocol/disco#info}identity"
681 [("category",[ContentText "conference"])
682 ,("type",[ContentText "text"])
683 ,("name",[ContentText name])]
684 , EventEndElement "{http://jabber.org/protocol/disco#info}identity"
685 ]
686 , [ EventEndElement "{http://jabber.org/protocol/disco#info}query"
687 , EventEndElement "{jabber:client}iq" ]
688 ]
689
690features :: [Text] -> [XML.Event]
691features fs = do
692 t <- fs
693 [ EventBeginElement "{http://jabber.org/protocol/disco#info}feature"
694 [("var",[ContentText t])],
695 EventEndElement "{http://jabber.org/protocol/disco#info}feature" ]
696
697makeMUCInfo :: Maybe Text -> Text -> Maybe Text -> [XML.Event] -> [XML.Event]
698makeMUCInfo mid from mto fs = concat
699 [ [ EventBeginElement "{jabber:client}iq"
700 $ consid mid $ maybe id (\to -> (("to", [ContentText to]) :)) mto
701 [("from", [ContentText from])
702 ,("type", [ContentText "result"])]
703 , EventBeginElement "{http://jabber.org/protocol/disco#info}query" []
704 , EventBeginElement "{http://jabber.org/protocol/disco#info}identity"
705 [("category",[ContentText "conference"])
706 ,("type",[ContentText "text"])]
707 , EventEndElement "{http://jabber.org/protocol/disco#info}identity"
708 {-
709 , EventBeginElement "{http://jabber.org/protocol/disco#info}feature"
710 [("var",[ContentText "http://jabber.org/protocol/disco#info"])]
711 , EventEndElement "{http://jabber.org/protocol/disco#info}feature"
712 , EventBeginElement "{http://jabber.org/protocol/disco#info}feature"
713 [("var",[ContentText "http://jabber.org/protocol/disco#items"])]
714 , EventEndElement "{http://jabber.org/protocol/disco#info}feature"
715 -}
716 , EventBeginElement "{http://jabber.org/protocol/disco#info}feature"
717 [("var",[ContentText "http://jabber.org/protocol/muc"])]
718 , EventEndElement "{http://jabber.org/protocol/disco#info}feature" ]
719 , fs
720 , [ EventEndElement "{http://jabber.org/protocol/disco#info}query"
721 , EventEndElement "{jabber:client}iq" ]
722 ]
723
724makeItemList :: Maybe Text -> [(Text,Maybe Text)] -> Text -> Maybe Text -> [Event]
725makeItemList mid items from mto = concat
726 [ [ EventBeginElement "{jabber:client}iq"
727 $ consid mid $ maybe id (\to -> (("to", [ContentText to]) :)) mto
728 [("from", [ContentText from])
729 ,("type", [ContentText "result"])]
730 , EventBeginElement "{http://jabber.org/protocol/disco#items}query" []]
731 , do (jid,name) <- items
732 [ EventBeginElement "{http://jabber.org/protocol/disco#items}item"
733 $ maybe id (\n -> (("name", [ContentText n]) :)) name [ ("jid", [ContentText jid]) ],
734 EventEndElement "{http://jabber.org/protocol/disco#items}item" ]
735 , [ EventEndElement "{http://jabber.org/protocol/disco#items}query"
736 , EventEndElement "{jabber:client}iq" ]
737 ]
738
739iq_bind_reply :: Maybe Text -> Text -> [XML.Event]
740iq_bind_reply mid jid =
741 [ EventBeginElement "{jabber:client}iq" (consid mid [("type",[ContentText "result"])])
742 , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-bind}bind"
743 [("xmlns",[ContentText "urn:ietf:params:xml:ns:xmpp-bind"])]
744 , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-bind}jid" []
745 , EventContent (ContentText jid)
746 , EventEndElement "{urn:ietf:params:xml:ns:xmpp-bind}jid"
747 , EventEndElement "{urn:ietf:params:xml:ns:xmpp-bind}bind"
748 , EventEndElement "{jabber:client}iq"
749
750 {-
751 -- query for client version
752 , EventBeginElement "{jabber:client}iq"
753 [ attr "to" jid
754 , attr "from" hostname
755 , attr "type" "get"
756 , attr "id" "version"]
757 , EventBeginElement "{jabber:iq:version}query" []
758 , EventEndElement "{jabber:iq:version}query"
759 , EventEndElement "{jabber:client}iq"
760 -}
761 ]
762
763iq_session_reply :: Maybe Text -> Text -> [XML.Event]
764iq_session_reply mid host =
765 -- Note: similar to Pong
766 [ EventBeginElement "{jabber:client}iq"
767 (consid mid [("from",[ContentText host])
768 ,("type",[ContentText "result"])
769 ])
770 , EventEndElement "{jabber:client}iq"
771 ]
772
773iq_service_unavailable :: Maybe Text -> Text -> XML.Name -> [XML.Event]
774iq_service_unavailable mid host {- mjid -} req =
775 [ EventBeginElement "{jabber:client}iq"
776 (consid mid [attr "type" "error"
777 ,attr "from" host])
778 , EventBeginElement req []
779 , EventEndElement req
780 , EventBeginElement "{jabber:client}error"
781 [ attr "type" "cancel"
782 , attr "code" "503" ]
783 , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-stanzas}service-unavailable" []
784 , EventEndElement "{urn:ietf:params:xml:ns:xmpp-stanzas}service-unavailable"
785 , EventEndElement "{jabber:client}error"
786 , EventEndElement "{jabber:client}iq"
787 ]
788
789
790wrapStanzaList :: [XML.Event] -> STM [Either (StanzaWrap XML.Event) XML.Event]
791wrapStanzaList xs = do
792 wrap <- do
793 clsrs <- newTVar Nothing
794 donev <- newTMVar ()
795 return $ \ x ->
796 Stanza { stanzaType = Unrecognized
797 , stanzaId = mid
798 , stanzaTo = mto
799 , stanzaFrom = mfrom
800 , stanzaClosers = clsrs
801 , stanzaInterrupt = donev
802 , stanzaOrigin = LocalPeer
803 , stanzaChan = x
804 }
805 return $ map (Left . wrap) (take 1 xs) ++ map Right (drop 1 xs)
806 where
807 m = listToMaybe xs
808 mto = m >>= lookupAttrib "to" . tagAttrs
809 mfrom = m >>= lookupAttrib "from" . tagAttrs
810 mid = m >>= lookupAttrib "id" . tagAttrs
811
812wrapStanzaConduit :: Monad m => StanzaWrap a -> ConduitM Event (Either (StanzaWrap Event) Event) m ()
813wrapStanzaConduit stanza = do
814 mfirst <- await
815 forM_ mfirst $ \first -> do
816 yield . Left $ stanza { stanzaChan = first }
817 awaitForever $ yield . Right
818
819
820
821{-
822greet namespace =
823 [ EventBeginDocument
824 , EventBeginElement (streamP "stream")
825 [ attr "xmlns" namespace
826 , attr "version" "1.0"
827 ]
828 ]
829-}
830
831{-
832goodbye :: [XML.Event]
833goodbye =
834 [ EventEndElement (streamP "stream")
835 , EventEndDocument
836 ]
837-}
838
839simulateChatError :: StanzaError -> Maybe Text -> [Event]
840simulateChatError err mfrom =
841 [ EventBeginElement "{jabber:client}message"
842 ((maybe id (\t->(attr "from" t:)) mfrom)
843 [attr "type" "normal" ])
844 , EventBeginElement "{jabber:client}body" []
845 , EventContent $ ContentText ("/me " <> errorText err)
846 , EventEndElement "{jabber:client}body"
847 , EventBeginElement "{http://jabber.org/protocol/xhtml-im}html" []
848 , EventBeginElement "{http://www.w3.org/1999/xhtml}body" []
849 , EventBeginElement "{http://www.w3.org/1999/xhtml}p"
850 [ attr "style" "font-weight:bold; color:red"
851 ]
852 , EventContent $ ContentText ("/me " <> errorText err)
853 , EventEndElement "{http://www.w3.org/1999/xhtml}p"
854 , EventEndElement "{http://www.w3.org/1999/xhtml}body"
855 , EventEndElement "{http://jabber.org/protocol/xhtml-im}html"
856 , EventEndElement "{jabber:client}message"
857 ]
858
859
860-- | Create a friend-request stanza.
861presenceSolicitation :: Text -- ^ JID of sender making request.
862 -> Text -- ^ JID of recipient who needs to approve it.
863 -> IO Stanza
864presenceSolicitation = presenceStanza (PresenceRequestSubscription True) "subscribe"
865
866presenceProbe :: Text -> Text -> IO Stanza
867presenceProbe = presenceStanza PresenceRequestStatus "probe"
868
869presenceStanza :: StanzaType -> Text -> Text -> Text -> IO Stanza
870presenceStanza stanza_type type_attr me jid =
871 stanzaFromList stanza_type
872 [ EventBeginElement "{jabber:server}presence"
873 [ attr "to" jid
874 , attr "from" me
875 , attr "type" type_attr
876 ]
877 , EventEndElement "{jabber:server}presence" ]
878
879slotsToSource ::
880 Slotted.UpdateStream XMPPState (Either (StanzaWrap XML.Event) XML.Event)
881 -> TVar Int
882 -> TVar (Maybe (StanzaWrap XML.Event))
883 -> TVar Bool
884 -> TMVar ()
885 -> ConduitT () (Flush XML.Event) IO ()
886slotsToSource slots nesting lastStanza needsFlush rdone =
887 fix $ \slot_src -> join . lift . atomically $ foldr1 orElse
888 [Slotted.pull slots >>= \x -> do
889 x <- case x of
890 Left wrapped -> do
891 writeTVar nesting 1
892 writeTVar lastStanza (Just wrapped)
893 return $ stanzaChan wrapped
894 Right x -> do
895 when (isEventBeginElement x)
896 $ modifyTVar' nesting (+1)
897 when (isEventEndElement x) $ do
898 n <- readTVar nesting
899 when (n==1) $ writeTVar lastStanza Nothing
900 modifyTVar' nesting (subtract 1)
901 return x
902 writeTVar needsFlush True
903 return $ do
904 -- liftIO $ wlog $ "yielding Chunk: " ++ show x
905 yield (Chunk x)
906 slot_src
907 ,do Slotted.isEmpty slots >>= check
908 readTVar needsFlush >>= check
909 writeTVar needsFlush False
910 return $ do
911 -- liftIO $ wlog "yielding Flush"
912 yield Flush
913 slot_src
914 ,readTMVar rdone >> return (return ())
915 ]
916
917forkConnection :: Server PeerAddress ConnectionData releaseKey XML.Event
918 -> XMPPServerParameters
919 -> PeerAddress -- SockAddr (XXX(what?): remote for peer, local for client)
920 -> ConnectionData
921 -> FlagCommand
922 -> ConduitT () XML.Event IO ()
923 -> ConduitT (Flush XML.Event) Void IO ()
924 -> TChan Stanza
925 -> MVar ()
926 -> IO (TChan Stanza)
927forkConnection sv xmpp saddr cdta pingflag src snk stanzas pp_mvar = do
928 let auxAddr = cdAddr cdta
929 clientOrServer@(namespace,tellmyname,telltheirname,_) = case auxAddr of
930 Right _ -> ("jabber:client", xmppTellMyNameToClient xmpp (ClientAddress $ peerAddress saddr)
931 , xmppTellClientHisName xmpp (ClientAddress $ peerAddress saddr)
932 , ClientOrigin (ClientAddress $ peerAddress saddr))
933 Left laddr -> ("jabber:server", xmppTellMyNameToPeer xmpp laddr
934 , xmppTellPeerHisName xmpp saddr
935 , PeerOrigin saddr)
936 me <- tellmyname
937 rdone <- atomically newEmptyTMVar
938 let isStarter (Left _) = True
939 isStarter (Right e) | isEventBeginElement e = True
940 isStarter _ = False
941 isStopper (Left _) = False
942 isStopper (Right e) | isEventEndElement e = True
943 isStopper _ = False
944 slots <- atomically $ Slotted.new isStarter isStopper
945 needsFlush <- atomically $ newTVar False
946 lastStanza <- atomically $ newTVar Nothing
947 nesting <- atomically $ newTVar 0
948 let _ = slots :: Slotted.UpdateStream XMPPState (Either (StanzaWrap XML.Event) XML.Event)
949 let greet_src = do
950 CL.sourceList (greet' namespace me) .| CL.map Chunk
951 yield Flush
952 slot_src = slotsToSource slots nesting lastStanza needsFlush rdone
953 -- client.PeerAddress {peerAddress = [::1]:5222}
954 let lbl n = concat [ n
955 , Text.unpack (Text.drop 7 namespace) -- "client" or "server"
956 , "."
957 , case cdProfile cdta of
958 _ | Right _ <- cdAddr cdta -> show saddr
959 "." -> show saddr
960 mytoxname -> show saddr {- TODO: remote tox peer name? -} ]
961
962 forkIO $ do myThreadId >>= flip labelThread (lbl "xmpp-post.")
963 -- This thread handles messages after they are pulled out of
964 -- the slots-queue. Hence, xmpp-post, for post- slots-queue.
965
966 -- Read all slots-queued XML events or stanzas and yield them
967 -- upstream. This should continue until the connection is
968 -- closed.
969 runConduit $ (greet_src >> slot_src) .| snk
970
971 -- Connection is now closed. Here we handle any unsent stanzas.
972 last <- atomically $ readTVar lastStanza
973 es <- while (atomically . fmap not $ Slotted.isEmpty slots)
974 (atomically . Slotted.pull $ slots)
975 let es' = mapMaybe metadata es -- We only care about full stanzas.
976 metadata (Left s) = Just s
977 metadata _ = Nothing
978 -- TODO: Issuing RecipientUnavailable for all errors is a presence leak
979 -- and protocol violation
980 -- TODO: IDMangler can be used for better targetted error delivery.
981 let fail stanza = do
982 wlog $ "failed delivery: " ++ show (stanzaId stanza)
983 quitVar <- atomically newEmptyTMVar
984 reply <- makeErrorStanza stanza
985 tag <- stanzaFirstTag stanza
986 -- sendReply quitVar (Error RecipientUnavailable tag) reply replyto
987 replystanza <- stanzaFromList (Error RecipientUnavailable tag) reply
988 xmppDeliverMessage xmpp (wlog $ "discarded error delivery fail") replystanza
989 notError s = case stanzaType s of
990 Error {} -> False
991 _ -> True
992 -- TODO: Probably some stanzas should be queued or saved for re-connect.
993 mapM_ fail $ filter notError (maybeToList last ++ es')
994 wlog $ "end xmpp-post fork: " ++ (lbl "")
995
996 output <- atomically newTChan
997 hacks <- atomically $ newTVar Map.empty
998 msgids <- atomically $ newTVar []
999 forkIO $ do
1000 -- Here is the pre- slots-queue thread which handles messages as they
1001 -- arrive and assigns slots to them if that is appropriate.
1002
1003 -- mapM_ (atomically . Slotted.push slots Nothing) greetPeer
1004 myThreadId >>= flip labelThread (lbl "xmpp-pre.")
1005
1006 verbosity <- xmppVerbosity xmpp
1007 fix $ \loop -> do
1008 what <- atomically $ foldr1 orElse
1009 [readTChan output >>= \stanza -> return $ do
1010 wantStanzas <- getVerbose XJabber
1011 let notping f
1012 | not wantStanzas = return ()
1013 | (verbosity==1) = case stanzaType stanza of Pong -> return ()
1014 _ -> f
1015 | (verbosity>=2) = f
1016 | otherwise = return ()
1017 -- isempty <- atomically $ isEmptyTChan (stanzaChan stanza)
1018 -- kwlog $ "queuing: "++show (isempty, stanzaId stanza)
1019 notping $ do
1020 dup <- cloneStanza stanza
1021 let typ = Strict8.pack $ c ++ "<-" ++ stanzaTypeString dup ++ " "
1022 c = case auxAddr of
1023 Right _ -> "C"
1024 Left _ -> "P"
1025 wlog ""
1026 liftIO $ takeMVar pp_mvar
1027 runConduit $ stanzaToConduit dup .| prettyPrint typ
1028 liftIO $ putMVar pp_mvar ()
1029 -- wlog $ "hacks: "++show (stanzaId stanza)
1030 case stanzaType stanza of
1031 InternalEnableHack hack -> do
1032 -- wlog $ "enable hack: " ++ show hack
1033 atomically $ modifyTVar' hacks (Map.insert hack ())
1034 InternalCacheId x -> do
1035 -- wlog $ "cache id thread: " ++ show x
1036 atomically $ modifyTVar' msgids (take 3 . (x:))
1037 _ -> return ()
1038 runConduit $ stanzaToConduit stanza .| wrapStanzaConduit stanza
1039 .| awaitForever
1040 -- TODO: PresenceStatus stanzas should be pushed to appropriate slots
1041 (liftIO . atomically . Slotted.push slots Nothing)
1042 case stanzaType stanza of
1043 Error err tag | tagName tag=="{jabber:client}message" -> do
1044 wlog $ "handling Error hacks"
1045 b <- atomically $ do m <- readTVar hacks
1046 cached <- readTVar msgids
1047 fromMaybe (return False) $ stanzaId stanza <&> \id' -> do
1048 return $ Map.member SimulatedChatErrors m
1049 && elem id' cached
1050 ids <- atomically $ readTVar msgids
1051 wlog $ "ids = " ++ show (b,stanzaId stanza, ids)
1052 when b $ do
1053 let sim = simulateChatError err (stanzaFrom stanza)
1054 wlog $ "sending simulated chat for error message."
1055 runConduit $ CL.sourceList sim .| wrapStanzaConduit stanza -- not quite right, but whatever
1056 .| awaitForever
1057 (liftIO . atomically . Slotted.push slots Nothing)
1058 Error e _ -> do
1059 wlog $ "no hacks for error: " ++ show e
1060 _ -> return ()
1061 loop
1062 ,do pingflag >>= check
1063 return $ do
1064 to <- telltheirname
1065 let from = me -- Look it up from Server object
1066 -- or pass it with Connection event.
1067 mid = Just "ping"
1068 ping0 = makePing namespace mid to from
1069 ping <- atomically $ wrapStanzaList ping0
1070 mapM_ (atomically . Slotted.push slots (Just $ PingSlot))
1071 ping
1072 wlog ""
1073 runConduit $ CL.sourceList ping0 .| prettyPrint (case auxAddr of
1074 Right _ -> "C<-Ping"
1075 Left _ -> "P<-Ping ")
1076 loop
1077 ,readTMVar rdone >> return (return ())
1078 ]
1079 what
1080 wlog $ "end xmpp-pre fork: " ++ show (lbl "")
1081 forkIO $ do
1082 myThreadId >>= flip labelThread (lbl "xmpp-reader.")
1083 -- src $$ awaitForever (lift . putStrLn . takeWhile (/=' ') . show)
1084 runConduit $ src .| xmppInbound cdta clientOrServer pingflag stanzas output rdone
1085 atomically $ putTMVar rdone ()
1086 wlog $ "end reader fork: " ++ lbl ""
1087 return output
1088
1089{-
1090data Peer = Peer
1091 { peerWanted :: TVar Bool -- ^ False when this peer is on a you-call-me basis
1092 , peerState :: TVar PeerState
1093 }
1094data PeerState
1095 = PeerPendingConnect UTCTime
1096 | PeerPendingAccept UTCTime
1097 | PeerConnected (TChan Stanza)
1098-}
1099
1100peerKey :: SocketLike sock => Maybe SockAddr -> sock -> IO (PeerAddress,ConnectionData)
1101peerKey bind_addr sock = do
1102 laddr <- getSocketName sock
1103 raddr <-
1104 sIsConnected sock >>= \c ->
1105 if c then getPeerName sock -- addr is normally socketName
1106 else return laddr -- Weird hack: addr is would-be peer name
1107 -- Assume remote peers are listening on the same port that we do.
1108 let peerport = fromIntegral $ fromMaybe 5269 $ do
1109 p <- bind_addr >>= sockAddrPort
1110 guard (p /= 0) -- Make sure we never use port 0 because it is used
1111 -- to distinguish fake address connection keys.
1112 return p
1113 rname <- atomically $ newTVar Nothing
1114 -- dput XMan $ "peerKey " ++ show (PeerAddress $ raddr `withPort` peerport,laddr)
1115 return $ ( PeerAddress $ raddr `withPort` peerport
1116 , ConnectionData { cdAddr = Left (Local laddr)
1117 , cdType = XMPP
1118 , cdProfile = "."
1119 , cdRemoteName = rname } )
1120
1121clientKey :: SocketLike sock => sock -> IO (PeerAddress,ConnectionData)
1122clientKey sock = do
1123 laddr <- getSocketName sock -- [::1]:5222 bind address, same for all clients
1124 raddr <- getPeerName sock -- [::1]:????? unique key
1125 when (Just 0 == sockAddrPort raddr) $ do
1126 dput XMan $ unwords [ "BUG: XMPP Client"
1127 , show (laddr,raddr)
1128 , "is using port zero. This could interfere"
1129 , "with Tox peer sessions." ]
1130 rname <- atomically $ newTVar Nothing
1131 -- dput XMan $ "clientKey " ++ show (PeerAddress laddr,raddr)
1132 return $ ( PeerAddress raddr -- Actually a ClientAddress, but _xmpp_sv conkey type is PeerAddress.
1133 , ConnectionData { cdAddr = Right (Remote raddr) -- FIXME: This is a bad way to detect client/peer.
1134 , cdType = XMPP
1135 , cdProfile = "."
1136 , cdRemoteName = rname } )
1137
1138
1139xmlifyRosterItems :: Monad m => Set Text -> Text -> Set Text -> ConduitM i Event m ()
1140xmlifyRosterItems solicited stype set = mapM_ item (Set.toList set)
1141 where
1142 item jid = do yield $ EventBeginElement "{jabber:iq:roster}item"
1143 ([ attr "jid" jid
1144 , attr "subscription" stype
1145 ]++if Set.member jid solicited
1146 then [attr "ask" "subscribe"]
1147 else [] )
1148 yield $ EventEndElement "{jabber:iq:roster}item"
1149
1150sendRoster ::
1151 StanzaWrap a
1152 -> XMPPServerParameters
1153 -> ClientAddress
1154 -> TChan Stanza
1155 -> IO ()
1156sendRoster query xmpp clientKey replyto = do
1157 let maddr = case stanzaOrigin query of
1158 ClientOrigin addr _ -> Just addr
1159 PeerOrigin {} -> Nothing -- remote peer requested roster?
1160 LocalPeer -> Nothing -- local peer requested roster?
1161 forM_ maddr $ \k -> do
1162 hostname <- xmppTellMyNameToClient xmpp clientKey
1163 let getlist f = do
1164 bs <- f xmpp k
1165 return (Set.fromList bs) -- js)
1166 buddies <- getlist xmppRosterBuddies
1167 subscribers <- getlist xmppRosterSubscribers
1168 solicited <- getlist xmppRosterSolicited
1169 subnone0 <- getlist xmppRosterOthers
1170 jid <- xmppTellClientHisName xmpp k -- LookupClientJID xmpp k
1171 let subnone = Set.union solicited subnone0 \\ Set.union buddies subscribers
1172 let subto = buddies \\ subscribers
1173 let subfrom = subscribers \\ buddies
1174 let subboth = Set.intersection buddies subscribers
1175 let roster = do
1176 yield $ EventBeginElement "{jabber:client}iq"
1177 (consid (stanzaId query)
1178 [ attr "to" jid
1179 , attr "type" "result" ])
1180 yield $ EventBeginElement "{jabber:iq:roster}query" [] -- todo: ver?
1181 xmlifyRosterItems solicited "to" subto
1182 xmlifyRosterItems solicited "from" subfrom
1183 xmlifyRosterItems solicited "both" subboth
1184 xmlifyRosterItems solicited "none" subnone
1185 yield $ EventEndElement "{jabber:iq:roster}query"
1186 yield $ EventEndElement "{jabber:client}iq"
1187
1188 conduitToStanza Roster
1189 (stanzaId query)
1190 Nothing
1191 (Just jid)
1192 roster >>= ioWriteChan replyto
1193 {-
1194 let debugpresence =
1195 [ EventBeginElement "{jabber:client}presence"
1196 [ attr "from" "guest@oxio4inifatsetlx.onion"
1197 , attr "to" jid]
1198 , EventEndElement "{jabber:client}presence"
1199 ]
1200 quitvar <- atomically newEmptyTMVar
1201 sendReply quitvar Unrecognized debugpresence replyto
1202 -}
1203
1204
1205socketFromKey :: Server PeerAddress ConnectionData releaseKey XML.Event -> ClientAddress -> IO (Remote SockAddr)
1206socketFromKey sv (ClientAddress addr) = do
1207 map <- atomically $ readTVar (conmap sv)
1208 let mcd = Map.lookup (PeerAddress addr) map
1209 oops = Remote addr -- No connection data, so using incorrect address.
1210 case mcd of
1211 Nothing -> return oops
1212 Just cd -> return $ either (const oops) id $ cdAddr $ cdata cd
1213
1214eventContent :: Maybe [Content] -> Text
1215eventContent cs = maybe "" (foldr1 (<>) . map content1) cs
1216 where content1 (ContentText t) = t
1217 content1 (ContentEntity t) = t
1218
1219makeErrorStanza :: StanzaFirstTag a => StanzaWrap a -> IO [XML.Event]
1220makeErrorStanza stanza = makeErrorStanza' stanza RecipientUnavailable []
1221
1222makeErrorStanza' :: StanzaFirstTag a =>
1223 StanzaWrap a -> StanzaError -> [(Name, [Content])] -> IO [Event]
1224makeErrorStanza' stanza err attrs = do
1225 startTag <- stanzaFirstTag stanza
1226 let n = tagName startTag
1227 endTag = EventEndElement n
1228 amap0 = Map.fromList (tagAttrs startTag)
1229 mto = Map.lookup "to" amap0
1230 mfrom = Map.lookup "from" amap0
1231 mtype = Map.lookup "type" amap0
1232 -- mid = Map.lookup "id" amap0
1233 amap1 = Map.alter (const mto) "from" amap0
1234 -- amap2 = Map.alter (const $ Just $ [ContentText "blackbird"]) {-mfrom)-} "to" amap1
1235 amap2 = Map.alter (const mfrom) "to" amap1
1236 amap3 = Map.insert "type" [XML.ContentText "error"] amap2
1237 startTag' = EventBeginElement
1238 (tagName startTag)
1239 (Map.toList amap3)
1240 -- err = Gone -- FeatureNotImplemented -- UndefinedCondition -- RecipientUnavailable
1241 errname = n { nameLocalName = "error" }
1242 -- errattrs = [attr "type" "wait"] -- "modify"]
1243 errorAttribs e xs = ys ++ xs -- todo replace instead of append
1244 where (typ,code) = xep0086 e
1245 ys = [attr "type" typ, attr "code" (Text.pack . show $ code)]
1246 errorTagName = Name { nameNamespace = Just "urn:ietf:params:xml:ns:xmpp-stanzas"
1247 , nameLocalName = errorTagLocalName err
1248 , namePrefix = Nothing }
1249 errattrs = errorAttribs err attrs
1250 {-
1251 let wlogd v s = do
1252 wlog $ "error "++show (lookupAttrib "id" $ tagAttrs startTag)++" " ++ v ++ " = " ++ show s
1253 wlogd "amap0" amap0
1254 wlogd "mto" mto
1255 wlogd "mfrom" mfrom
1256 wlogd "amap3" amap3
1257 -}
1258 if eventContent mtype=="error" then return [] else do
1259 return [ startTag'
1260 , EventBeginElement errname errattrs
1261 , EventBeginElement errorTagName []
1262 , EventEndElement errorTagName
1263 , EventEndElement errname
1264 {-
1265 , EventBeginElement "{jabber:client}body" []
1266 , EventContent (ContentText "what?")
1267 , EventEndElement "{jabber:client}body"
1268 -}
1269 {-
1270 , EventBeginElement "{154ae29f-98f2-4af4-826d-a40c8a188574}dummy" []
1271 , EventEndElement "{154ae29f-98f2-4af4-826d-a40c8a188574}dummy"
1272 -}
1273 , endTag
1274 ]
1275
1276monitor ::
1277 Server PeerAddress ConnectionData releaseKey XML.Event
1278 -> ConnectionParameters PeerAddress ConnectionData
1279 -> XMPPServerParameters
1280 -> IO b
1281monitor sv params xmpp = do
1282 chan <- return $ serverEvent sv
1283 stanzas <- atomically newTChan
1284 quitVar <- atomically newEmptyTMVar
1285 pp_mvar <- newMVar () -- Lock for synchronous pretty-printing of stanzas in log.
1286 joined_rooms <- atomically
1287 $ newTVar (Map.empty :: Map.Map ClientAddress (Map.Map (Text,Text) (TChan Stanza,JoinedRoom ClientAddress)))
1288 fix $ \loop -> do
1289 action <- atomically $ foldr1 orElse
1290 [ readTChan chan >>= \((addr,u),e) -> return $ do
1291 case e of
1292 Connection pingflag xsrc xsnk
1293 -> do wlog $ tomsg addr "Connection"
1294 outs <- forkConnection sv xmpp addr u pingflag xsrc xsnk stanzas pp_mvar
1295 -- /addr/ may be a peer or a client. So we'll strip off
1296 -- the PeerAddress constructor before exposing it.
1297 xmppNewConnection xmpp (peerAddress addr) u outs
1298 ConnectFailure addr
1299 -> do return () -- wlog $ tomsg k "ConnectFailure"
1300 EOF -> do wlog $ tomsg addr "EOF"
1301 -- /addr/ may be a peer or a client. So we'll strip off
1302 -- the PeerAddress constructor before exposing it.
1303 xmppEOF xmpp (peerAddress addr) u
1304 HalfConnection In
1305 -> do wlog $ tomsg addr "ReadOnly"
1306 case cdAddr u of
1307 Left (Local _) -> control sv (Connect (peerAddress addr) params)
1308 _ -> return () -- Don't call-back client connections.
1309 HalfConnection Out
1310 -> do wlog $ tomsg addr "WriteOnly"
1311 RequiresPing
1312 -> do return () -- wlog $ tomsg k "RequiresPing"
1313 , readTChan stanzas >>= \stanza -> return $ do
1314 {-
1315 dup <- case stanzaType stanza of
1316 -- Must dup anything that is going to be delivered...
1317 Message {} -> do
1318 dup <- cloneStanza stanza -- dupped so we can make debug print
1319 return dup
1320 Error {} -> do
1321 dup <- cloneStanza stanza -- dupped so we can make debug print
1322 return dup
1323 _ -> return stanza
1324 -}
1325 dup <- cloneStanza stanza
1326
1327 t <- forkIO $ do applyStanza sv joined_rooms quitVar xmpp stanza
1328 forwardStanza quitVar xmpp stanza
1329 labelThread t $ "process." ++ stanzaTypeString stanza
1330
1331 -- We need to clone in the case the stanza is passed on as for Message.
1332 wantStanzas <- getVerbose XJabber
1333 verbosity <- xmppVerbosity xmpp
1334 let notping f | not wantStanzas = return ()
1335 | (verbosity==1) = case stanzaType stanza of Pong -> return ()
1336 _ -> f
1337 | (verbosity>=2) = f
1338 | otherwise = return ()
1339 notping $ do
1340 let typ = Strict8.pack $ c ++ "->" ++ stanzaTypeString stanza ++ " "
1341 c = case stanzaOrigin stanza of
1342 LocalPeer -> "*"
1343 ClientOrigin {} -> "C"
1344 PeerOrigin {} -> "P"
1345 wlog ""
1346 liftIO $ takeMVar pp_mvar
1347 runConduit $ stanzaToConduit dup .| prettyPrint typ
1348 liftIO $ putMVar pp_mvar ()
1349 , do
1350 m <- readTVar joined_rooms
1351 foldr orElse retry $ (`map` (do (k,rs) <- Map.toList m
1352 i <- Map.toList rs
1353 return (k,i)))
1354 $ \(k,((rkey,muckey),(replyto,r))) -> do
1355 (mine,ChatTransaction no cjid cnick es) <- readRoom k r
1356 return $ do
1357 me <- xmppTellMyNameToClient xmpp k
1358 dput XJabber $ "CHAT " ++ Text.unpack rkey ++ ": <" ++ Text.unpack cnick ++ "> " ++ show es
1359 forM_ es $ \case
1360 Join | mine -> sendRoomOccupants muckey me cnick rkey r replyto
1361 Join -> do
1362 stanza <- makePresenceStanzaEx "jabber:client" (Just $ roomjid muckey me rkey cnick) Available
1363 [ EventBeginElement "{http://jabber.org/protocol/muc#user}x" []
1364 , EventEndElement "{http://jabber.org/protocol/muc#user}x"
1365 ]
1366 ioWriteChan replyto stanza
1367 Part -> do
1368 stanza <- makePresenceStanzaEx "jabber:client" (Just $ roomjid muckey me rkey cnick) Offline
1369 $ [ EventBeginElement "{http://jabber.org/protocol/muc#user}x" [] ]
1370 ++ (do guard mine
1371 [ EventBeginElement "{http://jabber.org/protocol/muc#user}status"
1372 [ ("code",[ContentText "110"]) -- self-presence code.
1373 ]
1374 , EventEndElement "{http://jabber.org/protocol/muc#user}status" ])
1375 ++ [ EventEndElement "{http://jabber.org/protocol/muc#user}x" ]
1376 ioWriteChan replyto stanza
1377 when mine $ atomically $ do
1378 jrs <- readTVar joined_rooms
1379 let m = Map.findWithDefault Map.empty k jrs
1380 m' = Map.delete (rkey,muckey) m
1381 jrs' = if Map.null m' then Map.delete k jrs
1382 else Map.insert k m' jrs
1383 writeTVar joined_rooms jrs'
1384 Talk talk -> do
1385 them <- xmppTellClientHisName xmpp k
1386 stanza <- makeMessageEx "jabber:client" (roomjid muckey me rkey cnick) them GroupChatMsg talk
1387 ioWriteChan replyto stanza
1388 return ()
1389 _ -> return ()
1390 ]
1391 action
1392 loop
1393 where
1394 tomsg k str = printf "%12s %s" str (show k)
1395 where
1396 _ = str :: String
1397
1398roomjid :: Text {- ^ service -} -> Text {- ^ hostname -} -> Text {- ^ room -} -> Text {- ^ nick -} -> Text
1399roomjid a me room n = room <> "@" <> a <> "." <> me <> "/" <> n
1400
1401sendRoomOccupants :: Text -> Text -> Text -> Text -> JoinedRoom k -> TChan Stanza -> IO ()
1402sendRoomOccupants a me them room r replyto = do
1403 xs <- map (\(n,m) -> (roomjid a me room n, m))
1404 <$> atomically (roomOccupants $ joinedRoom r)
1405 let (ys,xs') = partition (\(jid,_) -> jid == roomjid a me room them) xs
1406 forM_ xs $ \(jid,_) -> do
1407 stanza <- makePresenceStanzaEx "jabber:client" (Just jid) Available
1408 [ EventBeginElement "{http://jabber.org/protocol/muc#user}x" []
1409 , EventEndElement "{http://jabber.org/protocol/muc#user}x"
1410 ]
1411 ioWriteChan replyto stanza
1412 forM_ ys $ \(jid,_) -> do
1413 stanza <- makePresenceStanzaEx "jabber:client" (Just jid) Available
1414 [ EventBeginElement "{http://jabber.org/protocol/muc#user}x" []
1415 , EventBeginElement "{http://jabber.org/protocol/muc#user}status"
1416 [ ("code",[ContentText "110"]) -- self-presence code.
1417 ]
1418 , EventEndElement "{http://jabber.org/protocol/muc#user}status"
1419 , EventEndElement "{http://jabber.org/protocol/muc#user}x"
1420 ]
1421 ioWriteChan replyto stanza
1422
1423
1424stanzaTypeString :: StanzaWrap a -> String
1425stanzaTypeString stanza = concat . take 1 . words $ show (stanzaType stanza)
1426
1427data ServiceMatch a
1428 = NotMe -- ^ Hostname of another server.
1429 | UnknownService Text -- ^ Unknown subdomain of this host.
1430 | Service (Maybe Text) Text a -- ^ A known subdomain of this host. Optionally, a specific room name.
1431 | TopLevelService -- ^ This server's exact hostname.
1432
1433
1434lookupService :: Text {- ^ hostname -} -> Map.Map Text a {- ^ service map -} -> Text {- ^ JID -} -> (ServiceMatch a)
1435lookupService me mucs to = case Text.toLower to of
1436 nm | nm == Text.toLower me
1437 -> TopLevelService
1438 nm | let (a,hostname) = second (Text.drop 1) $ Text.break (=='@') nm
1439 (service,b) = Text.break (=='.') $ if Text.null hostname then a else hostname
1440 , Text.drop 1 b == Text.toLower me
1441 -> case Map.lookup service mucs of
1442 Just muc -> Service (if Text.null hostname then Nothing else Just a) service muc
1443 Nothing -> UnknownService service
1444 _ -> NotMe
1445
1446applyStanza :: Server PeerAddress ConnectionData releaseKey Event
1447 -> TVar (Map.Map ClientAddress (Map.Map (Text,Text) (TChan Stanza,JoinedRoom ClientAddress)))
1448 -> TMVar ()
1449 -> XMPPServerParameters
1450 -> StanzaWrap (LockedChan Event)
1451 -> IO ()
1452
1453applyStanza sv joined_rooms quitVar xmpp stanza = do
1454 dput XJabber $ "applyStanza: " ++ show (stanzaType stanza)
1455 case stanzaOrigin stanza of
1456 ClientOrigin k replyto ->
1457 case stanzaType stanza of
1458 RequestResource clientsNameForMe wanted -> do
1459 sockaddr <- socketFromKey sv k
1460 rsc0 <- xmppChooseResourceName xmpp k sockaddr clientsNameForMe wanted
1461 hostname <- xmppTellMyNameToClient xmpp k
1462 let rsc = unsplitJID (n,hostname,r) where (n,_,r) = splitJID rsc0
1463 let reply = iq_bind_reply (stanzaId stanza) rsc
1464 -- sendReply quitVar SetResource reply replyto
1465 let requestVersion :: ConduitT i XML.Event IO ()
1466 requestVersion = do
1467 yield $ EventBeginElement "{jabber:client}iq"
1468 [ attr "to" rsc
1469 , attr "from" hostname
1470 , attr "type" "get"
1471 , attr "id" "version"]
1472 yield $ EventBeginElement "{jabber:iq:version}query" []
1473 yield $ EventEndElement "{jabber:iq:version}query"
1474 yield $ EventEndElement "{jabber:client}iq"
1475 {-
1476 -- XXX Debug chat:
1477 yield $ EventBeginElement "{jabber:client}message"
1478 [ attr "from" $ eventContent (Just [ContentText rsc])
1479 , attr "type" "normal" ] -- "blackbird" ]
1480 yield $ EventBeginElement "{jabber:client}body" []
1481 yield $ EventContent $ ContentText ("hello?")
1482 yield $ EventEndElement "{jabber:client}body"
1483 yield $ EventEndElement "{jabber:client}message"
1484 -}
1485 sendReply quitVar SetResource reply replyto
1486 conduitToStanza (UnrecognizedQuery "{jabber:iq:version}query")
1487 Nothing -- id
1488 (Just hostname) -- from
1489 (Just rsc) -- to
1490 requestVersion
1491 >>= ioWriteChan replyto
1492 SessionRequest -> do
1493 me <- xmppTellMyNameToClient xmpp k
1494 let reply = iq_session_reply (stanzaId stanza) me
1495 sendReply quitVar Pong reply replyto
1496 RequestRoster -> do
1497 sendRoster stanza xmpp k replyto
1498 xmppSubscribeToRoster xmpp k
1499 PresenceStatus {} -> do
1500 let mucs = xmppGroupChat xmpp
1501 me <- xmppTellMyNameToClient xmpp k
1502 if | Just to <- stanzaTo stanza
1503 , (Just room,h,mnick) <- splitJID to
1504 , let roomjid = unsplitJID ((Just room,h,Nothing))
1505 , Service (Just _) mucname muc <- lookupService me mucs roomjid
1506 -> case mnick of
1507 Nothing -> do
1508 -- Missing nick.
1509 reply <- makeErrorStanza' stanza JidMalformed
1510 [ ("by", [ContentText roomjid]) ]
1511 sendReply quitVar (Error JidMalformed (head reply)) reply replyto
1512 Just nick -> case presenceShow (stanzaType stanza) of
1513 Offline -> do
1514 jid <- xmppTellClientHisName xmpp k
1515 atomically $ do
1516 jrs <- readTVar joined_rooms
1517 let m = Map.findWithDefault Map.empty k jrs
1518 case Map.lookup (room,mucname) m of
1519 Just (_,r) -> do
1520 partRoom r (Just jid) -- joinedNick r == nick
1521 {-
1522 let m' = Map.delete (room,mucname) m
1523 jrs' = if Map.null m' then Map.delete k jrs
1524 else Map.insert k m' jrs
1525 writeTVar joined_rooms jrs'
1526 -}
1527 _ -> return ()
1528 -- Anything other than type="unavailable" is treated as a join.
1529 _ -> do
1530 jid <- xmppTellClientHisName xmpp k
1531 join $ atomically $ do
1532 jrs <- readTVar joined_rooms
1533 let m = Map.findWithDefault Map.empty k jrs
1534 case Map.lookup (room,mucname) m of
1535 Nothing -> do r <- mucJoinRoom muc jid nick room k -- stanza
1536 jrs <- readTVar joined_rooms
1537 let m = Map.findWithDefault Map.empty k jrs
1538 writeTVar joined_rooms $ Map.insert k (Map.insert (room,mucname) (replyto,r) m) jrs
1539 return $ return ()
1540 Just r -> return $ dput XJabber "MUC: already joined."
1541 | otherwise -> do
1542 -- Handle presence stanza that is not a chatroom join.
1543 xmppInformClientPresence xmpp k stanza
1544 PresenceRequestSubscription {} -> do
1545 let fail = return () -- todo
1546 xmppClientSubscriptionRequest xmpp fail k stanza replyto
1547 PresenceInformSubscription {} -> do
1548 let fail = return () -- todo
1549 xmppClientInformSubscription xmpp fail k stanza
1550 NotifyClientVersion name version -> do
1551 enableClientHacks name version replyto
1552 RequestInfo mnode -> do
1553 me <- xmppTellMyNameToClient xmpp k
1554 let unavail = let query = "{http://jabber.org/protocol/disco#info}info"
1555 reply = iq_service_unavailable (stanzaId stanza) me query
1556 in return (Error ServiceUnavailable (head reply), reply)
1557 sto = fromMaybe me (stanzaTo stanza)
1558 (rtyp,reply) <- case lookupService me (xmppGroupChat xmpp) sto of
1559 NotMe -> unavail
1560 (UnknownService a) -> unavail -- TODO ItemNotFound instead?
1561 (Service Nothing a muc)
1562 -> case mnode of
1563 Just _ -> unavail
1564 Nothing -> let reply = makeMUCInfo (stanzaId stanza) (a <> "." <> me) (stanzaFrom stanza) []
1565 in return (Info, reply)
1566 (Service (Just room) a muc) | Nothing <- mnode
1567 -> let reply = makeMUCInfo (stanzaId stanza) (room <> "@" <> a <> "." <> me) (stanzaFrom stanza)
1568 $ features
1569 [ "http://jabber.org/protocol/muc#stable_id" ]
1570 in return (Info, reply)
1571 (Service (Just room) a muc) | Just "x-roomuser-item" <- mnode
1572 -> do
1573 mgetnick <- mucReservedNick muc room
1574 case mgetnick of
1575 Nothing -> do
1576 reply <- makeErrorStanza' stanza FeatureNotImplemented
1577 [ ("by", [ContentText (room <> "@" <> a <> "." <> me)]) ]
1578 return (Error FeatureNotImplemented (head reply), reply)
1579 Just getnick -> do
1580 who <- xmppTellClientHisName xmpp k
1581 n <- getnick who
1582 let reply = makeNodeInfo (stanzaId stanza) "x-roomuser-item" (room <> "@" <> a <> "." <> me)
1583 (stanzaFrom stanza) n
1584 return (Info, reply)
1585 (Service (Just room) a muc) | Just "http://jabber.org/protocol/muc#traffic" <- mnode
1586 -> do
1587 dput XJabber $ "TODO: 18.1.1 Allowable Traffic"
1588 reply <- makeErrorStanza' stanza FeatureNotImplemented
1589 [ ("by", [ContentText (room <> "@" <> a <> "." <> me)]) ]
1590 return (Error FeatureNotImplemented (head reply), reply)
1591 (Service (Just room) a muc) | Just "http://jabber.org/protocol/muc#rooms" <- mnode
1592 -> do
1593 dput XJabber $ "TODO: 6.7 Discovering Client Support for MUC"
1594 reply <- makeErrorStanza' stanza FeatureNotImplemented
1595 [ ("by", [ContentText (room <> "@" <> a <> "." <> me)]) ]
1596 return (Error FeatureNotImplemented (head reply), reply)
1597 (Service (Just room) a muc) | Just nodename <- mnode
1598 -> do
1599 dput XJabber $ "Uknown info node: " ++ Text.unpack nodename
1600 reply <- makeErrorStanza' stanza FeatureNotImplemented
1601 [ ("by", [ContentText (room <> "@" <> a <> "." <> me)]) ]
1602 return (Error FeatureNotImplemented (head reply), reply)
1603 TopLevelService
1604 -> case mnode of
1605 Just _ -> unavail
1606 Nothing -> let reply = makeInfo (stanzaId stanza) me (stanzaFrom stanza)
1607 in return (Info, reply)
1608 sendReply quitVar rtyp reply replyto
1609 RequestItems mnode -> do
1610 -- let query = "{http://jabber.org/protocol/disco#items}query"
1611 me <- xmppTellMyNameToClient xmpp k
1612 let unavail = let query = "{http://jabber.org/protocol/disco#info}info"
1613 reply = iq_service_unavailable (stanzaId stanza) me query
1614 in return (Error ServiceUnavailable (head reply), reply)
1615 sto = fromMaybe me (stanzaTo stanza)
1616 (rtyp,reply) <- case lookupService me (xmppGroupChat xmpp) sto of
1617 NotMe -> unavail
1618 (UnknownService a) -> unavail -- TODO ItemNotFound instead?
1619 (Service Nothing a muc) -> do
1620 items <- map (\(n,m) -> (n <> "@" <> a <> "." <> me, m))
1621 <$> mucRoomList muc
1622 let reply = makeItemList (stanzaId stanza) items (a <> "." <> me) (stanzaFrom stanza)
1623 return (Items, reply)
1624 (Service (Just room) a muc) -> do
1625 items <- map (\(n,m) -> (room <> "@" <> a <> "." <> me <> "/" <> n, m))
1626 <$> mucRoomOccupants muc room
1627 -- Note: I'm assuming 'mucRoomOccupants' returns an empty list for
1628 -- private rooms.
1629 let reply = makeItemList (stanzaId stanza) items (a <> "." <> me) (stanzaFrom stanza)
1630 return (Items, reply)
1631 TopLevelService -> do
1632 let items = do (name,MUC {}) <- Map.toList $ xmppGroupChat xmpp
1633 return (name <> "." <> me, Nothing)
1634 reply = makeItemList (stanzaId stanza) items me (stanzaFrom stanza)
1635 return (Items, reply)
1636 sendReply quitVar rtyp reply replyto
1637 UnrecognizedQuery query -> do
1638 me <- xmppTellMyNameToClient xmpp k
1639 let reply = iq_service_unavailable (stanzaId stanza) me query
1640 sendReply quitVar (Error ServiceUnavailable (head reply)) reply replyto
1641 Message { msgType = GroupChatMsg } -> do
1642 let mucs = xmppGroupChat xmpp
1643 me <- xmppTellMyNameToClient xmpp k
1644 if | Just to <- stanzaTo stanza
1645 , (Just room,h,mnick) <- splitJID to
1646 , let roomjid = unsplitJID ((Just room,h,Nothing))
1647 , Service (Just _) mucname muc <- lookupService me mucs roomjid
1648 -> case mnick of
1649 Nothing -> do
1650 -- Send message.
1651 jid <- xmppTellClientHisName xmpp k -- This should match stanzaFrom
1652 join $ atomically $ do
1653 jrs <- readTVar joined_rooms
1654 let m = Map.findWithDefault Map.empty k jrs
1655 case Map.lookup (room,mucname) m of
1656 Just (_,r) -> do
1657 let RH v = roomHandle r
1658 oldt <- readTVar v
1659 expected <- readTVar (roomFutureSeqNo $ joinedRoom r)
1660 b <- sendChat r (Just jid) $ do
1661 (_,msg) <- msgLangMap (stanzaType stanza)
1662 talk <- maybeToList $ msgBody msg
1663 [ Talk talk ]
1664 return $ dput XJabber $ "sendChat: " ++ show (b,expected,oldt,msgLangMap (stanzaType stanza))
1665 _ -> return $ dput XJabber $ "uknown room" ++ show (room,mucname)
1666 Just nick -> do
1667 -- Private message. TODO
1668 dput XJabber $ "TODO: Private messasge. " ++ show nick
1669
1670 | otherwise -> dput XJabber $ "Failed groupchat parse. to=" ++ show (stanzaTo stanza)
1671 Message {} -> do
1672 -- wlog $ "LANGMAP "++show (stanzaId stanza, msgLangMap (stanzaType stanza))
1673 maybe (return ()) (flip cacheMessageId replyto) $ do
1674 guard . not . null . mapMaybe (msgBody . snd) $ msgLangMap (stanzaType stanza)
1675 stanzaId stanza
1676 _ -> return ()
1677 PeerOrigin k replyto ->
1678 case stanzaType stanza of
1679 PresenceRequestStatus {} -> do
1680 xmppAnswerProbe xmpp k stanza replyto
1681 PresenceStatus {} -> do
1682 xmppInformPeerPresence xmpp k stanza
1683 PresenceRequestSubscription {} -> do
1684 let fail = return () -- todo
1685 xmppPeerSubscriptionRequest xmpp fail k stanza replyto
1686 PresenceInformSubscription {} -> do
1687 let fail = return () -- todo
1688 xmppPeerInformSubscription xmpp fail k stanza
1689 _ -> return ()
1690 _ -> return ()
1691
1692forwardStanza :: TMVar () -> XMPPServerParameters -> StanzaWrap (LockedChan Event) -> IO ()
1693forwardStanza quitVar xmpp stanza = do
1694 let deliver replyto = do
1695 -- TODO: Issuing RecipientUnavailable for all errors is a presence leak
1696 -- and protocol violation
1697 let fail = do
1698 wlog $ "Failed delivery id="++show (stanzaId stanza) -- TODO
1699 reply <- makeErrorStanza stanza
1700 tag <- stanzaFirstTag stanza
1701 sendReply quitVar (Error RecipientUnavailable tag) reply replyto
1702 xmppDeliverMessage xmpp fail stanza
1703 -- -- bad idea:
1704 -- let newStream = greet'' "jabber:client" "blackbird"
1705 -- sendReply quitVar Error newStream replyto
1706 case stanzaType stanza of
1707 Message { msgType = GroupChatMsg } -> return () -- Group chat handled elsewhere.
1708 Message {} -> do
1709 case stanzaOrigin stanza of
1710 LocalPeer {} -> return ()
1711 ClientOrigin _ replyto -> deliver replyto
1712 PeerOrigin _ replyto -> deliver replyto
1713 Error {} -> do
1714 case stanzaOrigin stanza of
1715 LocalPeer {} -> return ()
1716 ClientOrigin _ replyto -> deliver replyto
1717 PeerOrigin _ replyto -> deliver replyto
1718 _ -> return ()
1719
1720data ConnectionType = XMPP | Tox
1721 deriving (Eq,Ord,Enum,Show,Read)
1722
1723data ConnectionData = ConnectionData
1724 { cdAddr :: Either (Local SockAddr) -- Peer connection local address
1725 (Remote SockAddr) -- unused, todo:remove. (was client connection remote address).
1726 , cdType :: ConnectionType
1727 , cdProfile :: Text -- Currently ignored for clients. Instead, see
1728 -- 'clientProfile' field of 'ClientState'.
1729 --
1730 -- For peers: "." for XMPP, otherwise the ".tox" hostname
1731 -- of this local node.
1732
1733 -- Initially Nothing, when the remote end identifies itself by a given name,
1734 -- the result will be stored here.
1735 , cdRemoteName :: TVar (Maybe Text)
1736 }
1737
1738addrToPeerKey :: Remote SockAddr -> PeerAddress
1739addrToPeerKey (Remote raddr) = PeerAddress raddr
1740
1741addrFromClientKey :: ClientAddress -> Local SockAddr
1742addrFromClientKey (ClientAddress laddr) = Local laddr
1743
1744classifyConnection :: SockAddr -> ConnectionData -> Either (PeerAddress, Local SockAddr)
1745 (ClientAddress, Remote SockAddr)
1746classifyConnection saddr dta = case cdAddr dta of
1747 Left laddr -> Left (PeerAddress saddr, laddr)
1748 Right raddr -> Right (ClientAddress saddr, raddr)
1749
1750data XMPPServer
1751 = forall releaseKey.
1752 XMPPServer { _xmpp_sv :: Server PeerAddress ConnectionData releaseKey XML.Event
1753 -- ^ Internally, we're using PeerAddress for both clients
1754 -- and peers. For the external interface, we mark client
1755 -- addresses as 'ClientAddress' and not 'PeerAddress'.
1756 , _xmpp_man :: Connection.Manager TCPStatus Text
1757 , _xmpp_peer_params :: ConnectionParameters PeerAddress ConnectionData
1758 , _xmpp_peer_bind :: SockAddr
1759 }
1760
1761xmppConnections :: XMPPServer -> IO (Connection.Manager TCPStatus Text)
1762xmppConnections xsv@XMPPServer{_xmpp_man = m} = return m
1763
1764xmppEventChannel :: XMPPServer -> TChan ((PeerAddress, ConnectionData), ConnectionEvent Event)
1765xmppEventChannel XMPPServer{_xmpp_sv=sv} = serverEvent sv
1766
1767quitXmpp :: XMPPServer -> IO ()
1768quitXmpp XMPPServer{_xmpp_sv=sv} = control sv Quit
1769
1770xmppServer :: MonadIO m => Allocate releaseKey m
1771 -> Maybe SockAddr -- ^ Listen address for server-to-server protocol.
1772 -> m XMPPServer
1773xmppServer allocate bind_addr = do
1774 sv <- server allocate xmlStream
1775 liftIO $ do
1776 gen <- System.Random.getStdGen
1777 peer_bind <- maybe (getBindAddress "5269" True) return bind_addr
1778 let (r, _) = System.Random.next gen
1779 fuzz = r `mod` 2000 -- maximum 2 seconds of ping fuzz
1780 peer_params :: ConnectionParameters PeerAddress ConnectionData
1781 peer_params = (connectionDefaults $ peerKey $ Just peer_bind)
1782 { pingInterval = 15000 + fuzz
1783 , timeout = 2000
1784 , duplex = False }
1785 tcp <- tcpManager (\(PeerAddress addr) -> (addr, peer_params, 10000)) sv
1786 return XMPPServer { _xmpp_sv = sv
1787 , _xmpp_man = tcp
1788 , _xmpp_peer_params = peer_params
1789 , _xmpp_peer_bind = peer_bind
1790 }
1791
1792forkXmpp :: MonadIO m => XMPPServer -> XMPPServerParameters -> m ThreadId
1793forkXmpp XMPPServer { _xmpp_sv = sv
1794 , _xmpp_peer_params = peer_params
1795 , _xmpp_peer_bind = peer_bind
1796 }
1797 xmpp = liftIO $ do
1798 let client_params :: ConnectionParameters PeerAddress ConnectionData
1799 client_params = (connectionDefaults clientKey)
1800 { pingInterval = 0
1801 , timeout = 0
1802 }
1803 mt <- forkIO $ do myThreadId >>= flip labelThread ("XMPP.monitor")
1804 monitor sv peer_params xmpp
1805 dput XMisc $ "Starting peer listen"
1806 control sv (Listen peer_bind peer_params)
1807 dput XMisc $ "Starting client listen"
1808 client_bind <- maybe (getBindAddress "5222" True) return $ xmppClientBind xmpp
1809 control sv (Listen client_bind client_params)
1810 return mt
1811
1812
diff --git a/Presence/monitortty.c b/Presence/monitortty.c
deleted file mode 100644
index 7582aa56..00000000
--- a/Presence/monitortty.c
+++ /dev/null
@@ -1,182 +0,0 @@
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
149// Returns 0 on success.
150int monitorTTY(int fd) {
151 int er = -1, dev = -1;
152 pthread_mutex_init(&mu,NULL);
153 // Ensure we can open a device before we bother forking a thread.
154 dev = ttyfd();
155 if( dev != -1 ) {
156 er = pthread_create (&mt, NULL, write_vtch, (void*)(intptr_t)fd);
157 return er;
158 }
159 else {
160 return -1;
161 }
162}
163
164void closeTTY() {
165 int fd = -1;
166 int active = 7;
167 pthread_mutex_lock(&mu);
168 active = get_active(tty);
169 fd = tty;
170 pthread_mutex_unlock(&mu);
171#ifndef VTHACK
172 pthread_cancel(mt);
173#endif
174 char cmd[40]; cmd[39] = '\0';
175 // Hack to wake up from VT_WAITEVENT ioctl
176#ifdef VTHACK
177 snprintf(cmd,39,"chvt %i;chvt %i",active+1,active);
178 system(cmd);
179 pthread_join(mt,NULL);
180#endif
181 close(fd);
182}
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 15:51:47 +0000