module Data.Conduit.Network
(
sourceSocket
, sinkSocket
, Application
, ServerSettings (..)
, runTCPServer
, ClientSettings (..)
, runTCPClient
, bindPort
, getSocket
) where
import Data.Conduit
import qualified Network.Socket as NS
import Network.Socket (Socket)
import Network.Socket.ByteString (sendAll, recv)
import Data.ByteString (ByteString)
import qualified Data.ByteString as S
import Control.Monad.IO.Class (liftIO)
import Control.Exception (bracketOnError, IOException, bracket, throwIO, SomeException, try)
import Control.Monad (forever)
import Control.Monad.Trans.Resource (register)
import Control.Concurrent (forkIO)
sourceSocket :: ResourceIO m => Socket -> Source m ByteString
sourceSocket socket =
src
where
src = Source pull close
pull = do
bs <- liftIO (recv socket 4096)
return $ if S.null bs then Closed else Open src bs
close = return ()
sinkSocket :: ResourceIO m => Socket -> Sink ByteString m ()
sinkSocket socket =
SinkData push close
where
push bs = do
liftIO (sendAll socket bs)
return (Processing push close)
close = return ()
type Application = Source IO ByteString
-> Sink ByteString IO ()
-> ResourceT IO ()
data ServerSettings = ServerSettings
{ serverPort :: Int
, serverHost :: Maybe String
}
runTCPServer :: ServerSettings -> Application -> IO ()
runTCPServer (ServerSettings port host) app = bracket
(bindPort host port)
NS.sClose
(forever . serve)
where
serve lsocket = do
(socket, _addr) <- NS.accept lsocket
forkIO $ runResourceT $ do
_ <- register $ NS.sClose socket
app (sourceSocket socket) (sinkSocket socket)
data ClientSettings = ClientSettings
{ clientPort :: Int
, clientHost :: String
}
runTCPClient :: ClientSettings -> Application -> IO ()
runTCPClient (ClientSettings port host) app = bracket
(getSocket host port)
NS.sClose
(\s -> runResourceT $ app (sourceSocket s) (sinkSocket s))
getSocket :: String -> Int -> IO NS.Socket
getSocket host' port' = do
let hints = NS.defaultHints {
NS.addrFlags = [NS.AI_ADDRCONFIG]
, NS.addrSocketType = NS.Stream
}
(addr:_) <- NS.getAddrInfo (Just hints) (Just host') (Just $ show port')
sock <- NS.socket (NS.addrFamily addr) (NS.addrSocketType addr)
(NS.addrProtocol addr)
ee <- try' $ NS.connect sock (NS.addrAddress addr)
case ee of
Left e -> NS.sClose sock >> throwIO e
Right () -> return sock
where
try' :: IO a -> IO (Either SomeException a)
try' = try
bindPort :: Maybe String -> Int -> IO Socket
bindPort host p = do
let hints = NS.defaultHints
{ NS.addrFlags =
[ NS.AI_PASSIVE
, NS.AI_NUMERICSERV
, NS.AI_NUMERICHOST
]
, NS.addrSocketType = NS.Stream
}
port = Just . show $ p
addrs <- NS.getAddrInfo (Just hints) host port
let
tryAddrs (addr1:rest@(_:_)) =
catch
(theBody addr1)
(\(_ :: IOException) -> tryAddrs rest)
tryAddrs (addr1:[]) = theBody addr1
tryAddrs _ = error "bindPort: addrs is empty"
theBody addr =
bracketOnError
(NS.socket
(NS.addrFamily addr)
(NS.addrSocketType addr)
(NS.addrProtocol addr))
NS.sClose
(\sock -> do
NS.setSocketOption sock NS.ReuseAddr 1
NS.bindSocket sock (NS.addrAddress addr)
NS.listen sock NS.maxListenQueue
return sock
)
tryAddrs addrs