summaryrefslogtreecommitdiff
path: root/Presence
diff options
context:
space:
mode:
Diffstat (limited to 'Presence')
-rw-r--r--Presence/ClientState.hs2
-rw-r--r--Presence/DNSCache.hs18
-rw-r--r--Presence/FGConsole.hs1
-rw-r--r--Presence/Logging.hs8
-rw-r--r--Presence/Paths.hs29
-rw-r--r--Presence/PeerResolve.hs2
-rw-r--r--Presence/UTmp.hs81
-rw-r--r--Presence/XMPPServer.hs5
8 files changed, 142 insertions, 4 deletions
diff --git a/Presence/ClientState.hs b/Presence/ClientState.hs
index 44d81b4f..30a53131 100644
--- a/Presence/ClientState.hs
+++ b/Presence/ClientState.hs
@@ -22,11 +22,13 @@ cf_interested :: Int8
22cf_interested = 0x2 22cf_interested = 0x2
23 23
24-- | True if the client has sent an initial presence 24-- | True if the client has sent an initial presence
25clientIsAvailable :: ClientState -> STM Bool
25clientIsAvailable c = do 26clientIsAvailable c = do
26 flgs <- readTVar (clientFlags c) 27 flgs <- readTVar (clientFlags c)
27 return $ flgs .&. cf_available /= 0 28 return $ flgs .&. cf_available /= 0
28 29
29-- | True if the client has requested a roster 30-- | True if the client has requested a roster
31clientIsInterested :: ClientState -> STM Bool
30clientIsInterested c = do 32clientIsInterested c = do
31 flgs <- readTVar (clientFlags c) 33 flgs <- readTVar (clientFlags c)
32 return $ flgs .&. cf_interested /= 0 34 return $ flgs .&. cf_interested /= 0
diff --git a/Presence/DNSCache.hs b/Presence/DNSCache.hs
index d6d7ce2f..e3ccc386 100644
--- a/Presence/DNSCache.hs
+++ b/Presence/DNSCache.hs
@@ -1,4 +1,5 @@
1{-# LANGUAGE TupleSections #-} 1{-# LANGUAGE TupleSections #-}
2{-# LANGUAGE RankNTypes #-}
2module DNSCache 3module DNSCache
3 ( DNSCache 4 ( DNSCache
4 , reverseResolve 5 , reverseResolve
@@ -45,6 +46,7 @@ newDNSCache = do
45 rcache <- newTVarIO Map.empty 46 rcache <- newTVarIO Map.empty
46 return DNSCache { fcache=fcache, rcache=rcache } 47 return DNSCache { fcache=fcache, rcache=rcache }
47 48
49equivBy :: forall a t. Eq a => (t -> a) -> t -> t -> Bool
48equivBy f a b = f a == f b 50equivBy f a b = f a == f b
49 51
50updateCache :: Eq x => 52updateCache :: Eq x =>
@@ -81,9 +83,12 @@ dnsObserve dns withScrub utc obs = do
81 updatef f (n,addrs) = Map.alter (updateCache withScrub utc addrs) n f 83 updatef f (n,addrs) = Map.alter (updateCache withScrub utc addrs) n f
82 updater r (a,ns) = Map.alter (updateCache withScrub utc ns) a r 84 updater r (a,ns) = Map.alter (updateCache withScrub utc ns) a r
83 85
86make6mapped4 :: SockAddr -> SockAddr
84make6mapped4 addr@(SockAddrInet6 {}) = addr 87make6mapped4 addr@(SockAddrInet6 {}) = addr
85make6mapped4 addr@(SockAddrInet port a) = SockAddrInet6 port 0 (0,0,0xFFFF,fromBE32 a) 0 88make6mapped4 addr@(SockAddrInet port a) = SockAddrInet6 port 0 (0,0,0xFFFF,fromBE32 a) 0
86 89
90rawForwardResolve ::
91 DNSCache -> (Text -> IO ()) -> Int -> Text -> IO [SockAddr]
87rawForwardResolve dns fail timeout addrtext = do 92rawForwardResolve dns fail timeout addrtext = do
88 r <- atomically newEmptyTMVar 93 r <- atomically newEmptyTMVar
89 mvar <- atomically newEmptyTMVar 94 mvar <- atomically newEmptyTMVar
@@ -106,26 +111,32 @@ rawForwardResolve dns fail timeout addrtext = do
106 atomically $ dnsObserve dns True utc $ map (addrtext,) xs 111 atomically $ dnsObserve dns True utc $ map (addrtext,) xs
107 return () 112 return ()
108 113
114strip_brackets :: Text -> Text
109strip_brackets s = 115strip_brackets s =
110 case Text.uncons s of 116 case Text.uncons s of
111 Just ('[',t) -> Text.takeWhile (/=']') t 117 Just ('[',t) -> Text.takeWhile (/=']') t
112 _ -> s 118 _ -> s
113 119
114 120
121reportTimeout :: forall a. Show a => a -> IO ()
115reportTimeout addrtext = do 122reportTimeout addrtext = do
116 putStrLn $ "timeout resolving: "++show addrtext 123 putStrLn $ "timeout resolving: "++show addrtext
117 -- killThread rt 124 -- killThread rt
118 125
126timer :: forall t a. IO () -> Int -> TMVar [a] -> t -> IO ()
119timer fail timeout r rt = do 127timer fail timeout r rt = do
120 handle (\(ErrorCall _)-> return ()) $ do 128 handle (\(ErrorCall _)-> return ()) $ do
121 threadDelay timeout 129 threadDelay timeout
122 did <- atomically $ tryPutTMVar r [] 130 did <- atomically $ tryPutTMVar r []
123 when did fail 131 when did fail
124 132
133unmap6mapped4 :: SockAddr -> SockAddr
125unmap6mapped4 addr@(SockAddrInet6 port _ (0,0,0xFFFF,a) _) = 134unmap6mapped4 addr@(SockAddrInet6 port _ (0,0,0xFFFF,a) _) =
126 SockAddrInet port (toBE32 a) 135 SockAddrInet port (toBE32 a)
127unmap6mapped4 addr = addr 136unmap6mapped4 addr = addr
128 137
138rawReverseResolve ::
139 DNSCache -> (SockAddr -> IO ()) -> Int -> SockAddr -> IO [Text]
129rawReverseResolve dns fail timeout addr = do 140rawReverseResolve dns fail timeout addr = do
130 r <- atomically newEmptyTMVar 141 r <- atomically newEmptyTMVar
131 mvar <- atomically newEmptyTMVar 142 mvar <- atomically newEmptyTMVar
@@ -144,6 +155,7 @@ rawReverseResolve dns fail timeout addr = do
144 atomically $ dnsObserve dns False utc $ map (,addr) xs 155 atomically $ dnsObserve dns False utc $ map (,addr) xs
145 atomically $ putTMVar r xs 156 atomically $ putTMVar r xs
146 157
158expiredReverse :: DNSCache -> SockAddr -> IO [Text]
147expiredReverse dns addr = do 159expiredReverse dns addr = do
148 utc <- getCurrentTime 160 utc <- getCurrentTime
149 addr <- return $ addr `withPort` 0 161 addr <- return $ addr `withPort` 0
@@ -163,6 +175,7 @@ expiredReverse dns addr = do
163 return es 175 return es
164 return es 176 return es
165 177
178cachedReverse :: DNSCache -> SockAddr -> IO [Text]
166cachedReverse dns addr = do 179cachedReverse dns addr = do
167 utc <- getCurrentTime 180 utc <- getCurrentTime
168 addr <- return $ addr `withPort` 0 181 addr <- return $ addr `withPort` 0
@@ -177,6 +190,7 @@ cachedReverse dns addr = do
177 -} 190 -}
178 return $ map snd ns 191 return $ map snd ns
179 192
193cachedForward :: DNSCache -> Text -> IO [SockAddr]
180cachedForward dns n = do 194cachedForward dns n = do
181 utc <- getCurrentTime 195 utc <- getCurrentTime
182 atomically $ do 196 atomically $ do
@@ -187,6 +201,7 @@ cachedForward dns n = do
187 modifyTVar' (fcache dns) $ Map.insert n as' 201 modifyTVar' (fcache dns) $ Map.insert n as'
188 return $ map snd as' 202 return $ map snd as'
189 203
204reverseResolve :: DNSCache -> SockAddr -> IO [Text]
190reverseResolve dns addr = do 205reverseResolve dns addr = do
191 expired <- expiredReverse dns addr 206 expired <- expiredReverse dns addr
192 forM_ expired $ \n -> forkIO $ do 207 forM_ expired $ \n -> forkIO $ do
@@ -196,6 +211,7 @@ reverseResolve dns addr = do
196 cs <- cachedReverse dns addr 211 cs <- cachedReverse dns addr
197 return $ xs ++ filter (not . flip elem xs) cs 212 return $ xs ++ filter (not . flip elem xs) cs
198 213
214forwardResolve :: DNSCache -> Text -> IO [SockAddr]
199forwardResolve dns n = do 215forwardResolve dns n = do
200 as <- rawForwardResolve dns (const $ return ()) 1000000 n 216 as <- rawForwardResolve dns (const $ return ()) 1000000 n
201 if null as 217 if null as
@@ -209,7 +225,7 @@ parseAddress addr_str = do
209 (Just "0") 225 (Just "0")
210 return . listToMaybe $ map addrAddress info 226 return . listToMaybe $ map addrAddress info
211 227
228
212withPort :: SockAddr -> Int -> SockAddr 229withPort :: SockAddr -> Int -> SockAddr
213withPort (SockAddrInet _ a) port = SockAddrInet (toEnum port) a 230withPort (SockAddrInet _ a) port = SockAddrInet (toEnum port) a
214withPort (SockAddrInet6 _ a b c) port = SockAddrInet6 (toEnum port) a b c 231withPort (SockAddrInet6 _ a b c) port = SockAddrInet6 (toEnum port) a b c
215
diff --git a/Presence/FGConsole.hs b/Presence/FGConsole.hs
index 6686e19f..623fb493 100644
--- a/Presence/FGConsole.hs
+++ b/Presence/FGConsole.hs
@@ -50,6 +50,7 @@ monitorTTY handler = do
50 monitor 50 monitor
51 return (rfd,thread) 51 return (rfd,thread)
52 52
53unmonitorTTY :: (Fd, ThreadId) -> IO ()
53unmonitorTTY (rfd,thread) = do 54unmonitorTTY (rfd,thread) = do
54 closeFd rfd 55 closeFd rfd
55 yield 56 yield
diff --git a/Presence/Logging.hs b/Presence/Logging.hs
index f55e2e79..b997d341 100644
--- a/Presence/Logging.hs
+++ b/Presence/Logging.hs
@@ -1,10 +1,18 @@
1{-# LANGUAGE RankNTypes #-}
1module Logging where 2module Logging where
2 3
3import qualified Data.ByteString.Lazy.Char8 as L 4import qualified Data.ByteString.Lazy.Char8 as L
4import qualified Data.ByteString.Char8 as S 5import qualified Data.ByteString.Char8 as S
5import qualified Data.Text.IO as Text 6import qualified Data.Text.IO as Text
7import qualified Data.Text as Text
6import qualified Debug.Trace as Debug 8import qualified Debug.Trace as Debug
7 9
10debugL :: L.ByteString -> IO ()
11debugS :: S.ByteString -> IO ()
12debugStr :: String -> IO ()
13debugText :: Text.Text -> IO ()
14trace :: forall a. String -> a -> a
15
8 16
9debugStr str = putStrLn str 17debugStr str = putStrLn str
10 18
diff --git a/Presence/Paths.hs b/Presence/Paths.hs
index ac7c0938..9d51b66e 100644
--- a/Presence/Paths.hs
+++ b/Presence/Paths.hs
@@ -3,6 +3,35 @@ module Paths where
3 3
4#include <paths.h> 4#include <paths.h>
5 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
6bshell = _PATH_BSHELL 35bshell = _PATH_BSHELL
7console = _PATH_CONSOLE 36console = _PATH_CONSOLE
8cshell = _PATH_CSHELL 37cshell = _PATH_CSHELL
diff --git a/Presence/PeerResolve.hs b/Presence/PeerResolve.hs
index 39607ef4..0854b365 100644
--- a/Presence/PeerResolve.hs
+++ b/Presence/PeerResolve.hs
@@ -26,6 +26,7 @@ import ConnectionKey
26import ControlMaybe 26import ControlMaybe
27 27
28{-# NOINLINE global_dns_cache #-} 28{-# NOINLINE global_dns_cache #-}
29global_dns_cache :: DNSCache
29global_dns_cache = unsafePerformIO $ newDNSCache 30global_dns_cache = unsafePerformIO $ newDNSCache
30 31
31resolvePeer :: Text -> IO [SockAddr] 32resolvePeer :: Text -> IO [SockAddr]
@@ -36,4 +37,3 @@ peerKeyToResolvedNames k@(ClientKey { localAddress=addr }) = return []
36peerKeyToResolvedNames k@(PeerKey { callBackAddress=addr }) = do 37peerKeyToResolvedNames k@(PeerKey { callBackAddress=addr }) = do
37 reverseResolve global_dns_cache addr 38 reverseResolve global_dns_cache addr
38 39
39
diff --git a/Presence/UTmp.hs b/Presence/UTmp.hs
index 2cfbdf38..b43278da 100644
--- a/Presence/UTmp.hs
+++ b/Presence/UTmp.hs
@@ -1,5 +1,6 @@
1{-# LANGUAGE TemplateHaskell #-} 1{-# LANGUAGE TemplateHaskell #-}
2module UTmp 2{-# LANGUAGE RankNTypes #-}
3module UTmp
3 ( users 4 ( users
4 , users2 5 , users2
5 , utmp_file 6 , utmp_file
@@ -31,10 +32,28 @@ import qualified Data.Text.Encoding as Text
31import SockAddr () 32import SockAddr ()
32 33
33 34
35utmp_file :: String
34utmp_file = Paths.utmp -- "/var/run/utmp" 36utmp_file = Paths.utmp -- "/var/run/utmp"
35 37
38utmp_bs :: IO C.ByteString
36utmp_bs = S.readFile utmp_file 39utmp_bs = S.readFile utmp_file
37 40
41decode_utmp_bytestring ::
42 C.ByteString
43 -> (Word32,
44 Word32,
45 C.ByteString,
46 C.ByteString,
47 C.ByteString,
48 C.ByteString,
49 Word16,
50 Word16,
51 Word32,
52 C.ByteString,
53 Word32,
54 Word32,
55 Word32,
56 Word32)
38decode_utmp_bytestring = 57decode_utmp_bytestring =
39 runIdentity 58 runIdentity
40 . $(bitSyn [ UnsignedLE 4 -- type 59 . $(bitSyn [ UnsignedLE 4 -- type
@@ -54,9 +73,11 @@ decode_utmp_bytestring =
54 , Skip 20 -- reserved 73 , Skip 20 -- reserved
55 ]) 74 ])
56 75
76utmp_size :: Int
57utmp_size = 384 -- 768 77utmp_size = 384 -- 768
58 78
59 79
80utmp_records :: C.ByteString -> [C.ByteString]
60utmp_records bs | S.length bs >= utmp_size 81utmp_records bs | S.length bs >= utmp_size
61 = u:utmp_records us 82 = u:utmp_records us
62 where 83 where
@@ -64,10 +85,45 @@ utmp_records bs | S.length bs >= utmp_size
64 85
65utmp_records bs = [bs] 86utmp_records bs = [bs]
66 87
88utmp ::
89 IO
90 [(Word32,
91 Word32,
92 C.ByteString,
93 C.ByteString,
94 C.ByteString,
95 C.ByteString,
96 Word16,
97 Word16,
98 Word32,
99 C.ByteString,
100 Word32,
101 Word32,
102 Word32,
103 Word32)]
67utmp = fmap (map decode_utmp_bytestring . utmp_records) utmp_bs 104utmp = fmap (map decode_utmp_bytestring . utmp_records) utmp_bs
68 105
106toStr :: C.ByteString -> [Char]
69toStr = takeWhile (/='\0') . C.unpack 107toStr = takeWhile (/='\0') . C.unpack
70 108
109interp_utmp_record ::
110 forall t t1 t2 t3 t4 t5 t6 t7 t8 a.
111 Integral a =>
112 (a,
113 Word32,
114 C.ByteString,
115 t,
116 C.ByteString,
117 C.ByteString,
118 t1,
119 t2,
120 t3,
121 t4,
122 t5,
123 t6,
124 t7,
125 t8)
126 -> (UT_Type, [Char], [Char], CPid, [Char])
71interp_utmp_record (typ,pid,tty,inittab,user,hostv4,term,exit,session,time 127interp_utmp_record (typ,pid,tty,inittab,user,hostv4,term,exit,session,time
72 ,addr0,addr1,addr2,addr3) = 128 ,addr0,addr1,addr2,addr3) =
73 ( (toEnum . fromIntegral) typ :: UT_Type 129 ( (toEnum . fromIntegral) typ :: UT_Type
@@ -96,6 +152,7 @@ data UT_Type
96 152
97 deriving (Enum,Show,Eq,Ord,Read) 153 deriving (Enum,Show,Eq,Ord,Read)
98 154
155processAlive :: ProcessID -> IO Bool
99processAlive pid = do 156processAlive pid = do
100 catchError (do { signalProcess nullSignal pid ; return True }) 157 catchError (do { signalProcess nullSignal pid ; return True })
101 $ \e -> do { return (not ( isDoesNotExistError e)); } 158 $ \e -> do { return (not ( isDoesNotExistError e)); }
@@ -115,6 +172,7 @@ users = fmap (map only3) $ do
115 us3 <- filterM (onThrd processAlive) us'' 172 us3 <- filterM (onThrd processAlive) us''
116 return us3 173 return us3
117 174
175only3 :: forall t t1 t2 t3. (t1, t2, t3, t) -> (t1, t2, t3)
118only3 (a,b,c,_) = (a,b,c) 176only3 (a,b,c,_) = (a,b,c)
119 177
120data UtmpRecord = UtmpRecord 178data UtmpRecord = UtmpRecord
@@ -128,8 +186,27 @@ data UtmpRecord = UtmpRecord
128 } 186 }
129 deriving ( Show, Eq, Ord ) 187 deriving ( Show, Eq, Ord )
130 188
189toText :: C.ByteString -> Text
131toText bs = Text.decodeUtf8 $ C.takeWhile (/='\0') bs 190toText bs = Text.decodeUtf8 $ C.takeWhile (/='\0') bs
132 191
192interp_utmp_record2 ::
193 forall t t1 t2 t3 a.
194 Integral a =>
195 (a,
196 Word32,
197 C.ByteString,
198 t,
199 C.ByteString,
200 C.ByteString,
201 t1,
202 t2,
203 Word32,
204 t3,
205 Word32,
206 Word32,
207 Word32,
208 Word32)
209 -> UtmpRecord
133interp_utmp_record2 (typ,pid,tty,inittab,user,hostv4 210interp_utmp_record2 (typ,pid,tty,inittab,user,hostv4
134 ,term,exit,session,time,addr0,addr1,addr2,addr3) = 211 ,term,exit,session,time,addr0,addr1,addr2,addr3) =
135 UtmpRecord 212 UtmpRecord
@@ -148,7 +225,7 @@ interp_utmp_record2 (typ,pid,tty,inittab,user,hostv4
148 where 225 where
149 processId = CPid . coerceToSigned 226 processId = CPid . coerceToSigned
150 227
151-- users2 :: IO [(UserName, Tty, ProcessID)] 228users2 :: IO [UtmpRecord]
152users2 = do 229users2 = do
153 us <- utmp 230 us <- utmp
154 let us' = map interp_utmp_record2 us 231 let us' = map interp_utmp_record2 us
diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index 6f834c25..df2945d6 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -63,6 +63,7 @@ import Data.Map (Map)
63import qualified Data.Map as Map 63import qualified Data.Map as Map
64import Data.Set (Set, (\\) ) 64import Data.Set (Set, (\\) )
65import qualified Data.Set as Set 65import qualified Data.Set as Set
66import Data.String ( IsString(..) )
66import qualified System.Random 67import qualified System.Random
67import Data.Void (Void) 68import Data.Void (Void)
68import System.Endian (toBE32) 69import System.Endian (toBE32)
@@ -191,6 +192,10 @@ data XMPPServerParameters =
191 } 192 }
192 193
193 194
195enableClientHacks ::
196 forall t a.
197 (Eq a, IsString a) =>
198 a -> t -> TChan Stanza -> IO ()
194enableClientHacks "Pidgin" version replyto = do 199enableClientHacks "Pidgin" version replyto = do
195 wlog "Enabling hack SimulatedChatErrors for client Pidgin" 200 wlog "Enabling hack SimulatedChatErrors for client Pidgin"
196 donevar <- atomically newEmptyTMVar 201 donevar <- atomically newEmptyTMVar
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 18:51:15 +0000