diff options
author | Joe Crayne <joe@jerkface.net> | 2019-10-17 22:48:46 -0400 |
---|---|---|
committer | Joe Crayne <joe@jerkface.net> | 2020-01-01 19:45:16 -0500 |
commit | 1e193f42fb51ff2e32b80a1f8ca64df421c30dce (patch) | |
tree | 9da87365988b33a0c0051eed55f0b9f270521bae | |
parent | b27c28f1a5c41c25b5693195ec8c15510c144413 (diff) |
Fixed resource-exhausted logic.
-rw-r--r-- | dht/src/Network/StreamServer.hs | 12 | ||||
-rw-r--r-- | test/resourceExhausted.hs | 35 |
2 files changed, 43 insertions, 4 deletions
diff --git a/dht/src/Network/StreamServer.hs b/dht/src/Network/StreamServer.hs index 9a5b8593..1055eaad 100644 --- a/dht/src/Network/StreamServer.hs +++ b/dht/src/Network/StreamServer.hs | |||
@@ -7,6 +7,7 @@ | |||
7 | module Network.StreamServer | 7 | module Network.StreamServer |
8 | ( streamServer | 8 | ( streamServer |
9 | , ServerHandle | 9 | , ServerHandle |
10 | , getAcceptLoopThreadId | ||
10 | , ServerConfig(..) | 11 | , ServerConfig(..) |
11 | , withSession | 12 | , withSession |
12 | , quitListening | 13 | , quitListening |
@@ -49,6 +50,10 @@ import DebugTag | |||
49 | 50 | ||
50 | data ServerHandle = ServerHandle Socket (Weak ThreadId) | 51 | data ServerHandle = ServerHandle Socket (Weak ThreadId) |
51 | 52 | ||
53 | -- | Useful for testing. | ||
54 | getAcceptLoopThreadId :: ServerHandle -> IO (Weak ThreadId) | ||
55 | getAcceptLoopThreadId (ServerHandle _ t) = return t | ||
56 | |||
52 | listenSocket :: ServerHandle -> RestrictedSocket | 57 | listenSocket :: ServerHandle -> RestrictedSocket |
53 | listenSocket (ServerHandle sock _) = restrictSocket sock | 58 | listenSocket (ServerHandle sock _) = restrictSocket sock |
54 | 59 | ||
@@ -149,15 +154,14 @@ acceptLoop cfg sock n = handle (acceptException cfg n sock) $ do | |||
149 | 154 | ||
150 | acceptException :: ServerConfig -> Int -> Socket -> IOError -> IO () | 155 | acceptException :: ServerConfig -> Int -> Socket -> IOError -> IO () |
151 | acceptException cfg n sock ioerror = do | 156 | acceptException cfg n sock ioerror = do |
152 | Socket.close sock | ||
153 | case show (ioeGetErrorType ioerror) of | 157 | case show (ioeGetErrorType ioerror) of |
154 | "resource exhausted" -> do -- try again | 158 | "resource exhausted" -> do -- try again (ioeGetErrorType ioerror == fullErrorType) |
155 | serverWarn cfg $ ("acceptLoop: resource exhasted") | 159 | serverWarn cfg $ ("acceptLoop: resource exhasted") |
156 | threadDelay 500000 | 160 | threadDelay 500000 |
157 | acceptLoop cfg sock (n + 1) | 161 | acceptLoop cfg sock (n + 1) |
158 | "invalid argument" -> do -- quit on closed socket | 162 | "invalid argument" -> do -- quit on closed socket |
159 | return () | 163 | Socket.close sock |
160 | message -> do -- unexpected exception | 164 | message -> do -- unexpected exception |
161 | serverWarn cfg $ ("acceptLoop: "<>bshow message) | 165 | serverWarn cfg $ ("acceptLoop: "<>bshow message) |
162 | return () | 166 | Socket.close sock |
163 | 167 | ||
diff --git a/test/resourceExhausted.hs b/test/resourceExhausted.hs new file mode 100644 index 00000000..4cdef98e --- /dev/null +++ b/test/resourceExhausted.hs | |||
@@ -0,0 +1,35 @@ | |||
1 | import Control.Concurrent | ||
2 | import System.IO | ||
3 | import System.Mem.Weak | ||
4 | import System.IO.Error | ||
5 | |||
6 | import Network.StreamServer | ||
7 | import Network.Address (getBindAddress) | ||
8 | import DPut | ||
9 | import DebugTag | ||
10 | |||
11 | sesh sock n h = do | ||
12 | s <- hGetContents h | ||
13 | putStr s | ||
14 | |||
15 | main = do | ||
16 | setVerbose XMisc | ||
17 | bind <- getBindAddress "8889" True | ||
18 | serv <- streamServer (withSession sesh) [bind] | ||
19 | |||
20 | wtid <- getAcceptLoopThreadId serv | ||
21 | mtid <- deRefWeak wtid | ||
22 | case mtid of | ||
23 | Nothing -> hPutStrLn stderr "missing accept loop?" | ||
24 | Just tid -> do | ||
25 | threadDelay 1000000 | ||
26 | hPutStrLn stderr "Throwing execption now..." | ||
27 | let -- e = userError "resource exhausted" `ioeSetErrorType` fullErrorType | ||
28 | e = mkIOError fullErrorType "resourceExhausted.hs" Nothing Nothing | ||
29 | throwTo tid e | ||
30 | hPutStrLn stderr "Thrown." | ||
31 | |||
32 | getLine | ||
33 | |||
34 | quitListening serv | ||
35 | return () | ||