{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE BangPatterns #-}
module Data.Streaming.Network
(
ServerSettings
, ClientSettings
, HostPreference
, Message (..)
, AppData
#if !WINDOWS
, ServerSettingsUnix
, ClientSettingsUnix
, AppDataUnix
#endif
, serverSettingsTCP
, serverSettingsTCPSocket
, clientSettingsTCP
, serverSettingsUDP
, clientSettingsUDP
#if !WINDOWS
, serverSettingsUnix
, clientSettingsUnix
#endif
, message
, HasPort (..)
, HasAfterBind (..)
, HasReadWrite (..)
, HasReadBufferSize (..)
#if !WINDOWS
, HasPath (..)
#endif
, setPort
, setHost
, setAddrFamily
, setAfterBind
, setNeedLocalAddr
, setReadBufferSize
#if !WINDOWS
, setPath
#endif
, getPort
, getHost
, getAddrFamily
, getAfterBind
, getNeedLocalAddr
, getReadBufferSize
#if !WINDOWS
, getPath
#endif
, appRead
, appWrite
, appSockAddr
, appLocalAddr
, appCloseConnection
, appRawSocket
, bindPortGen
, bindPortGenEx
, bindRandomPortGen
, getSocketGen
, getSocketFamilyGen
, acceptSafe
, unassignedPorts
, getUnassignedPort
, bindPortTCP
, bindRandomPortTCP
, getSocketTCP
, getSocketFamilyTCP
, safeRecv
, runTCPServer
, runTCPClient
, ConnectionHandle()
, runTCPServerWithHandle
, bindPortUDP
, bindRandomPortUDP
, getSocketUDP
#if !WINDOWS
, bindPath
, getSocketUnix
, runUnixServer
, runUnixClient
#endif
) where
import qualified Network.Socket as NS
import Data.Streaming.Network.Internal
import Control.Concurrent (threadDelay)
import Control.Exception (IOException, try, SomeException, throwIO, bracketOnError, bracket)
import Network.Socket (Socket, AddrInfo, SocketType)
import Network.Socket.ByteString (recv, sendAll)
import System.IO.Error (isDoesNotExistError)
import qualified Data.ByteString.Char8 as S8
import qualified Control.Exception as E
import Data.ByteString (ByteString)
import System.Directory (removeFile)
import Data.Functor.Constant (Constant (Constant), getConstant)
import Data.Functor.Identity (Identity (Identity), runIdentity)
import Control.Concurrent (forkIO)
import Control.Monad (forever)
import Data.IORef (IORef, newIORef, atomicModifyIORef)
import Data.Array.Unboxed ((!), UArray, listArray)
import System.IO.Unsafe (unsafePerformIO, unsafeDupablePerformIO)
import System.Random (randomRIO)
import System.IO.Error (isFullErrorType, ioeGetErrorType)
#if WINDOWS
import Control.Concurrent.MVar (putMVar, takeMVar, newEmptyMVar)
#endif
getPossibleAddrs :: SocketType -> String -> Int -> NS.Family -> IO [AddrInfo]
getPossibleAddrs :: SocketType -> String -> Int -> Family -> IO [AddrInfo]
getPossibleAddrs sockettype :: SocketType
sockettype host' :: String
host' port' :: Int
port' af :: Family
af =
Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
NS.getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
hints) (String -> Maybe String
forall a. a -> Maybe a
Just String
host') (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
port')
where
hints :: AddrInfo
hints = AddrInfo
NS.defaultHints {
addrSocketType :: SocketType
NS.addrSocketType = SocketType
sockettype
, addrFamily :: Family
NS.addrFamily = Family
af
}
getSocketFamilyGen :: SocketType -> String -> Int -> NS.Family -> IO (Socket, AddrInfo)
getSocketFamilyGen :: SocketType -> String -> Int -> Family -> IO (Socket, AddrInfo)
getSocketFamilyGen sockettype :: SocketType
sockettype host' :: String
host' port' :: Int
port' af :: Family
af = do
(addr :: AddrInfo
addr:_) <- SocketType -> String -> Int -> Family -> IO [AddrInfo]
getPossibleAddrs SocketType
sockettype String
host' Int
port' Family
af
Socket
sock <- Family -> SocketType -> ProtocolNumber -> IO Socket
NS.socket (AddrInfo -> Family
NS.addrFamily AddrInfo
addr) (AddrInfo -> SocketType
NS.addrSocketType AddrInfo
addr)
(AddrInfo -> ProtocolNumber
NS.addrProtocol AddrInfo
addr)
(Socket, AddrInfo) -> IO (Socket, AddrInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (Socket
sock, AddrInfo
addr)
getSocketGen :: SocketType -> String -> Int -> IO (Socket, AddrInfo)
getSocketGen :: SocketType -> String -> Int -> IO (Socket, AddrInfo)
getSocketGen sockettype :: SocketType
sockettype host :: String
host port :: Int
port = SocketType -> String -> Int -> Family -> IO (Socket, AddrInfo)
getSocketFamilyGen SocketType
sockettype String
host Int
port Family
NS.AF_UNSPEC
defaultSocketOptions :: SocketType -> [(NS.SocketOption, Int)]
defaultSocketOptions :: SocketType -> [(SocketOption, Int)]
defaultSocketOptions sockettype :: SocketType
sockettype =
case SocketType
sockettype of
NS.Datagram -> [(SocketOption
NS.ReuseAddr,1)]
_ -> [(SocketOption
NS.NoDelay,1), (SocketOption
NS.ReuseAddr,1)]
bindPortGen :: SocketType -> Int -> HostPreference -> IO Socket
bindPortGen :: SocketType -> Int -> HostPreference -> IO Socket
bindPortGen sockettype :: SocketType
sockettype = [(SocketOption, Int)]
-> SocketType -> Int -> HostPreference -> IO Socket
bindPortGenEx (SocketType -> [(SocketOption, Int)]
defaultSocketOptions SocketType
sockettype) SocketType
sockettype
bindPortGenEx :: [(NS.SocketOption, Int)] -> SocketType -> Int -> HostPreference -> IO Socket
bindPortGenEx :: [(SocketOption, Int)]
-> SocketType -> Int -> HostPreference -> IO Socket
bindPortGenEx sockOpts :: [(SocketOption, Int)]
sockOpts sockettype :: SocketType
sockettype p :: Int
p s :: HostPreference
s = do
let hints :: AddrInfo
hints = AddrInfo
NS.defaultHints
{ addrFlags :: [AddrInfoFlag]
NS.addrFlags = [AddrInfoFlag
NS.AI_PASSIVE]
, addrSocketType :: SocketType
NS.addrSocketType = SocketType
sockettype
}
host :: Maybe String
host =
case HostPreference
s of
Host s' :: String
s' -> String -> Maybe String
forall a. a -> Maybe a
Just String
s'
_ -> Maybe String
forall a. Maybe a
Nothing
port :: Maybe String
port = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> (Int -> String) -> Int -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> Maybe String) -> Int -> Maybe String
forall a b. (a -> b) -> a -> b
$ Int
p
[AddrInfo]
addrs <- Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
NS.getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
hints) Maybe String
host Maybe String
port
let addrs4 :: [AddrInfo]
addrs4 = (AddrInfo -> Bool) -> [AddrInfo] -> [AddrInfo]
forall a. (a -> Bool) -> [a] -> [a]
filter (\x :: AddrInfo
x -> AddrInfo -> Family
NS.addrFamily AddrInfo
x Family -> Family -> Bool
forall a. Eq a => a -> a -> Bool
/= Family
NS.AF_INET6) [AddrInfo]
addrs
addrs6 :: [AddrInfo]
addrs6 = (AddrInfo -> Bool) -> [AddrInfo] -> [AddrInfo]
forall a. (a -> Bool) -> [a] -> [a]
filter (\x :: AddrInfo
x -> AddrInfo -> Family
NS.addrFamily AddrInfo
x Family -> Family -> Bool
forall a. Eq a => a -> a -> Bool
== Family
NS.AF_INET6) [AddrInfo]
addrs
addrs' :: [AddrInfo]
addrs' =
case HostPreference
s of
HostIPv4 -> [AddrInfo]
addrs4 [AddrInfo] -> [AddrInfo] -> [AddrInfo]
forall a. [a] -> [a] -> [a]
++ [AddrInfo]
addrs6
HostIPv4Only -> [AddrInfo]
addrs4
HostIPv6 -> [AddrInfo]
addrs6 [AddrInfo] -> [AddrInfo] -> [AddrInfo]
forall a. [a] -> [a] -> [a]
++ [AddrInfo]
addrs4
HostIPv6Only -> [AddrInfo]
addrs6
_ -> [AddrInfo]
addrs
tryAddrs :: [AddrInfo] -> IO Socket
tryAddrs (addr1 :: AddrInfo
addr1:rest :: [AddrInfo]
rest@(_:_)) =
IO Socket -> (IOException -> IO Socket) -> IO Socket
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
E.catch
(AddrInfo -> IO Socket
theBody AddrInfo
addr1)
(\(IOException
_ :: IOException) -> [AddrInfo] -> IO Socket
tryAddrs [AddrInfo]
rest)
tryAddrs (addr1 :: AddrInfo
addr1:[]) = AddrInfo -> IO Socket
theBody AddrInfo
addr1
tryAddrs _ = String -> IO Socket
forall a. HasCallStack => String -> a
error "bindPort: addrs is empty"
theBody :: AddrInfo -> IO Socket
theBody addr :: AddrInfo
addr =
IO Socket
-> (Socket -> IO ()) -> (Socket -> IO Socket) -> IO Socket
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError
(Family -> SocketType -> ProtocolNumber -> IO Socket
NS.socket (AddrInfo -> Family
NS.addrFamily AddrInfo
addr) (AddrInfo -> SocketType
NS.addrSocketType AddrInfo
addr) (AddrInfo -> ProtocolNumber
NS.addrProtocol AddrInfo
addr))
Socket -> IO ()
NS.close
(\sock :: Socket
sock -> do
((SocketOption, Int) -> IO ()) -> [(SocketOption, Int)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(opt :: SocketOption
opt,v :: Int
v) -> Socket -> SocketOption -> Int -> IO ()
NS.setSocketOption Socket
sock SocketOption
opt Int
v) [(SocketOption, Int)]
sockOpts
Socket -> SockAddr -> IO ()
NS.bind Socket
sock (AddrInfo -> SockAddr
NS.addrAddress AddrInfo
addr)
Socket -> IO Socket
forall (m :: * -> *) a. Monad m => a -> m a
return Socket
sock
)
[AddrInfo] -> IO Socket
tryAddrs [AddrInfo]
addrs'
bindRandomPortGen :: SocketType -> HostPreference -> IO (Int, Socket)
bindRandomPortGen :: SocketType -> HostPreference -> IO (Int, Socket)
bindRandomPortGen sockettype :: SocketType
sockettype s :: HostPreference
s = do
Socket
socket <- SocketType -> Int -> HostPreference -> IO Socket
bindPortGen SocketType
sockettype 0 HostPreference
s
PortNumber
port <- Socket -> IO PortNumber
NS.socketPort Socket
socket
(Int, Socket) -> IO (Int, Socket)
forall (m :: * -> *) a. Monad m => a -> m a
return (PortNumber -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral PortNumber
port, Socket
socket)
unassignedPortsList :: [Int]
unassignedPortsList :: [Int]
unassignedPortsList = [[Int]] -> [Int]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [43124..44320]
, [28120..29166]
, [45967..46997]
, [28241..29117]
, [40001..40840]
, [29170..29998]
, [38866..39680]
, [43442..44122]
, [41122..41793]
, [35358..36000]
]
unassignedPorts :: UArray Int Int
unassignedPorts :: UArray Int Int
unassignedPorts = (Int, Int) -> [Int] -> UArray Int Int
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray (Int
unassignedPortsMin, Int
unassignedPortsMax) [Int]
unassignedPortsList
unassignedPortsMin, unassignedPortsMax :: Int
unassignedPortsMin :: Int
unassignedPortsMin = 0
unassignedPortsMax :: Int
unassignedPortsMax = [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
unassignedPortsList Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1
nextUnusedPort :: IORef Int
nextUnusedPort :: IORef Int
nextUnusedPort = IO (IORef Int) -> IORef Int
forall a. IO a -> a
unsafePerformIO
(IO (IORef Int) -> IORef Int) -> IO (IORef Int) -> IORef Int
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> IO Int
forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO (Int
unassignedPortsMin, Int
unassignedPortsMax) IO Int -> (Int -> IO (IORef Int)) -> IO (IORef Int)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef
{-# NOINLINE nextUnusedPort #-}
getUnassignedPort :: IO Int
getUnassignedPort :: IO Int
getUnassignedPort = do
Int
port <- IORef Int -> (Int -> (Int, Int)) -> IO Int
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef Int
nextUnusedPort Int -> (Int, Int)
go
Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$! Int
port
where
go :: Int -> (Int, Int)
go i :: Int
i
| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
unassignedPortsMax = (Int -> Int
forall a. Enum a => a -> a
succ Int
unassignedPortsMin, UArray Int Int
unassignedPorts UArray Int Int -> Int -> Int
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! Int
unassignedPortsMin)
| Bool
otherwise = (Int -> Int
forall a. Enum a => a -> a
succ Int
i, UArray Int Int
unassignedPorts UArray Int Int -> Int -> Int
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! Int
i)
getSocketUDP :: String -> Int -> IO (Socket, AddrInfo)
getSocketUDP :: String -> Int -> IO (Socket, AddrInfo)
getSocketUDP = SocketType -> String -> Int -> IO (Socket, AddrInfo)
getSocketGen SocketType
NS.Datagram
bindPortUDP :: Int -> HostPreference -> IO Socket
bindPortUDP :: Int -> HostPreference -> IO Socket
bindPortUDP = SocketType -> Int -> HostPreference -> IO Socket
bindPortGen SocketType
NS.Datagram
bindRandomPortUDP :: HostPreference -> IO (Int, Socket)
bindRandomPortUDP :: HostPreference -> IO (Int, Socket)
bindRandomPortUDP = SocketType -> HostPreference -> IO (Int, Socket)
bindRandomPortGen SocketType
NS.Datagram
{-# NOINLINE defaultReadBufferSize #-}
defaultReadBufferSize :: Int
defaultReadBufferSize :: Int
defaultReadBufferSize = IO Int -> Int
forall a. IO a -> a
unsafeDupablePerformIO (IO Int -> Int) -> IO Int -> Int
forall a b. (a -> b) -> a -> b
$
IO Socket -> (Socket -> IO ()) -> (Socket -> IO Int) -> IO Int
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (Family -> SocketType -> ProtocolNumber -> IO Socket
NS.socket Family
NS.AF_INET SocketType
NS.Stream 0) Socket -> IO ()
NS.close (\sock :: Socket
sock -> Socket -> SocketOption -> IO Int
NS.getSocketOption Socket
sock SocketOption
NS.RecvBuffer)
#if !WINDOWS
getSocketUnix :: FilePath -> IO Socket
getSocketUnix :: String -> IO Socket
getSocketUnix path :: String
path = do
Socket
sock <- Family -> SocketType -> ProtocolNumber -> IO Socket
NS.socket Family
NS.AF_UNIX SocketType
NS.Stream 0
Either SomeException ()
ee <- IO () -> IO (Either SomeException ())
forall a. IO a -> IO (Either SomeException a)
try' (IO () -> IO (Either SomeException ()))
-> IO () -> IO (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ Socket -> SockAddr -> IO ()
NS.connect Socket
sock (String -> SockAddr
NS.SockAddrUnix String
path)
case Either SomeException ()
ee of
Left e :: SomeException
e -> Socket -> IO ()
NS.close Socket
sock IO () -> IO Socket -> IO Socket
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SomeException -> IO Socket
forall e a. Exception e => e -> IO a
throwIO SomeException
e
Right () -> Socket -> IO Socket
forall (m :: * -> *) a. Monad m => a -> m a
return Socket
sock
where
try' :: IO a -> IO (Either SomeException a)
try' :: IO a -> IO (Either SomeException a)
try' = IO a -> IO (Either SomeException a)
forall e a. Exception e => IO a -> IO (Either e a)
try
bindPath :: FilePath -> IO Socket
bindPath :: String -> IO Socket
bindPath path :: String
path = do
Socket
sock <- IO Socket
-> (Socket -> IO ()) -> (Socket -> IO Socket) -> IO Socket
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError
(Family -> SocketType -> ProtocolNumber -> IO Socket
NS.socket Family
NS.AF_UNIX SocketType
NS.Stream 0)
Socket -> IO ()
NS.close
(\sock :: Socket
sock -> do
String -> IO ()
removeFileSafe String
path
Socket -> SockAddr -> IO ()
NS.bind Socket
sock (String -> SockAddr
NS.SockAddrUnix String
path)
Socket -> IO Socket
forall (m :: * -> *) a. Monad m => a -> m a
return Socket
sock)
Socket -> Int -> IO ()
NS.listen Socket
sock (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max 2048 Int
NS.maxListenQueue)
Socket -> IO Socket
forall (m :: * -> *) a. Monad m => a -> m a
return Socket
sock
removeFileSafe :: FilePath -> IO ()
removeFileSafe :: String -> IO ()
removeFileSafe path :: String
path =
String -> IO ()
removeFile String
path IO () -> (IOException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` IOException -> IO ()
handleExists
where
handleExists :: IOException -> IO ()
handleExists e :: IOException
e
| IOException -> Bool
isDoesNotExistError IOException
e = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = IOException -> IO ()
forall e a. Exception e => e -> IO a
throwIO IOException
e
serverSettingsUnix
:: FilePath
-> ServerSettingsUnix
serverSettingsUnix :: String -> ServerSettingsUnix
serverSettingsUnix path :: String
path = $WServerSettingsUnix :: String -> (Socket -> IO ()) -> Int -> ServerSettingsUnix
ServerSettingsUnix
{ serverPath :: String
serverPath = String
path
, serverAfterBindUnix :: Socket -> IO ()
serverAfterBindUnix = IO () -> Socket -> IO ()
forall a b. a -> b -> a
const (IO () -> Socket -> IO ()) -> IO () -> Socket -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
, serverReadBufferSizeUnix :: Int
serverReadBufferSizeUnix = Int
defaultReadBufferSize
}
clientSettingsUnix
:: FilePath
-> ClientSettingsUnix
clientSettingsUnix :: String -> ClientSettingsUnix
clientSettingsUnix path :: String
path = $WClientSettingsUnix :: String -> Int -> ClientSettingsUnix
ClientSettingsUnix
{ clientPath :: String
clientPath = String
path
, clientReadBufferSizeUnix :: Int
clientReadBufferSizeUnix = Int
defaultReadBufferSize
}
#endif
#if defined(__GLASGOW_HASKELL__) && WINDOWS
#define SOCKET_ACCEPT_RECV_WORKAROUND
#endif
safeRecv :: Socket -> Int -> IO ByteString
#ifndef SOCKET_ACCEPT_RECV_WORKAROUND
safeRecv :: Socket -> Int -> IO ByteString
safeRecv = Socket -> Int -> IO ByteString
recv
#else
safeRecv s buf = do
var <- newEmptyMVar
forkIO $ recv s buf `E.catch` (\(_::IOException) -> return S8.empty) >>= putMVar var
takeMVar var
#endif
serverSettingsUDP
:: Int
-> HostPreference
-> ServerSettings
serverSettingsUDP :: Int -> HostPreference -> ServerSettings
serverSettingsUDP = Int -> HostPreference -> ServerSettings
serverSettingsTCP
serverSettingsTCP
:: Int
-> HostPreference
-> ServerSettings
serverSettingsTCP :: Int -> HostPreference -> ServerSettings
serverSettingsTCP port :: Int
port host :: HostPreference
host = $WServerSettings :: Int
-> HostPreference
-> Maybe Socket
-> (Socket -> IO ())
-> Bool
-> Int
-> ServerSettings
ServerSettings
{ serverPort :: Int
serverPort = Int
port
, serverHost :: HostPreference
serverHost = HostPreference
host
, serverSocket :: Maybe Socket
serverSocket = Maybe Socket
forall a. Maybe a
Nothing
, serverAfterBind :: Socket -> IO ()
serverAfterBind = IO () -> Socket -> IO ()
forall a b. a -> b -> a
const (IO () -> Socket -> IO ()) -> IO () -> Socket -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
, serverNeedLocalAddr :: Bool
serverNeedLocalAddr = Bool
False
, serverReadBufferSize :: Int
serverReadBufferSize = Int
defaultReadBufferSize
}
serverSettingsTCPSocket :: Socket -> ServerSettings
serverSettingsTCPSocket :: Socket -> ServerSettings
serverSettingsTCPSocket lsocket :: Socket
lsocket = $WServerSettings :: Int
-> HostPreference
-> Maybe Socket
-> (Socket -> IO ())
-> Bool
-> Int
-> ServerSettings
ServerSettings
{ serverPort :: Int
serverPort = 0
, serverHost :: HostPreference
serverHost = HostPreference
HostAny
, serverSocket :: Maybe Socket
serverSocket = Socket -> Maybe Socket
forall a. a -> Maybe a
Just Socket
lsocket
, serverAfterBind :: Socket -> IO ()
serverAfterBind = IO () -> Socket -> IO ()
forall a b. a -> b -> a
const (IO () -> Socket -> IO ()) -> IO () -> Socket -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
, serverNeedLocalAddr :: Bool
serverNeedLocalAddr = Bool
False
, serverReadBufferSize :: Int
serverReadBufferSize = Int
defaultReadBufferSize
}
clientSettingsUDP
:: Int
-> ByteString
-> ClientSettings
clientSettingsUDP :: Int -> ByteString -> ClientSettings
clientSettingsUDP = Int -> ByteString -> ClientSettings
clientSettingsTCP
clientSettingsTCP
:: Int
-> ByteString
-> ClientSettings
clientSettingsTCP :: Int -> ByteString -> ClientSettings
clientSettingsTCP port :: Int
port host :: ByteString
host = $WClientSettings :: Int -> ByteString -> Family -> Int -> ClientSettings
ClientSettings
{ clientPort :: Int
clientPort = Int
port
, clientHost :: ByteString
clientHost = ByteString
host
, clientAddrFamily :: Family
clientAddrFamily = Family
NS.AF_UNSPEC
, clientReadBufferSize :: Int
clientReadBufferSize = Int
defaultReadBufferSize
}
getSocketFamilyTCP :: ByteString -> Int -> NS.Family -> IO (NS.Socket, NS.SockAddr)
getSocketFamilyTCP :: ByteString -> Int -> Family -> IO (Socket, SockAddr)
getSocketFamilyTCP host' :: ByteString
host' port' :: Int
port' addrFamily :: Family
addrFamily = do
[AddrInfo]
addrsInfo <- SocketType -> String -> Int -> Family -> IO [AddrInfo]
getPossibleAddrs SocketType
NS.Stream (ByteString -> String
S8.unpack ByteString
host') Int
port' Family
addrFamily
[AddrInfo] -> IO (Socket, SockAddr)
firstSuccess [AddrInfo]
addrsInfo
where
firstSuccess :: [AddrInfo] -> IO (Socket, SockAddr)
firstSuccess [ai :: AddrInfo
ai] = AddrInfo -> IO (Socket, SockAddr)
connect AddrInfo
ai
firstSuccess (ai :: AddrInfo
ai:ais :: [AddrInfo]
ais) = AddrInfo -> IO (Socket, SockAddr)
connect AddrInfo
ai IO (Socket, SockAddr)
-> (IOException -> IO (Socket, SockAddr)) -> IO (Socket, SockAddr)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \(IOException
_ :: IOException) -> [AddrInfo] -> IO (Socket, SockAddr)
firstSuccess [AddrInfo]
ais
firstSuccess _ = String -> IO (Socket, SockAddr)
forall a. HasCallStack => String -> a
error "getSocketFamilyTCP: can't happen"
createSocket :: AddrInfo -> IO Socket
createSocket addrInfo :: AddrInfo
addrInfo = do
Socket
sock <- Family -> SocketType -> ProtocolNumber -> IO Socket
NS.socket (AddrInfo -> Family
NS.addrFamily AddrInfo
addrInfo) (AddrInfo -> SocketType
NS.addrSocketType AddrInfo
addrInfo)
(AddrInfo -> ProtocolNumber
NS.addrProtocol AddrInfo
addrInfo)
Socket -> SocketOption -> Int -> IO ()
NS.setSocketOption Socket
sock SocketOption
NS.NoDelay 1
Socket -> IO Socket
forall (m :: * -> *) a. Monad m => a -> m a
return Socket
sock
connect :: AddrInfo -> IO (Socket, SockAddr)
connect addrInfo :: AddrInfo
addrInfo = IO Socket
-> (Socket -> IO ())
-> (Socket -> IO (Socket, SockAddr))
-> IO (Socket, SockAddr)
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracketOnError (AddrInfo -> IO Socket
createSocket AddrInfo
addrInfo) Socket -> IO ()
NS.close ((Socket -> IO (Socket, SockAddr)) -> IO (Socket, SockAddr))
-> (Socket -> IO (Socket, SockAddr)) -> IO (Socket, SockAddr)
forall a b. (a -> b) -> a -> b
$ \sock :: Socket
sock -> do
Socket -> SockAddr -> IO ()
NS.connect Socket
sock (AddrInfo -> SockAddr
NS.addrAddress AddrInfo
addrInfo)
(Socket, SockAddr) -> IO (Socket, SockAddr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Socket
sock, AddrInfo -> SockAddr
NS.addrAddress AddrInfo
addrInfo)
getSocketTCP :: ByteString -> Int -> IO (NS.Socket, NS.SockAddr)
getSocketTCP :: ByteString -> Int -> IO (Socket, SockAddr)
getSocketTCP host :: ByteString
host port :: Int
port = ByteString -> Int -> Family -> IO (Socket, SockAddr)
getSocketFamilyTCP ByteString
host Int
port Family
NS.AF_UNSPEC
bindPortTCP :: Int -> HostPreference -> IO Socket
bindPortTCP :: Int -> HostPreference -> IO Socket
bindPortTCP p :: Int
p s :: HostPreference
s = do
Socket
sock <- SocketType -> Int -> HostPreference -> IO Socket
bindPortGen SocketType
NS.Stream Int
p HostPreference
s
Socket -> Int -> IO ()
NS.listen Socket
sock (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max 2048 Int
NS.maxListenQueue)
Socket -> IO Socket
forall (m :: * -> *) a. Monad m => a -> m a
return Socket
sock
bindRandomPortTCP :: HostPreference -> IO (Int, Socket)
bindRandomPortTCP :: HostPreference -> IO (Int, Socket)
bindRandomPortTCP s :: HostPreference
s = do
(port :: Int
port, sock :: Socket
sock) <- SocketType -> HostPreference -> IO (Int, Socket)
bindRandomPortGen SocketType
NS.Stream HostPreference
s
Socket -> Int -> IO ()
NS.listen Socket
sock (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max 2048 Int
NS.maxListenQueue)
(Int, Socket) -> IO (Int, Socket)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
port, Socket
sock)
acceptSafe :: Socket -> IO (Socket, NS.SockAddr)
acceptSafe :: Socket -> IO (Socket, SockAddr)
acceptSafe socket :: Socket
socket =
#ifndef SOCKET_ACCEPT_RECV_WORKAROUND
IO (Socket, SockAddr)
loop
#else
do var <- newEmptyMVar
forkIO $ loop >>= putMVar var
takeMVar var
#endif
where
loop :: IO (Socket, SockAddr)
loop =
Socket -> IO (Socket, SockAddr)
NS.accept Socket
socket IO (Socket, SockAddr)
-> (IOException -> IO (Socket, SockAddr)) -> IO (Socket, SockAddr)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \e :: IOException
e ->
if IOErrorType -> Bool
isFullErrorType (IOException -> IOErrorType
ioeGetErrorType IOException
e)
then do
Int -> IO ()
threadDelay 1000000
IO (Socket, SockAddr)
loop
else IOException -> IO (Socket, SockAddr)
forall e a. Exception e => e -> IO a
E.throwIO IOException
e
message :: ByteString -> NS.SockAddr -> Message
message :: ByteString -> SockAddr -> Message
message = ByteString -> SockAddr -> Message
Message
class HasPort a where
portLens :: Functor f => (Int -> f Int) -> a -> f a
instance HasPort ServerSettings where
portLens :: (Int -> f Int) -> ServerSettings -> f ServerSettings
portLens f :: Int -> f Int
f ss :: ServerSettings
ss = (Int -> ServerSettings) -> f Int -> f ServerSettings
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\p :: Int
p -> ServerSettings
ss { serverPort :: Int
serverPort = Int
p }) (Int -> f Int
f (ServerSettings -> Int
serverPort ServerSettings
ss))
instance HasPort ClientSettings where
portLens :: (Int -> f Int) -> ClientSettings -> f ClientSettings
portLens f :: Int -> f Int
f ss :: ClientSettings
ss = (Int -> ClientSettings) -> f Int -> f ClientSettings
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\p :: Int
p -> ClientSettings
ss { clientPort :: Int
clientPort = Int
p }) (Int -> f Int
f (ClientSettings -> Int
clientPort ClientSettings
ss))
getPort :: HasPort a => a -> Int
getPort :: a -> Int
getPort = Constant Int a -> Int
forall a k (b :: k). Constant a b -> a
getConstant (Constant Int a -> Int) -> (a -> Constant Int a) -> a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Constant Int Int) -> a -> Constant Int a
forall a (f :: * -> *).
(HasPort a, Functor f) =>
(Int -> f Int) -> a -> f a
portLens Int -> Constant Int Int
forall k a (b :: k). a -> Constant a b
Constant
setPort :: HasPort a => Int -> a -> a
setPort :: Int -> a -> a
setPort p :: Int
p = Identity a -> a
forall a. Identity a -> a
runIdentity (Identity a -> a) -> (a -> Identity a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Identity Int) -> a -> Identity a
forall a (f :: * -> *).
(HasPort a, Functor f) =>
(Int -> f Int) -> a -> f a
portLens (Identity Int -> Int -> Identity Int
forall a b. a -> b -> a
const (Int -> Identity Int
forall a. a -> Identity a
Identity Int
p))
setHost :: ByteString -> ClientSettings -> ClientSettings
setHost :: ByteString -> ClientSettings -> ClientSettings
setHost hp :: ByteString
hp ss :: ClientSettings
ss = ClientSettings
ss { clientHost :: ByteString
clientHost = ByteString
hp }
getHost :: ClientSettings -> ByteString
getHost :: ClientSettings -> ByteString
getHost = ClientSettings -> ByteString
clientHost
setAddrFamily :: NS.Family -> ClientSettings -> ClientSettings
setAddrFamily :: Family -> ClientSettings -> ClientSettings
setAddrFamily af :: Family
af cs :: ClientSettings
cs = ClientSettings
cs { clientAddrFamily :: Family
clientAddrFamily = Family
af }
getAddrFamily :: ClientSettings -> NS.Family
getAddrFamily :: ClientSettings -> Family
getAddrFamily = ClientSettings -> Family
clientAddrFamily
#if !WINDOWS
class HasPath a where
pathLens :: Functor f => (FilePath -> f FilePath) -> a -> f a
instance HasPath ServerSettingsUnix where
pathLens :: (String -> f String) -> ServerSettingsUnix -> f ServerSettingsUnix
pathLens f :: String -> f String
f ss :: ServerSettingsUnix
ss = (String -> ServerSettingsUnix) -> f String -> f ServerSettingsUnix
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\p :: String
p -> ServerSettingsUnix
ss { serverPath :: String
serverPath = String
p }) (String -> f String
f (ServerSettingsUnix -> String
serverPath ServerSettingsUnix
ss))
instance HasPath ClientSettingsUnix where
pathLens :: (String -> f String) -> ClientSettingsUnix -> f ClientSettingsUnix
pathLens f :: String -> f String
f ss :: ClientSettingsUnix
ss = (String -> ClientSettingsUnix) -> f String -> f ClientSettingsUnix
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\p :: String
p -> ClientSettingsUnix
ss { clientPath :: String
clientPath = String
p }) (String -> f String
f (ClientSettingsUnix -> String
clientPath ClientSettingsUnix
ss))
getPath :: HasPath a => a -> FilePath
getPath :: a -> String
getPath = Constant String a -> String
forall a k (b :: k). Constant a b -> a
getConstant (Constant String a -> String)
-> (a -> Constant String a) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Constant String String) -> a -> Constant String a
forall a (f :: * -> *).
(HasPath a, Functor f) =>
(String -> f String) -> a -> f a
pathLens String -> Constant String String
forall k a (b :: k). a -> Constant a b
Constant
setPath :: HasPath a => FilePath -> a -> a
setPath :: String -> a -> a
setPath p :: String
p = Identity a -> a
forall a. Identity a -> a
runIdentity (Identity a -> a) -> (a -> Identity a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Identity String) -> a -> Identity a
forall a (f :: * -> *).
(HasPath a, Functor f) =>
(String -> f String) -> a -> f a
pathLens (Identity String -> String -> Identity String
forall a b. a -> b -> a
const (String -> Identity String
forall a. a -> Identity a
Identity String
p))
#endif
setNeedLocalAddr :: Bool -> ServerSettings -> ServerSettings
setNeedLocalAddr :: Bool -> ServerSettings -> ServerSettings
setNeedLocalAddr x :: Bool
x y :: ServerSettings
y = ServerSettings
y { serverNeedLocalAddr :: Bool
serverNeedLocalAddr = Bool
x }
getNeedLocalAddr :: ServerSettings -> Bool
getNeedLocalAddr :: ServerSettings -> Bool
getNeedLocalAddr = ServerSettings -> Bool
serverNeedLocalAddr
class HasAfterBind a where
afterBindLens :: Functor f => ((Socket -> IO ()) -> f (Socket -> IO ())) -> a -> f a
instance HasAfterBind ServerSettings where
afterBindLens :: ((Socket -> IO ()) -> f (Socket -> IO ()))
-> ServerSettings -> f ServerSettings
afterBindLens f :: (Socket -> IO ()) -> f (Socket -> IO ())
f ss :: ServerSettings
ss = ((Socket -> IO ()) -> ServerSettings)
-> f (Socket -> IO ()) -> f ServerSettings
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\p :: Socket -> IO ()
p -> ServerSettings
ss { serverAfterBind :: Socket -> IO ()
serverAfterBind = Socket -> IO ()
p }) ((Socket -> IO ()) -> f (Socket -> IO ())
f (ServerSettings -> Socket -> IO ()
serverAfterBind ServerSettings
ss))
#if !WINDOWS
instance HasAfterBind ServerSettingsUnix where
afterBindLens :: ((Socket -> IO ()) -> f (Socket -> IO ()))
-> ServerSettingsUnix -> f ServerSettingsUnix
afterBindLens f :: (Socket -> IO ()) -> f (Socket -> IO ())
f ss :: ServerSettingsUnix
ss = ((Socket -> IO ()) -> ServerSettingsUnix)
-> f (Socket -> IO ()) -> f ServerSettingsUnix
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\p :: Socket -> IO ()
p -> ServerSettingsUnix
ss { serverAfterBindUnix :: Socket -> IO ()
serverAfterBindUnix = Socket -> IO ()
p }) ((Socket -> IO ()) -> f (Socket -> IO ())
f (ServerSettingsUnix -> Socket -> IO ()
serverAfterBindUnix ServerSettingsUnix
ss))
#endif
getAfterBind :: HasAfterBind a => a -> (Socket -> IO ())
getAfterBind :: a -> Socket -> IO ()
getAfterBind = Constant (Socket -> IO ()) a -> Socket -> IO ()
forall a k (b :: k). Constant a b -> a
getConstant (Constant (Socket -> IO ()) a -> Socket -> IO ())
-> (a -> Constant (Socket -> IO ()) a) -> a -> Socket -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Socket -> IO ()) -> Constant (Socket -> IO ()) (Socket -> IO ()))
-> a -> Constant (Socket -> IO ()) a
forall a (f :: * -> *).
(HasAfterBind a, Functor f) =>
((Socket -> IO ()) -> f (Socket -> IO ())) -> a -> f a
afterBindLens (Socket -> IO ()) -> Constant (Socket -> IO ()) (Socket -> IO ())
forall k a (b :: k). a -> Constant a b
Constant
setAfterBind :: HasAfterBind a => (Socket -> IO ()) -> a -> a
setAfterBind :: (Socket -> IO ()) -> a -> a
setAfterBind p :: Socket -> IO ()
p = Identity a -> a
forall a. Identity a -> a
runIdentity (Identity a -> a) -> (a -> Identity a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Socket -> IO ()) -> Identity (Socket -> IO ()))
-> a -> Identity a
forall a (f :: * -> *).
(HasAfterBind a, Functor f) =>
((Socket -> IO ()) -> f (Socket -> IO ())) -> a -> f a
afterBindLens (Identity (Socket -> IO ())
-> (Socket -> IO ()) -> Identity (Socket -> IO ())
forall a b. a -> b -> a
const ((Socket -> IO ()) -> Identity (Socket -> IO ())
forall a. a -> Identity a
Identity Socket -> IO ()
p))
class HasReadBufferSize a where
readBufferSizeLens :: Functor f => (Int -> f Int) -> a -> f a
instance HasReadBufferSize ServerSettings where
readBufferSizeLens :: (Int -> f Int) -> ServerSettings -> f ServerSettings
readBufferSizeLens f :: Int -> f Int
f ss :: ServerSettings
ss = (Int -> ServerSettings) -> f Int -> f ServerSettings
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\p :: Int
p -> ServerSettings
ss { serverReadBufferSize :: Int
serverReadBufferSize = Int
p }) (Int -> f Int
f (ServerSettings -> Int
serverReadBufferSize ServerSettings
ss))
instance HasReadBufferSize ClientSettings where
readBufferSizeLens :: (Int -> f Int) -> ClientSettings -> f ClientSettings
readBufferSizeLens f :: Int -> f Int
f cs :: ClientSettings
cs = (Int -> ClientSettings) -> f Int -> f ClientSettings
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\p :: Int
p -> ClientSettings
cs { clientReadBufferSize :: Int
clientReadBufferSize = Int
p }) (Int -> f Int
f (ClientSettings -> Int
clientReadBufferSize ClientSettings
cs))
#if !WINDOWS
instance HasReadBufferSize ServerSettingsUnix where
readBufferSizeLens :: (Int -> f Int) -> ServerSettingsUnix -> f ServerSettingsUnix
readBufferSizeLens f :: Int -> f Int
f ss :: ServerSettingsUnix
ss = (Int -> ServerSettingsUnix) -> f Int -> f ServerSettingsUnix
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\p :: Int
p -> ServerSettingsUnix
ss { serverReadBufferSizeUnix :: Int
serverReadBufferSizeUnix = Int
p }) (Int -> f Int
f (ServerSettingsUnix -> Int
serverReadBufferSizeUnix ServerSettingsUnix
ss))
instance HasReadBufferSize ClientSettingsUnix where
readBufferSizeLens :: (Int -> f Int) -> ClientSettingsUnix -> f ClientSettingsUnix
readBufferSizeLens f :: Int -> f Int
f ss :: ClientSettingsUnix
ss = (Int -> ClientSettingsUnix) -> f Int -> f ClientSettingsUnix
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\p :: Int
p -> ClientSettingsUnix
ss { clientReadBufferSizeUnix :: Int
clientReadBufferSizeUnix = Int
p }) (Int -> f Int
f (ClientSettingsUnix -> Int
clientReadBufferSizeUnix ClientSettingsUnix
ss))
#endif
getReadBufferSize :: HasReadBufferSize a => a -> Int
getReadBufferSize :: a -> Int
getReadBufferSize = Constant Int a -> Int
forall a k (b :: k). Constant a b -> a
getConstant (Constant Int a -> Int) -> (a -> Constant Int a) -> a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Constant Int Int) -> a -> Constant Int a
forall a (f :: * -> *).
(HasReadBufferSize a, Functor f) =>
(Int -> f Int) -> a -> f a
readBufferSizeLens Int -> Constant Int Int
forall k a (b :: k). a -> Constant a b
Constant
setReadBufferSize :: HasReadBufferSize a => Int -> a -> a
setReadBufferSize :: Int -> a -> a
setReadBufferSize p :: Int
p = Identity a -> a
forall a. Identity a -> a
runIdentity (Identity a -> a) -> (a -> Identity a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Identity Int) -> a -> Identity a
forall a (f :: * -> *).
(HasReadBufferSize a, Functor f) =>
(Int -> f Int) -> a -> f a
readBufferSizeLens (Identity Int -> Int -> Identity Int
forall a b. a -> b -> a
const (Int -> Identity Int
forall a. a -> Identity a
Identity Int
p))
type ConnectionHandle = Socket -> NS.SockAddr -> Maybe NS.SockAddr -> IO ()
runTCPServerWithHandle :: ServerSettings -> ConnectionHandle -> IO a
runTCPServerWithHandle :: ServerSettings -> ConnectionHandle -> IO a
runTCPServerWithHandle (ServerSettings port :: Int
port host :: HostPreference
host msocket :: Maybe Socket
msocket afterBind :: Socket -> IO ()
afterBind needLocalAddr :: Bool
needLocalAddr _) handle :: ConnectionHandle
handle =
case Maybe Socket
msocket of
Nothing -> IO Socket -> (Socket -> IO ()) -> (Socket -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracket (Int -> HostPreference -> IO Socket
bindPortTCP Int
port HostPreference
host) Socket -> IO ()
NS.close Socket -> IO a
forall b. Socket -> IO b
inner
Just lsocket :: Socket
lsocket -> Socket -> IO a
forall b. Socket -> IO b
inner Socket
lsocket
where
inner :: Socket -> IO b
inner lsocket :: Socket
lsocket = Socket -> IO ()
afterBind Socket
lsocket IO () -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO () -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (Socket -> IO ()
serve Socket
lsocket)
serve :: Socket -> IO ()
serve lsocket :: Socket
lsocket = IO (Socket, SockAddr)
-> ((Socket, SockAddr) -> IO ())
-> ((Socket, SockAddr) -> IO ())
-> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracketOnError
(Socket -> IO (Socket, SockAddr)
acceptSafe Socket
lsocket)
(\(socket :: Socket
socket, _) -> Socket -> IO ()
NS.close Socket
socket)
(((Socket, SockAddr) -> IO ()) -> IO ())
-> ((Socket, SockAddr) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(socket :: Socket
socket, addr :: SockAddr
addr) -> do
Maybe SockAddr
mlocal <- if Bool
needLocalAddr
then (SockAddr -> Maybe SockAddr) -> IO SockAddr -> IO (Maybe SockAddr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SockAddr -> Maybe SockAddr
forall a. a -> Maybe a
Just (IO SockAddr -> IO (Maybe SockAddr))
-> IO SockAddr -> IO (Maybe SockAddr)
forall a b. (a -> b) -> a -> b
$ Socket -> IO SockAddr
NS.getSocketName Socket
socket
else Maybe SockAddr -> IO (Maybe SockAddr)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SockAddr
forall a. Maybe a
Nothing
ThreadId
_ <- ((forall a. IO a -> IO a) -> IO ThreadId) -> IO ThreadId
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
E.mask (((forall a. IO a -> IO a) -> IO ThreadId) -> IO ThreadId)
-> ((forall a. IO a -> IO a) -> IO ThreadId) -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ \restore :: forall a. IO a -> IO a
restore -> IO () -> IO ThreadId
forkIO
(IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall a. IO a -> IO a
restore (ConnectionHandle
handle Socket
socket SockAddr
addr Maybe SockAddr
mlocal)
IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`E.finally` Socket -> IO ()
NS.close Socket
socket
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
runTCPServer :: ServerSettings -> (AppData -> IO ()) -> IO a
runTCPServer :: ServerSettings -> (AppData -> IO ()) -> IO a
runTCPServer settings :: ServerSettings
settings app :: AppData -> IO ()
app = ServerSettings -> ConnectionHandle -> IO a
forall a. ServerSettings -> ConnectionHandle -> IO a
runTCPServerWithHandle ServerSettings
settings ConnectionHandle
app'
where app' :: ConnectionHandle
app' socket :: Socket
socket addr :: SockAddr
addr mlocal :: Maybe SockAddr
mlocal =
let ad :: AppData
ad = $WAppData :: IO ByteString
-> (ByteString -> IO ())
-> SockAddr
-> Maybe SockAddr
-> IO ()
-> Maybe Socket
-> AppData
AppData
{ appRead' :: IO ByteString
appRead' = Socket -> Int -> IO ByteString
safeRecv Socket
socket (Int -> IO ByteString) -> Int -> IO ByteString
forall a b. (a -> b) -> a -> b
$ ServerSettings -> Int
forall a. HasReadBufferSize a => a -> Int
getReadBufferSize ServerSettings
settings
, appWrite' :: ByteString -> IO ()
appWrite' = Socket -> ByteString -> IO ()
sendAll Socket
socket
, appSockAddr' :: SockAddr
appSockAddr' = SockAddr
addr
, appLocalAddr' :: Maybe SockAddr
appLocalAddr' = Maybe SockAddr
mlocal
, appCloseConnection' :: IO ()
appCloseConnection' = Socket -> IO ()
NS.close Socket
socket
, appRawSocket' :: Maybe Socket
appRawSocket' = Socket -> Maybe Socket
forall a. a -> Maybe a
Just Socket
socket
}
in
AppData -> IO ()
app AppData
ad
runTCPClient :: ClientSettings -> (AppData -> IO a) -> IO a
runTCPClient :: ClientSettings -> (AppData -> IO a) -> IO a
runTCPClient (ClientSettings port :: Int
port host :: ByteString
host addrFamily :: Family
addrFamily readBufferSize :: Int
readBufferSize) app :: AppData -> IO a
app = IO (Socket, SockAddr)
-> ((Socket, SockAddr) -> IO ())
-> ((Socket, SockAddr) -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracket
(ByteString -> Int -> Family -> IO (Socket, SockAddr)
getSocketFamilyTCP ByteString
host Int
port Family
addrFamily)
(Socket -> IO ()
NS.close (Socket -> IO ())
-> ((Socket, SockAddr) -> Socket) -> (Socket, SockAddr) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Socket, SockAddr) -> Socket
forall a b. (a, b) -> a
fst)
(\(s :: Socket
s, address :: SockAddr
address) -> AppData -> IO a
app $WAppData :: IO ByteString
-> (ByteString -> IO ())
-> SockAddr
-> Maybe SockAddr
-> IO ()
-> Maybe Socket
-> AppData
AppData
{ appRead' :: IO ByteString
appRead' = Socket -> Int -> IO ByteString
safeRecv Socket
s Int
readBufferSize
, appWrite' :: ByteString -> IO ()
appWrite' = Socket -> ByteString -> IO ()
sendAll Socket
s
, appSockAddr' :: SockAddr
appSockAddr' = SockAddr
address
, appLocalAddr' :: Maybe SockAddr
appLocalAddr' = Maybe SockAddr
forall a. Maybe a
Nothing
, appCloseConnection' :: IO ()
appCloseConnection' = Socket -> IO ()
NS.close Socket
s
, appRawSocket' :: Maybe Socket
appRawSocket' = Socket -> Maybe Socket
forall a. a -> Maybe a
Just Socket
s
})
appLocalAddr :: AppData -> Maybe NS.SockAddr
appLocalAddr :: AppData -> Maybe SockAddr
appLocalAddr = AppData -> Maybe SockAddr
appLocalAddr'
appSockAddr :: AppData -> NS.SockAddr
appSockAddr :: AppData -> SockAddr
appSockAddr = AppData -> SockAddr
appSockAddr'
appCloseConnection :: AppData -> IO ()
appCloseConnection :: AppData -> IO ()
appCloseConnection = AppData -> IO ()
appCloseConnection'
appRawSocket :: AppData -> Maybe NS.Socket
appRawSocket :: AppData -> Maybe Socket
appRawSocket = AppData -> Maybe Socket
appRawSocket'
class HasReadWrite a where
readLens :: Functor f => (IO ByteString -> f (IO ByteString)) -> a -> f a
writeLens :: Functor f => ((ByteString -> IO ()) -> f (ByteString -> IO ())) -> a -> f a
instance HasReadWrite AppData where
readLens :: (IO ByteString -> f (IO ByteString)) -> AppData -> f AppData
readLens f :: IO ByteString -> f (IO ByteString)
f a :: AppData
a = (IO ByteString -> AppData) -> f (IO ByteString) -> f AppData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\x :: IO ByteString
x -> AppData
a { appRead' :: IO ByteString
appRead' = IO ByteString
x }) (IO ByteString -> f (IO ByteString)
f (AppData -> IO ByteString
appRead' AppData
a))
writeLens :: ((ByteString -> IO ()) -> f (ByteString -> IO ()))
-> AppData -> f AppData
writeLens f :: (ByteString -> IO ()) -> f (ByteString -> IO ())
f a :: AppData
a = ((ByteString -> IO ()) -> AppData)
-> f (ByteString -> IO ()) -> f AppData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\x :: ByteString -> IO ()
x -> AppData
a { appWrite' :: ByteString -> IO ()
appWrite' = ByteString -> IO ()
x }) ((ByteString -> IO ()) -> f (ByteString -> IO ())
f (AppData -> ByteString -> IO ()
appWrite' AppData
a))
#if !WINDOWS
instance HasReadWrite AppDataUnix where
readLens :: (IO ByteString -> f (IO ByteString))
-> AppDataUnix -> f AppDataUnix
readLens f :: IO ByteString -> f (IO ByteString)
f a :: AppDataUnix
a = (IO ByteString -> AppDataUnix)
-> f (IO ByteString) -> f AppDataUnix
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\x :: IO ByteString
x -> AppDataUnix
a { appReadUnix :: IO ByteString
appReadUnix = IO ByteString
x }) (IO ByteString -> f (IO ByteString)
f (AppDataUnix -> IO ByteString
appReadUnix AppDataUnix
a))
writeLens :: ((ByteString -> IO ()) -> f (ByteString -> IO ()))
-> AppDataUnix -> f AppDataUnix
writeLens f :: (ByteString -> IO ()) -> f (ByteString -> IO ())
f a :: AppDataUnix
a = ((ByteString -> IO ()) -> AppDataUnix)
-> f (ByteString -> IO ()) -> f AppDataUnix
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\x :: ByteString -> IO ()
x -> AppDataUnix
a { appWriteUnix :: ByteString -> IO ()
appWriteUnix = ByteString -> IO ()
x }) ((ByteString -> IO ()) -> f (ByteString -> IO ())
f (AppDataUnix -> ByteString -> IO ()
appWriteUnix AppDataUnix
a))
#endif
appRead :: HasReadWrite a => a -> IO ByteString
appRead :: a -> IO ByteString
appRead = Constant (IO ByteString) a -> IO ByteString
forall a k (b :: k). Constant a b -> a
getConstant (Constant (IO ByteString) a -> IO ByteString)
-> (a -> Constant (IO ByteString) a) -> a -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IO ByteString -> Constant (IO ByteString) (IO ByteString))
-> a -> Constant (IO ByteString) a
forall a (f :: * -> *).
(HasReadWrite a, Functor f) =>
(IO ByteString -> f (IO ByteString)) -> a -> f a
readLens IO ByteString -> Constant (IO ByteString) (IO ByteString)
forall k a (b :: k). a -> Constant a b
Constant
appWrite :: HasReadWrite a => a -> ByteString -> IO ()
appWrite :: a -> ByteString -> IO ()
appWrite = Constant (ByteString -> IO ()) a -> ByteString -> IO ()
forall a k (b :: k). Constant a b -> a
getConstant (Constant (ByteString -> IO ()) a -> ByteString -> IO ())
-> (a -> Constant (ByteString -> IO ()) a)
-> a
-> ByteString
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ByteString -> IO ())
-> Constant (ByteString -> IO ()) (ByteString -> IO ()))
-> a -> Constant (ByteString -> IO ()) a
forall a (f :: * -> *).
(HasReadWrite a, Functor f) =>
((ByteString -> IO ()) -> f (ByteString -> IO ())) -> a -> f a
writeLens (ByteString -> IO ())
-> Constant (ByteString -> IO ()) (ByteString -> IO ())
forall k a (b :: k). a -> Constant a b
Constant
#if !WINDOWS
runUnixServer :: ServerSettingsUnix -> (AppDataUnix -> IO ()) -> IO a
runUnixServer :: ServerSettingsUnix -> (AppDataUnix -> IO ()) -> IO a
runUnixServer (ServerSettingsUnix path :: String
path afterBind :: Socket -> IO ()
afterBind readBufferSize :: Int
readBufferSize) app :: AppDataUnix -> IO ()
app = IO Socket -> (Socket -> IO ()) -> (Socket -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracket
(String -> IO Socket
bindPath String
path)
Socket -> IO ()
NS.close
(\socket :: Socket
socket -> do
Socket -> IO ()
afterBind Socket
socket
IO () -> IO a
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO a) -> IO () -> IO a
forall a b. (a -> b) -> a -> b
$ Socket -> IO ()
serve Socket
socket)
where
serve :: Socket -> IO ()
serve lsocket :: Socket
lsocket = IO (Socket, SockAddr)
-> ((Socket, SockAddr) -> IO ())
-> ((Socket, SockAddr) -> IO ())
-> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracketOnError
(Socket -> IO (Socket, SockAddr)
acceptSafe Socket
lsocket)
(\(socket :: Socket
socket, _) -> Socket -> IO ()
NS.close Socket
socket)
(((Socket, SockAddr) -> IO ()) -> IO ())
-> ((Socket, SockAddr) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(socket :: Socket
socket, _) -> do
let ad :: AppDataUnix
ad = $WAppDataUnix :: IO ByteString -> (ByteString -> IO ()) -> AppDataUnix
AppDataUnix
{ appReadUnix :: IO ByteString
appReadUnix = Socket -> Int -> IO ByteString
safeRecv Socket
socket Int
readBufferSize
, appWriteUnix :: ByteString -> IO ()
appWriteUnix = Socket -> ByteString -> IO ()
sendAll Socket
socket
}
ThreadId
_ <- ((forall a. IO a -> IO a) -> IO ThreadId) -> IO ThreadId
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
E.mask (((forall a. IO a -> IO a) -> IO ThreadId) -> IO ThreadId)
-> ((forall a. IO a -> IO a) -> IO ThreadId) -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ \restore :: forall a. IO a -> IO a
restore -> IO () -> IO ThreadId
forkIO
(IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall a. IO a -> IO a
restore (AppDataUnix -> IO ()
app AppDataUnix
ad)
IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`E.finally` Socket -> IO ()
NS.close Socket
socket
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
runUnixClient :: ClientSettingsUnix -> (AppDataUnix -> IO a) -> IO a
runUnixClient :: ClientSettingsUnix -> (AppDataUnix -> IO a) -> IO a
runUnixClient (ClientSettingsUnix path :: String
path readBufferSize :: Int
readBufferSize) app :: AppDataUnix -> IO a
app = IO Socket -> (Socket -> IO ()) -> (Socket -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracket
(String -> IO Socket
getSocketUnix String
path)
Socket -> IO ()
NS.close
(\sock :: Socket
sock -> AppDataUnix -> IO a
app $WAppDataUnix :: IO ByteString -> (ByteString -> IO ()) -> AppDataUnix
AppDataUnix
{ appReadUnix :: IO ByteString
appReadUnix = Socket -> Int -> IO ByteString
safeRecv Socket
sock Int
readBufferSize
, appWriteUnix :: ByteString -> IO ()
appWriteUnix = Socket -> ByteString -> IO ()
sendAll Socket
sock
})
#endif