module Network.Server
( ipAddress
, Server (..)
, serveNoBlock
, serve
, multiServeNoBlock
, ServerRoutine
, multiServe)
where
import Network
import Network.Socket hiding (accept)
import System.IO
import Control.Concurrent
import Control.Exception hiding (catch)
import Data.Word
ipAddress :: (Word8, Word8, Word8, Word8) -> HostAddress
ipAddress (a, b, c, d) = fromIntegral a + 0x100 * fromIntegral b + 0x10000 * fromIntegral c + 0x1000000 * fromIntegral d
type ServerRoutine = (Handle, HostName, PortNumber) -> IO ()
serverSocket :: Server -> IO Socket
serverSocket (Server (SockAddrInet _ _) t _) = socket AF_INET t defaultProtocol
serverSocket (Server (SockAddrInet6 _ _ _ _) t _) = socket AF_INET6 t defaultProtocol
serverSocket (Server (SockAddrUnix _) t _) = socket AF_UNIX t defaultProtocol
data Server = Server {
serverAddr :: SockAddr,
serverTyp :: SocketType,
serverRoutine :: ServerRoutine}
serveNoBlock :: Server -> IO (ThreadId, MVar ())
serveNoBlock server = do
sock <- serverSocket server
setSocketOption sock ReuseAddr 1
bindSocket sock (serverAddr server)
listen sock maxListenQueue
mvar <- newEmptyMVar
threadId <- forkIO (acceptance sock (serverRoutine server) `finally` putMVar mvar ())
return (threadId, mvar)
serve :: Server -> IO ()
serve server = do
(_, mvar) <- serveNoBlock server
readMVar mvar
multiServeNoBlock :: [Server] -> IO [(ThreadId, MVar ())]
multiServeNoBlock l = mapM serveNoBlock l
multiServe :: [Server] -> IO ()
multiServe l = multiServeNoBlock l >>= mapM_ (\r -> takeMVar (snd r))
acceptance :: Socket -> ServerRoutine -> IO ()
acceptance sock action = catch (do
dta <- accept sock
forkIO (action dta) >> return ()) print >>
acceptance sock action