module Control.Pipe.Network (
Application,
socketReader,
socketWriter,
ServerSettings(..),
runTCPServer,
ClientSettings(..),
runTCPClient,
) where
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 B
import Control.Concurrent (forkIO)
import qualified Control.Exception as E
import Control.Monad (forever, unless)
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Pipe
socketReader :: MonadIO m => Socket -> Pipe () ByteString m ()
socketReader socket = go
where
go = do
bs <- lift . liftIO $ recv socket 4096
unless (B.null bs) $
yield bs >> go
socketWriter :: MonadIO m => Socket -> Pipe ByteString Void m r
socketWriter socket = forever $ await >>= lift . liftIO . sendAll socket
type Application m r = Pipe () ByteString m ()
-> Pipe ByteString Void m ()
-> IO r
data ServerSettings = ServerSettings
{ serverPort :: Int
, serverHost :: Maybe String
}
runTCPServer :: MonadIO m => ServerSettings -> Application m r -> IO r
runTCPServer (ServerSettings port host) app = E.bracket
(bindPort host port)
NS.sClose
(forever . serve)
where
serve lsocket = do
(socket, _addr) <- NS.accept lsocket
forkIO $ do
E.finally
(app (socketReader socket) (socketWriter socket))
(NS.sClose socket)
return ()
data ClientSettings = ClientSettings
{ clientPort :: Int
, clientHost :: String
}
runTCPClient :: MonadIO m => ClientSettings -> Application m r -> IO r
runTCPClient (ClientSettings port host) app = E.bracket
(getSocket host port)
NS.sClose
(\s -> app (socketReader s) (socketWriter 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')
E.bracketOnError
(NS.socket (NS.addrFamily addr)
(NS.addrSocketType addr)
(NS.addrProtocol addr))
NS.sClose
(\sock -> NS.connect sock (NS.addrAddress addr) >> return sock)
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@(_:_)) = E.catch
(theBody addr1)
(\(_ :: E.IOException) -> tryAddrs rest)
tryAddrs (addr1:[]) = theBody addr1
tryAddrs _ = error "bindPort: addrs is empty"
theBody addr =
E.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