├── Setup.hs ├── .gitignore ├── examples ├── tcpClient.hs ├── udpServer.hs ├── tcpServer.hs └── udpClient.hs ├── network-run.cabal ├── LICENSE ├── fourmolu.yaml ├── CHANGELOG.md └── Network └── Run ├── TCP └── Timeout.hs ├── UDP.hs ├── TCP.hs └── Core.hs /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | main = defaultMain 4 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.hi 2 | *.o 3 | *~ 4 | .hpc/* 5 | Setup 6 | Setup.exe* 7 | TAGS 8 | autom4te.cache/* 9 | config.log 10 | config.mk 11 | config.status 12 | configure 13 | dist/* 14 | dist-newstyle/* 15 | include/HsNetworkConfig.h 16 | include/HsNetworkConfig.h.in 17 | network.buildinfo 18 | cabal.sandbox.config 19 | .cabal-sandbox 20 | .stack-work/ 21 | .ghc.* 22 | .vscode -------------------------------------------------------------------------------- /examples/tcpClient.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Main (main) where 4 | 5 | import qualified Data.ByteString.Char8 as C 6 | import Network.Run.TCP (runTCPClient) 7 | import Network.Socket.ByteString (recv, sendAll) 8 | 9 | main :: IO () 10 | main = runTCPClient "127.0.0.1" "3000" $ \s -> do 11 | sendAll s "Hello, world!" 12 | msg <- recv s 1024 13 | putStr "Received: " 14 | C.putStrLn msg 15 | -------------------------------------------------------------------------------- /examples/udpServer.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Control.Monad (forever, unless, void) 4 | import qualified Data.ByteString as S 5 | import Network.Run.UDP (runUDPServer) 6 | import Network.Socket.ByteString (recvFrom, sendTo) 7 | 8 | main :: IO () 9 | main = runUDPServer (Just "127.0.0.1") "3000" $ \sock -> forever $ do 10 | (msg, peer) <- recvFrom sock 2048 11 | unless (S.null msg) $ void $ sendTo sock msg peer 12 | -------------------------------------------------------------------------------- /examples/tcpServer.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Control.Monad (unless) 4 | import qualified Data.ByteString as S 5 | import Network.Run.TCP (runTCPServer) 6 | import Network.Socket.ByteString (recv, sendAll) 7 | 8 | main :: IO () 9 | main = runTCPServer Nothing "3000" talk 10 | where 11 | talk s = do 12 | msg <- recv s 1024 13 | unless (S.null msg) $ do 14 | sendAll s msg 15 | talk s 16 | -------------------------------------------------------------------------------- /examples/udpClient.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | -- Echo client program 4 | module Main (main) where 5 | 6 | import qualified Data.ByteString.Char8 as C 7 | import Network.Run.UDP (runUDPClient) 8 | import Network.Socket 9 | import Network.Socket.ByteString (recvFrom, sendTo) 10 | 11 | main :: IO () 12 | main = runUDPClient "127.0.0.1" "3000" $ \sock sockAddr -> do 13 | -- Initially the local port is 0 14 | my1 <- getSocketName sock 15 | putStrLn $ "My sock addr " ++ show my1 16 | putStrLn $ "Peer sock addr " ++ show sockAddr 17 | _ <- sendTo sock "Hello, world!" sockAddr 18 | -- After sendTo, the local port is implicitly bound 19 | my2 <- getSocketName sock 20 | putStrLn $ "My sock addr " ++ show my2 21 | (msg, peer) <- recvFrom sock 1024 22 | putStrLn $ "Peer sock addr " ++ show peer 23 | putStr "Received: " 24 | C.putStrLn msg 25 | -------------------------------------------------------------------------------- /network-run.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >=1.10 2 | name: network-run 3 | version: 0.5.0 4 | license: BSD3 5 | license-file: LICENSE 6 | maintainer: kazu@iij.ad.jp 7 | author: Kazu Yamamoto 8 | synopsis: Simple network runner library 9 | description: Simple functions to run network clients and servers. 10 | category: Network 11 | build-type: Simple 12 | extra-source-files: CHANGELOG.md 13 | 14 | source-repository head 15 | type: git 16 | location: https://github.com/kazu-yamamoto/network-run 17 | 18 | library 19 | exposed-modules: 20 | Network.Run.TCP 21 | Network.Run.TCP.Timeout 22 | Network.Run.UDP 23 | 24 | other-modules: Network.Run.Core 25 | default-language: Haskell2010 26 | build-depends: 27 | base >=4 && <5, 28 | bytestring, 29 | network >=3.2.4, 30 | time-manager >=0.2 && <0.4 31 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2019, IIJ Innovation Institute Inc. 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions 6 | are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | * Redistributions in binary form must reproduce the above copyright 11 | notice, this list of conditions and the following disclaimer in 12 | the documentation and/or other materials provided with the 13 | distribution. 14 | * Neither the name of the copyright holders nor the names of its 15 | contributors may be used to endorse or promote products derived 16 | from this software without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 21 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 22 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 23 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 24 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 25 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 26 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 27 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 28 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 29 | POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /fourmolu.yaml: -------------------------------------------------------------------------------- 1 | # Number of spaces per indentation step 2 | indentation: 4 3 | 4 | # Max line length for automatic line breaking 5 | column-limit: 80 6 | 7 | # Styling of arrows in type signatures (choices: trailing, leading, or leading-args) 8 | function-arrows: leading 9 | 10 | # How to place commas in multi-line lists, records, etc. (choices: leading or trailing) 11 | comma-style: leading 12 | 13 | # Styling of import/export lists (choices: leading, trailing, or diff-friendly) 14 | import-export-style: diff-friendly 15 | 16 | # Whether to full-indent or half-indent 'where' bindings past the preceding body 17 | indent-wheres: false 18 | 19 | # Whether to leave a space before an opening record brace 20 | record-brace-space: false 21 | 22 | # Number of spaces between top-level declarations 23 | newlines-between-decls: 1 24 | 25 | # How to print Haddock comments (choices: single-line, multi-line, or multi-line-compact) 26 | haddock-style: single-line 27 | 28 | # How to print module docstring 29 | haddock-style-module: null 30 | 31 | # Styling of let blocks (choices: auto, inline, newline, or mixed) 32 | let-style: inline 33 | 34 | # How to align the 'in' keyword with respect to the 'let' keyword (choices: left-align, right-align, or no-space) 35 | in-style: right-align 36 | 37 | # Whether to put parentheses around a single constraint (choices: auto, always, or never) 38 | single-constraint-parens: never 39 | 40 | # Output Unicode syntax (choices: detect, always, or never) 41 | unicode: never 42 | 43 | # Give the programmer more choice on where to insert blank lines 44 | respectful: true 45 | 46 | # Fixity information for operators 47 | fixities: [] 48 | 49 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for network-run 2 | 3 | ## 0.5.0 4 | 5 | * Fixing a bug that TimeoutServer is not killed. 6 | * Breaking change: the signatures of Timeout.runTCPServer and 7 | Timeout.runTCPServerWithSocket are changed. 8 | 9 | ## 0.4.3 10 | 11 | * Using time-manager >= 0.2. 12 | 13 | ## 0.4.2 14 | 15 | * Using `withHandle` of time-manager. 16 | 17 | ## 0.4.1 18 | 19 | * Make sure to cancel Handles. 20 | [#13](https://github.com/kazu-yamamoto/network-run/pull/13) 21 | * New API: `openClientSocketWithOpts`, `openServerSocketWithOpts` 22 | and `openTCPServerSocketWithOpts`. 23 | [#12](https://github.com/kazu-yamamoto/network-run/pull/12) 24 | 25 | ## 0.4.0 26 | 27 | * New API: `openTCPServerSocket`, `runTCPClientWithSettings`, etc. 28 | * Breaking change: runTCPServerSocket takes a socket itself 29 | 30 | ## 0.3.2 31 | 32 | * Add `openServerSocketWithOptions`, `openClientSocketWithOptions`, 33 | `runTCPServerWithSocketOptions`, `runTCPClientWithSocketOptions`. 34 | [#6](https://github.com/kazu-yamamoto/network-run/pull/6) 35 | 36 | ## 0.3.1 37 | 38 | * Using close instead of gracefulClose for client 39 | [#5](https://github.com/kazu-yamamoto/network-run/pull/5) 40 | 41 | ## 0.3.0 42 | 43 | * Specifying IPv6Only 44 | [#4](https://github.com/kazu-yamamoto/network-run/pull/4) 45 | 46 | ## 0.2.8 47 | 48 | * runTCPClient specifies AI_ADDRCONFIG. 49 | 50 | ## 0.2.7 51 | 52 | * Introduce `runTCPServerWithSocket` 53 | [#3](https://github.com/kazu-yamamoto/network-run/pull/3) 54 | 55 | ## 0.2.6 56 | 57 | * Adding the Network.Run.TCP.Timeout module. 58 | 59 | ## 0.2.5 60 | 61 | * Making accept breakable on windows 62 | [#2](https://github.com/kazu-yamamoto/network-run/pull/2) 63 | -------------------------------------------------------------------------------- /Network/Run/TCP/Timeout.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | -- | Simple functions to run TCP clients and servers. 4 | module Network.Run.TCP.Timeout ( 5 | runTCPServer, 6 | TimeoutServer, 7 | 8 | -- * Generalized API 9 | runTCPServerWithSocket, 10 | openServerSocket, 11 | openServerSocketWithOptions, 12 | openServerSocketWithOpts, 13 | ) where 14 | 15 | import Control.Concurrent (forkFinally) 16 | import qualified Control.Exception as E 17 | import Control.Monad (forever, void) 18 | import qualified Data.List.NonEmpty as NE 19 | import Network.Socket 20 | import qualified System.TimeManager as T 21 | 22 | import Network.Run.Core 23 | 24 | -- | A server type 25 | type TimeoutServer a = 26 | T.Manager 27 | -- ^ A global timeout manager 28 | -> T.Handle 29 | -- ^ A thread-local timeout handler 30 | -> Socket 31 | -- ^ A connected socket 32 | -> IO a 33 | 34 | -- | Running a TCP server with a connected socket. 35 | runTCPServer 36 | :: Int 37 | -- ^ Timeout in second. 38 | -> Maybe HostName 39 | -> ServiceName 40 | -> TimeoutServer () 41 | -> IO () 42 | runTCPServer tm mhost port server = do 43 | addr <- resolve Stream mhost port [AI_PASSIVE] NE.head 44 | E.bracket (openTCPServerSocket addr) close $ \sock -> 45 | runTCPServerWithSocket tm sock server 46 | 47 | -- | Running a TCP client with a connected socket for a given listen 48 | -- socket. 49 | runTCPServerWithSocket 50 | :: Int 51 | -- ^ Timeout in second. 52 | -> Socket 53 | -> TimeoutServer () 54 | -> IO () 55 | runTCPServerWithSocket tm sock server = do 56 | T.withManager (tm * 1000000) $ \mgr -> forever $ 57 | E.bracketOnError (accept sock) (close . fst) $ \(conn, _peer) -> 58 | void $ forkFinally (runServer mgr conn) (const $ gclose conn) 59 | where 60 | runServer mgr conn = do 61 | labelMe "TCP timeout server" 62 | T.withHandleKillThread mgr (return ()) $ \th -> server mgr th conn 63 | -------------------------------------------------------------------------------- /Network/Run/UDP.hs: -------------------------------------------------------------------------------- 1 | -- | Simple functions to run UDP clients and servers. 2 | module Network.Run.UDP ( 3 | runUDPClient, 4 | runUDPServer, 5 | runUDPServerFork, 6 | ) where 7 | 8 | import Control.Concurrent (forkFinally, forkIO) 9 | import qualified Control.Exception as E 10 | import Control.Monad (forever, void) 11 | import Data.ByteString (ByteString) 12 | import qualified Data.List.NonEmpty as NE 13 | import Network.Socket 14 | import Network.Socket.ByteString 15 | 16 | import Network.Run.Core 17 | 18 | -- | Running a UDP client with a socket. 19 | -- The client action takes a socket and 20 | -- server's socket address. 21 | -- They should be used with 'sendTo'. 22 | runUDPClient :: HostName -> ServiceName -> (Socket -> SockAddr -> IO a) -> IO a 23 | runUDPClient host port client = do 24 | addr <- resolve Datagram (Just host) port [AI_ADDRCONFIG] NE.head 25 | let sockAddr = addrAddress addr 26 | E.bracket (openSocket addr) close $ \sock -> client sock sockAddr 27 | 28 | -- | Running a UDP server with an open socket in a single Haskell thread. 29 | runUDPServer :: Maybe HostName -> ServiceName -> (Socket -> IO a) -> IO a 30 | runUDPServer mhost port server = do 31 | addr <- resolve Datagram mhost port [AI_PASSIVE] NE.head 32 | E.bracket (openServerSocket addr) close server 33 | 34 | -- | Running a UDP server with a connected socket in each Haskell thread. 35 | -- The first request is given to the server. 36 | -- Suppose that the server is serving on __addrS:portS__ and 37 | -- a client connects to the service from __addrC:portC__. 38 | -- A connected socket is created by binding to __*:portS__ and 39 | -- connecting to __addrC:portC__, 40 | -- resulting in __(UDP,addrS:portS,addrC:portC)__ where 41 | -- __addrS__ is given magically. 42 | -- This approach is fragile due to NAT rebidings. 43 | runUDPServerFork 44 | :: [HostName] -> ServiceName -> (Socket -> ByteString -> IO ()) -> IO () 45 | runUDPServerFork [] _ _ = return () 46 | runUDPServerFork (h : hs) port server = do 47 | mapM_ (forkIO . run) hs 48 | run h 49 | where 50 | run host = do 51 | labelMe $ "UDP server for " ++ h 52 | runUDPServer (Just host) port $ \lsock -> forever $ do 53 | (bs0, peeraddr) <- recvFrom lsock 2048 54 | let family = case peeraddr of 55 | SockAddrInet{} -> AF_INET 56 | SockAddrInet6{} -> AF_INET6 57 | _ -> error "family" 58 | hints = 59 | defaultHints 60 | { addrSocketType = Datagram 61 | , addrFamily = family 62 | , addrFlags = [AI_PASSIVE] 63 | } 64 | addr <- NE.head <$> getAddrInfo (Just hints) Nothing (Just port) 65 | s <- openServerSocket addr 66 | connect s peeraddr 67 | void $ forkFinally (labelMe "UDP server" >> server s bs0) (\_ -> close s) 68 | -------------------------------------------------------------------------------- /Network/Run/TCP.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | 4 | -- | Simple functions to run TCP clients and servers. 5 | module Network.Run.TCP ( 6 | -- * Server 7 | runTCPServer, 8 | runTCPServerWithSocket, 9 | openTCPServerSocket, 10 | openTCPServerSocketWithOptions, 11 | openTCPServerSocketWithOpts, 12 | resolve, 13 | 14 | -- * Client 15 | runTCPClient, 16 | Settings, 17 | defaultSettings, 18 | settingsOpenClientSocket, 19 | settingsSelectAddrInfo, 20 | runTCPClientWithSettings, 21 | openClientSocket, 22 | openClientSocketWithOptions, 23 | openClientSocketWithOpts, 24 | ) where 25 | 26 | import Control.Concurrent (forkFinally) 27 | import qualified Control.Exception as E 28 | import Control.Monad (forever, void) 29 | import Data.List.NonEmpty (NonEmpty) 30 | import qualified Data.List.NonEmpty as NE 31 | import Network.Socket 32 | 33 | import Network.Run.Core 34 | 35 | ---------------------------------------------------------------- 36 | 37 | -- | Running a TCP server with an accepted socket and its peer name. 38 | runTCPServer :: Maybe HostName -> ServiceName -> (Socket -> IO a) -> IO a 39 | runTCPServer mhost port server = do 40 | addr <- resolve Stream mhost port [AI_PASSIVE] NE.head 41 | E.bracket (openTCPServerSocket addr) close $ \sock -> 42 | runTCPServerWithSocket sock server 43 | 44 | -- | Running a TCP client with a connected socket for a given listen 45 | -- socket. 46 | runTCPServerWithSocket 47 | :: Socket 48 | -> (Socket -> IO a) 49 | -- ^ Called for each incoming connection, in a new thread 50 | -> IO a 51 | runTCPServerWithSocket sock server = forever $ 52 | E.bracketOnError (accept sock) (close . fst) $ 53 | \(conn, _peer) -> 54 | void $ forkFinally (labelMe "TCP server" >> server conn) (const $ gclose conn) 55 | 56 | ---------------------------------------------------------------- 57 | 58 | -- | Settings for client. 59 | data Settings = Settings 60 | { settingsOpenClientSocket :: AddrInfo -> IO Socket 61 | -- ^ Opening a socket. Use 'openClientSocketWithOptions' to specify 'SocketOption' 62 | , settingsSelectAddrInfo :: NonEmpty AddrInfo -> AddrInfo 63 | -- ^ Selecting 'AddrInfo'. 64 | } 65 | 66 | -- | Default settings. 67 | defaultSettings :: Settings 68 | defaultSettings = 69 | Settings 70 | { settingsOpenClientSocket = openClientSocket 71 | , settingsSelectAddrInfo = NE.head 72 | } 73 | 74 | -- | Running a TCP client with a connected socket. 75 | -- 76 | -- This is the same as: 77 | -- 78 | -- @ 79 | -- 'runTCPClientWithSettings' 'defaultSettings' 80 | -- @ 81 | runTCPClient :: HostName -> ServiceName -> (Socket -> IO a) -> IO a 82 | runTCPClient = runTCPClientWithSettings defaultSettings 83 | 84 | -- | Running a TCP client with a connected socket. 85 | runTCPClientWithSettings 86 | :: Settings 87 | -> HostName 88 | -> ServiceName 89 | -> (Socket -> IO a) 90 | -> IO a 91 | runTCPClientWithSettings Settings{..} host port client = do 92 | addr <- resolve Stream (Just host) port [AI_ADDRCONFIG] settingsSelectAddrInfo 93 | E.bracket (settingsOpenClientSocket addr) close client 94 | -------------------------------------------------------------------------------- /Network/Run/Core.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module Network.Run.Core ( 4 | resolve, 5 | openSocket, 6 | openClientSocket, 7 | openClientSocketWithOptions, 8 | openClientSocketWithOpts, 9 | openServerSocket, 10 | openServerSocketWithOptions, 11 | openServerSocketWithOpts, 12 | openTCPServerSocket, 13 | openTCPServerSocketWithOptions, 14 | openTCPServerSocketWithOpts, 15 | gclose, 16 | labelMe, 17 | ) where 18 | 19 | import Data.List.NonEmpty (NonEmpty) 20 | import Control.Arrow 21 | import Control.Concurrent 22 | import qualified Control.Exception as E 23 | import Control.Monad (when) 24 | import GHC.Conc.Sync 25 | import Network.Socket 26 | 27 | resolve 28 | :: SocketType 29 | -> Maybe HostName 30 | -> ServiceName 31 | -> [AddrInfoFlag] 32 | -> (NonEmpty AddrInfo -> AddrInfo) 33 | -> IO AddrInfo 34 | resolve socketType mhost port flags select = 35 | select <$> getAddrInfo (Just hints) mhost (Just port) 36 | where 37 | hints = 38 | defaultHints 39 | { addrSocketType = socketType 40 | , addrFlags = flags 41 | } 42 | 43 | #if !MIN_VERSION_network(3,1,2) 44 | openSocket :: AddrInfo -> IO Socket 45 | openSocket addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) 46 | #endif 47 | 48 | -- | This is the same as 49 | -- 50 | -- @ 51 | -- 'openClientSocketWithOptions' [] 52 | -- @ 53 | openClientSocket :: AddrInfo -> IO Socket 54 | openClientSocket = openClientSocketWithOptions [] 55 | 56 | -- | Open a client socket with the given options 57 | -- 58 | -- The options are set before 'connect'. This is equivalent to 59 | -- 60 | -- @ 61 | -- 'openClientSocketWithOpts' . 'map' ('second' 'SockOptValue') 62 | -- @ 63 | openClientSocketWithOptions :: [(SocketOption, Int)] -> AddrInfo -> IO Socket 64 | openClientSocketWithOptions = openClientSocketWithOpts . map (second SockOptValue) 65 | 66 | -- | Open a client socket with the given options 67 | -- 68 | -- This must be used rather than 'openClientSocketWithOptions' for options such 69 | -- as 'Network.Socket.Linger' which require a composite value 70 | -- ('Network.Socket.StructLinger'). 71 | -- 72 | -- The options are set before 'connect'. 73 | openClientSocketWithOpts :: [(SocketOption, SockOptValue)] -> AddrInfo -> IO Socket 74 | openClientSocketWithOpts opts addr = E.bracketOnError (openSocket addr) close $ \sock -> do 75 | mapM_ (uncurry $ setSockOptValue sock) opts 76 | connect sock $ addrAddress addr 77 | return sock 78 | 79 | -- | Open socket for server use 80 | -- 81 | -- This is the same as: 82 | -- 83 | -- @ 84 | -- 'openServerSocketWithOptions' [] 85 | -- @ 86 | openServerSocket :: AddrInfo -> IO Socket 87 | openServerSocket = openServerSocketWithOptions [] 88 | 89 | -- | Open socket for server use, and set the provided options before binding. 90 | -- 91 | -- This is equivalent to 92 | -- 93 | -- @ 94 | -- 'openServerSocketWithOpts' . 'map' ('second' 'SockOptValue') 95 | -- @ 96 | openServerSocketWithOptions :: [(SocketOption, Int)] -> AddrInfo -> IO Socket 97 | openServerSocketWithOptions = openServerSocketWithOpts . map (second SockOptValue) 98 | 99 | -- | Open socket for server use, and set the provided options before binding. 100 | -- 101 | -- In addition to the given options, the socket is configured to 102 | -- 103 | -- * allow reuse of local addresses (SO_REUSEADDR) 104 | -- * automatically be closed during a successful @execve@ (FD_CLOEXEC) 105 | -- * bind to the address specified 106 | openServerSocketWithOpts :: [(SocketOption, SockOptValue)] -> AddrInfo -> IO Socket 107 | openServerSocketWithOpts opts addr = E.bracketOnError (openSocket addr) close $ \sock -> do 108 | setSocketOption sock ReuseAddr 1 109 | #if !defined(openbsd_HOST_OS) 110 | when (addrFamily addr == AF_INET6) $ setSocketOption sock IPv6Only 1 111 | #endif 112 | mapM_ (uncurry $ setSockOptValue sock) opts 113 | withFdSocket sock setCloseOnExecIfNeeded 114 | bind sock $ addrAddress addr 115 | return sock 116 | 117 | -- | Open TCP socket for server use 118 | -- 119 | -- This is the same as: 120 | -- 121 | -- @ 122 | -- 'openTCPServerSocketWithOptions' [] 123 | -- @ 124 | openTCPServerSocket :: AddrInfo -> IO Socket 125 | openTCPServerSocket = openTCPServerSocketWithOptions [] 126 | 127 | -- | Open socket for server use, and set the provided options before binding. 128 | -- 129 | -- This is equivalent to 130 | -- 131 | -- @ 132 | -- 'openTCPServerSocketWithOpts' . 'map' ('second' 'SockOptValue') 133 | -- @ 134 | openTCPServerSocketWithOptions :: [(SocketOption, Int)] -> AddrInfo -> IO Socket 135 | openTCPServerSocketWithOptions = openTCPServerSocketWithOpts . map (second SockOptValue) 136 | 137 | -- | Open socket for server use, and set the provided options before binding. 138 | -- 139 | -- In addition to the given options, the socket is configured to 140 | -- 141 | -- * allow reuse of local addresses (SO_REUSEADDR) 142 | -- * automatically be closed during a successful @execve@ (FD_CLOEXEC) 143 | -- * bind to the address specified 144 | -- * listen with queue length with 1024 145 | openTCPServerSocketWithOpts :: [(SocketOption, SockOptValue)] -> AddrInfo -> IO Socket 146 | openTCPServerSocketWithOpts opts addr = do 147 | sock <- openServerSocketWithOpts opts addr 148 | listen sock 1024 149 | return sock 150 | 151 | gclose :: Socket -> IO () 152 | #if MIN_VERSION_network(3,1,1) 153 | gclose sock = gracefulClose sock 5000 154 | #else 155 | gclose = close 156 | #endif 157 | 158 | labelMe :: String -> IO () 159 | labelMe name = do 160 | tid <- myThreadId 161 | labelThread tid name 162 | --------------------------------------------------------------------------------