diff options
author | Joe Crayne <joe@jerkface.net> | 2020-01-03 15:35:23 -0500 |
---|---|---|
committer | Joe Crayne <joe@jerkface.net> | 2020-01-03 17:26:06 -0500 |
commit | 31b799222cb76cd0002d9a3cc5b340a7b6fed139 (patch) | |
tree | 8b834e455529fb270375e4967d1acad56553544f /dht/Presence | |
parent | 1e03ed3670a8386ede93a09fa0c67785e7da6478 (diff) |
server library.
Diffstat (limited to 'dht/Presence')
-rw-r--r-- | dht/Presence/ControlMaybe.hs | 64 | ||||
-rw-r--r-- | dht/Presence/DNSCache.hs | 285 | ||||
-rw-r--r-- | dht/Presence/GetHostByAddr.hs | 77 | ||||
-rw-r--r-- | dht/Presence/SockAddr.hs | 14 |
4 files changed, 0 insertions, 440 deletions
diff --git a/dht/Presence/ControlMaybe.hs b/dht/Presence/ControlMaybe.hs deleted file mode 100644 index a101d667..00000000 --- a/dht/Presence/ControlMaybe.hs +++ /dev/null | |||
@@ -1,64 +0,0 @@ | |||
1 | {-# LANGUAGE CPP #-} | ||
2 | {-# LANGUAGE ScopedTypeVariables #-} | ||
3 | module ControlMaybe | ||
4 | ( module ControlMaybe | ||
5 | , module Data.Functor | ||
6 | ) where | ||
7 | |||
8 | -- import GHC.IO.Exception (IOException(..)) | ||
9 | import Control.Monad | ||
10 | import Data.Functor | ||
11 | import System.IO.Error | ||
12 | |||
13 | |||
14 | -- forM_ with less polymorphism. | ||
15 | withJust :: Monad m => Maybe x -> (x -> m ()) -> m () | ||
16 | withJust m f = forM_ m f | ||
17 | {-# INLINE withJust #-} | ||
18 | |||
19 | whenJust :: Monad m => m (Maybe x) -> (x -> m ()) -> m () | ||
20 | whenJust acn f = acn >>= mapM_ f | ||
21 | {-# INLINE whenJust #-} | ||
22 | |||
23 | |||
24 | catchIO_ :: IO a -> IO a -> IO a | ||
25 | catchIO_ body catcher = catchIOError body (\_ -> catcher) | ||
26 | {-# INLINE catchIO_ #-} | ||
27 | |||
28 | handleIO_ :: IO a -> IO a -> IO a | ||
29 | handleIO_ catcher body = catchIOError body (\_ -> catcher) | ||
30 | {-# INLINE handleIO_ #-} | ||
31 | |||
32 | |||
33 | handleIO :: (IOError -> IO a) -> IO a -> IO a | ||
34 | handleIO 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 | ||
59 | as <&> f = f <$> as | ||
60 | |||
61 | infixl 1 <&> | ||
62 | #endif | ||
63 | |||
64 | |||
diff --git a/dht/Presence/DNSCache.hs b/dht/Presence/DNSCache.hs deleted file mode 100644 index 9bb354e1..00000000 --- a/dht/Presence/DNSCache.hs +++ /dev/null | |||
@@ -1,285 +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 #-} | ||
14 | module DNSCache | ||
15 | ( DNSCache | ||
16 | , reverseResolve | ||
17 | , forwardResolve | ||
18 | , newDNSCache | ||
19 | , parseAddress | ||
20 | , unsafeParseAddress | ||
21 | , strip_brackets | ||
22 | , withPort | ||
23 | ) where | ||
24 | |||
25 | import Control.Concurrent.ThreadUtil | ||
26 | import Control.Arrow | ||
27 | import Control.Concurrent.STM | ||
28 | import Data.Text ( Text ) | ||
29 | import Network.Socket ( SockAddr(..), AddrInfoFlag(..), defaultHints, getAddrInfo, AddrInfo(..) ) | ||
30 | import Data.Time.Clock ( UTCTime, getCurrentTime, diffUTCTime ) | ||
31 | import System.IO.Error ( isDoesNotExistError ) | ||
32 | import System.Endian ( fromBE32, toBE32 ) | ||
33 | import Control.Exception ( handle ) | ||
34 | import Data.Map ( Map ) | ||
35 | import qualified Data.Map as Map | ||
36 | import qualified Network.BSD as BSD | ||
37 | import qualified Data.Text as Text | ||
38 | import Control.Monad | ||
39 | import Data.Function | ||
40 | import Data.List | ||
41 | import Data.Ord | ||
42 | import Data.Maybe | ||
43 | import System.IO.Error | ||
44 | import System.IO.Unsafe | ||
45 | |||
46 | import SockAddr () | ||
47 | import ControlMaybe ( handleIO_ ) | ||
48 | import GetHostByAddr ( getHostByAddr ) | ||
49 | import Control.Concurrent.Delay | ||
50 | import DPut | ||
51 | import DebugTag | ||
52 | |||
53 | type TimeStamp = UTCTime | ||
54 | |||
55 | data DNSCache = | ||
56 | DNSCache | ||
57 | { fcache :: TVar (Map Text [(TimeStamp, SockAddr)]) | ||
58 | , rcache :: TVar (Map SockAddr [(TimeStamp, Text)]) | ||
59 | } | ||
60 | |||
61 | |||
62 | newDNSCache :: IO DNSCache | ||
63 | newDNSCache = do | ||
64 | fcache <- newTVarIO Map.empty | ||
65 | rcache <- newTVarIO Map.empty | ||
66 | return DNSCache { fcache=fcache, rcache=rcache } | ||
67 | |||
68 | updateCache :: Eq x => | ||
69 | Bool -> TimeStamp -> [x] -> Maybe [(TimeStamp,x)] -> Maybe [(TimeStamp,x)] | ||
70 | updateCache withScrub utc xs mys = do | ||
71 | let ys = maybe [] id mys | ||
72 | ys' = filter scrub ys | ||
73 | ys'' = map (utc,) xs ++ ys' | ||
74 | minute = 60 | ||
75 | scrub (t,x) | withScrub && diffUTCTime utc t < minute = False | ||
76 | scrub (t,x) | x `elem` xs = False | ||
77 | scrub _ = True | ||
78 | guard $ not (null ys'') | ||
79 | return ys'' | ||
80 | |||
81 | dnsObserve :: DNSCache -> Bool -> TimeStamp -> [(Text,SockAddr)] -> STM () | ||
82 | dnsObserve dns withScrub utc obs = do | ||
83 | f <- readTVar $ fcache dns | ||
84 | r <- readTVar $ rcache dns | ||
85 | let obs' = map (\(n,a)->(n,a `withPort` 0)) obs | ||
86 | gs = do | ||
87 | g <- groupBy ((==) `on` fst) $ sortBy (comparing fst) obs' | ||
88 | (n,_) <- take 1 g | ||
89 | return (n,map snd g) | ||
90 | f' = foldl' updatef f gs | ||
91 | hs = do | ||
92 | h <- groupBy ((==) `on` snd) $ sortBy (comparing snd) obs' | ||
93 | (_,a) <- take 1 h | ||
94 | return (a,map fst h) | ||
95 | r' = foldl' updater r hs | ||
96 | writeTVar (fcache dns) f' | ||
97 | writeTVar (rcache dns) r' | ||
98 | where | ||
99 | updatef f (n,addrs) = Map.alter (updateCache withScrub utc addrs) n f | ||
100 | updater r (a,ns) = Map.alter (updateCache withScrub utc ns) a r | ||
101 | |||
102 | make6mapped4 :: SockAddr -> SockAddr | ||
103 | make6mapped4 addr@(SockAddrInet6 {}) = addr | ||
104 | make6mapped4 addr@(SockAddrInet port a) = SockAddrInet6 port 0 (0,0,0xFFFF,fromBE32 a) 0 | ||
105 | |||
106 | tryForkOS :: String -> IO () -> IO ThreadId | ||
107 | tryForkOS lbl action = catchIOError (forkOSLabeled lbl action) $ \e -> do | ||
108 | dput XMisc $ "DNSCache: Link with -threaded to avoid excessively long time-out." | ||
109 | forkLabeled lbl action | ||
110 | |||
111 | |||
112 | -- Attempt to resolve the given domain name. Returns an empty list if the | ||
113 | -- resolve operation takes longer than the timeout, but the 'DNSCache' will be | ||
114 | -- updated when the resolve completes. | ||
115 | -- | ||
116 | -- When the resolve operation does complete, any entries less than a minute old | ||
117 | -- will be overwritten with the new results. Older entries are allowed to | ||
118 | -- persist for reasons I don't understand as of this writing. (See 'updateCache') | ||
119 | rawForwardResolve :: | ||
120 | DNSCache -> (Text -> IO ()) -> Int -> Text -> IO [SockAddr] | ||
121 | rawForwardResolve dns onFail timeout addrtext = do | ||
122 | r <- atomically newEmptyTMVar | ||
123 | mvar <- interruptibleDelay | ||
124 | rt <- tryForkOS ("resolve."++show addrtext) $ do | ||
125 | resolver r mvar | ||
126 | startDelay mvar timeout | ||
127 | did <- atomically $ tryPutTMVar r [] | ||
128 | when did (onFail addrtext) | ||
129 | atomically $ readTMVar r | ||
130 | where | ||
131 | resolver r mvar = do | ||
132 | xs <- handle (\e -> let _ = isDoesNotExistError e in return []) | ||
133 | $ do fmap (nub . map (make6mapped4 . addrAddress)) $ | ||
134 | getAddrInfo (Just $ defaultHints { addrFlags = [ AI_CANONNAME, AI_V4MAPPED ]}) | ||
135 | (Just $ Text.unpack $ strip_brackets addrtext) | ||
136 | (Just "5269") | ||
137 | did <- atomically $ tryPutTMVar r xs | ||
138 | when did $ do | ||
139 | interruptDelay mvar | ||
140 | utc <- getCurrentTime | ||
141 | atomically $ dnsObserve dns True utc $ map (addrtext,) xs | ||
142 | return () | ||
143 | |||
144 | strip_brackets :: Text -> Text | ||
145 | strip_brackets s = | ||
146 | case Text.uncons s of | ||
147 | Just ('[',t) -> Text.takeWhile (/=']') t | ||
148 | _ -> s | ||
149 | |||
150 | |||
151 | reportTimeout :: forall a. Show a => a -> IO () | ||
152 | reportTimeout addrtext = do | ||
153 | dput XMisc $ "timeout resolving: "++show addrtext | ||
154 | -- killThread rt | ||
155 | |||
156 | unmap6mapped4 :: SockAddr -> SockAddr | ||
157 | unmap6mapped4 addr@(SockAddrInet6 port _ (0,0,0xFFFF,a) _) = | ||
158 | SockAddrInet port (toBE32 a) | ||
159 | unmap6mapped4 addr = addr | ||
160 | |||
161 | rawReverseResolve :: | ||
162 | DNSCache -> (SockAddr -> IO ()) -> Int -> SockAddr -> IO [Text] | ||
163 | rawReverseResolve dns onFail timeout addr = do | ||
164 | r <- atomically newEmptyTMVar | ||
165 | mvar <- interruptibleDelay | ||
166 | rt <- forkOS $ resolver r mvar | ||
167 | startDelay mvar timeout | ||
168 | did <- atomically $ tryPutTMVar r [] | ||
169 | when did (onFail addr) | ||
170 | atomically $ readTMVar r | ||
171 | where | ||
172 | resolver r mvar = | ||
173 | handleIO_ (return ()) $ do | ||
174 | ent <- getHostByAddr (unmap6mapped4 addr) -- AF_UNSPEC addr | ||
175 | let names = BSD.hostName ent : BSD.hostAliases ent | ||
176 | xs = map Text.pack $ nub names | ||
177 | forkIO $ do | ||
178 | utc <- getCurrentTime | ||
179 | atomically $ dnsObserve dns False utc $ map (,addr) xs | ||
180 | atomically $ putTMVar r xs | ||
181 | |||
182 | -- Returns expired (older than a minute) cached reverse-dns results | ||
183 | -- and removes them from the cache. | ||
184 | expiredReverse :: DNSCache -> SockAddr -> IO [Text] | ||
185 | expiredReverse dns addr = do | ||
186 | utc <- getCurrentTime | ||
187 | addr <- return $ addr `withPort` 0 | ||
188 | es <- atomically $ do | ||
189 | r <- readTVar $ rcache dns | ||
190 | let ns = maybe [] id $ Map.lookup addr r | ||
191 | minute = 60 -- seconds | ||
192 | -- XXX: Is this right? flip diffUTCTime utc returns the age of the | ||
193 | -- cache entry? | ||
194 | (es0,ns') = partition ( (>=minute) . flip diffUTCTime utc . fst ) ns | ||
195 | es = map snd es0 | ||
196 | modifyTVar' (rcache dns) $ Map.insert addr ns' | ||
197 | f <- readTVar $ fcache dns | ||
198 | let f' = foldl' (flip $ Map.alter (expire utc)) f es | ||
199 | expire utc Nothing = Nothing | ||
200 | expire utc (Just as) = if null as' then Nothing else Just as' | ||
201 | where as' = filter ( (<minute) . flip diffUTCTime utc . fst) as | ||
202 | writeTVar (fcache dns) f' | ||
203 | return es | ||
204 | return es | ||
205 | |||
206 | cachedReverse :: DNSCache -> SockAddr -> IO [Text] | ||
207 | cachedReverse dns addr = do | ||
208 | utc <- getCurrentTime | ||
209 | addr <- return $ addr `withPort` 0 | ||
210 | atomically $ do | ||
211 | r <- readTVar (rcache dns) | ||
212 | let ns = maybe [] id $ Map.lookup addr r | ||
213 | {- | ||
214 | ns' = filter ( (<minute) . flip diffUTCTime utc . fst) ns | ||
215 | minute = 60 -- seconds | ||
216 | modifyTVar' (rcache dns) $ Map.insert addr ns' | ||
217 | return $ map snd ns' | ||
218 | -} | ||
219 | return $ map snd ns | ||
220 | |||
221 | -- Returns any dns query results for the given name that were observed less | ||
222 | -- than a minute ago and updates the forward-cache to remove any results older | ||
223 | -- than that. | ||
224 | cachedForward :: DNSCache -> Text -> IO [SockAddr] | ||
225 | cachedForward dns n = do | ||
226 | utc <- getCurrentTime | ||
227 | atomically $ do | ||
228 | f <- readTVar (fcache dns) | ||
229 | let as = maybe [] id $ Map.lookup n f | ||
230 | as' = filter ( (<minute) . flip diffUTCTime utc . fst) as | ||
231 | minute = 60 -- seconds | ||
232 | modifyTVar' (fcache dns) $ Map.insert n as' | ||
233 | return $ map snd as' | ||
234 | |||
235 | -- Reverse-resolves an address to a domain name. Returns both the result of a | ||
236 | -- new query and any freshly cached results. Cache entries older than a minute | ||
237 | -- will not be returned, but will be refreshed in spawned threads so that they | ||
238 | -- may be available for the next call. | ||
239 | reverseResolve :: DNSCache -> SockAddr -> IO [Text] | ||
240 | reverseResolve dns addr = do | ||
241 | expired <- expiredReverse dns addr | ||
242 | forM_ expired $ \n -> forkIO $ do | ||
243 | rawForwardResolve dns (const $ return ()) 1000000 n | ||
244 | return () | ||
245 | xs <- rawReverseResolve dns (const $ return ()) 1000000 addr | ||
246 | cs <- cachedReverse dns addr | ||
247 | return $ xs ++ filter (not . flip elem xs) cs | ||
248 | |||
249 | -- Resolves a name, if there's no result within one second, then any cached | ||
250 | -- results that are less than a minute old are returned. | ||
251 | forwardResolve :: DNSCache -> Text -> IO [SockAddr] | ||
252 | forwardResolve dns n = do | ||
253 | as <- rawForwardResolve dns (const $ return ()) 1000000 n | ||
254 | if null as | ||
255 | then cachedForward dns n | ||
256 | else return as | ||
257 | |||
258 | parseAddress :: Text -> IO (Maybe SockAddr) | ||
259 | parseAddress addr_str = do | ||
260 | info <- getAddrInfo (Just $ defaultHints { addrFlags = [ AI_NUMERICHOST ] }) | ||
261 | (Just . Text.unpack $ addr_str) | ||
262 | (Just "0") | ||
263 | return . listToMaybe $ map addrAddress info | ||
264 | |||
265 | |||
266 | splitAtPort :: String -> (String,String) | ||
267 | splitAtPort s = second sanitizePort $ case s of | ||
268 | ('[':t) -> break (==']') t | ||
269 | _ -> break (==':') s | ||
270 | where | ||
271 | sanitizePort (']':':':p) = p | ||
272 | sanitizePort (':':p) = p | ||
273 | sanitizePort _ = "0" | ||
274 | |||
275 | unsafeParseAddress :: String -> Maybe SockAddr | ||
276 | unsafeParseAddress addr_str = unsafePerformIO $ do | ||
277 | let (ipstr,portstr) = splitAtPort addr_str | ||
278 | info <- getAddrInfo (Just $ defaultHints { addrFlags = [ AI_NUMERICHOST ] }) | ||
279 | (Just ipstr) | ||
280 | (Just portstr) | ||
281 | return . listToMaybe $ map addrAddress info | ||
282 | |||
283 | withPort :: SockAddr -> Int -> SockAddr | ||
284 | withPort (SockAddrInet _ a) port = SockAddrInet (toEnum port) a | ||
285 | withPort (SockAddrInet6 _ a b c) port = SockAddrInet6 (toEnum port) a b c | ||
diff --git a/dht/Presence/GetHostByAddr.hs b/dht/Presence/GetHostByAddr.hs deleted file mode 100644 index 45bca5e9..00000000 --- a/dht/Presence/GetHostByAddr.hs +++ /dev/null | |||
@@ -1,77 +0,0 @@ | |||
1 | {-# LANGUAGE ForeignFunctionInterface #-} | ||
2 | module GetHostByAddr where | ||
3 | |||
4 | import Network.BSD | ||
5 | import Foreign.Ptr | ||
6 | import Foreign.C.Types | ||
7 | import Foreign.Storable (Storable(..)) | ||
8 | import Foreign.Marshal.Utils (with) | ||
9 | import Foreign.Marshal.Alloc | ||
10 | import Control.Concurrent | ||
11 | import System.IO.Unsafe | ||
12 | import System.IO.Error (ioeSetErrorString, mkIOError) | ||
13 | import Network.Socket | ||
14 | import GHC.IO.Exception | ||
15 | |||
16 | |||
17 | throwNoSuchThingIfNull :: String -> String -> IO (Ptr a) -> IO (Ptr a) | ||
18 | throwNoSuchThingIfNull 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 #-} | ||
25 | lock :: MVar () | ||
26 | lock = unsafePerformIO $ newMVar () | ||
27 | |||
28 | withLock :: IO a -> IO a | ||
29 | withLock act = withMVar lock (\_ -> act) | ||
30 | |||
31 | trySysCall :: IO a -> IO a | ||
32 | trySysCall 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. | ||
38 | getHostByAddr :: Family -> SockAddr -> IO HostEntry | ||
39 | getHostByAddr 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 | ||
52 | getHostByAddr :: SockAddr -> IO HostEntry | ||
53 | getHostByAddr (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 | ||
59 | getHostByAddr (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 | |||
72 | foreign import ccall safe "gethostbyaddr" | ||
73 | c_gethostbyaddr :: Ptr a -> CInt -> CInt -> IO (Ptr HostEntry) | ||
74 | |||
75 | |||
76 | |||
77 | -- vim:ft=haskell: | ||
diff --git a/dht/Presence/SockAddr.hs b/dht/Presence/SockAddr.hs deleted file mode 100644 index b5fbf16e..00000000 --- a/dht/Presence/SockAddr.hs +++ /dev/null | |||
@@ -1,14 +0,0 @@ | |||
1 | {-# LANGUAGE CPP #-} | ||
2 | {-# LANGUAGE StandaloneDeriving #-} | ||
3 | module SockAddr () where | ||
4 | |||
5 | #if MIN_VERSION_network(2,4,0) | ||
6 | import Network.Socket () | ||
7 | #else | ||
8 | import Network.Socket ( SockAddr(..) ) | ||
9 | |||
10 | deriving instance Ord SockAddr | ||
11 | #endif | ||
12 | |||
13 | |||
14 | |||