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


-- |make an IP Address: (127,0,0,1) is the localhost
ipAddress :: (Word8, Word8, Word8, Word8) -> HostAddress
ipAddress (a, b, c, d) = fromIntegral a + 0x100 * fromIntegral b + 0x10000 * fromIntegral c + 0x1000000 * fromIntegral d

-- |the functionality of a server
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

-- |the specification of a serving process
data Server = Server {
	serverAddr :: SockAddr,
	serverTyp :: SocketType,
	serverRoutine :: ServerRoutine}

-- |Start one server acception connections and return immediatly. You can wait for the server thread
-- by reading the MVar
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)

-- |like 'serveNoBlock', but wait for the server thread to finish
serve :: Server -> IO ()
serve server = do
	(_, mvar) <- serveNoBlock server
	readMVar mvar

-- |Start a list of servers and return immediatly.
multiServeNoBlock :: [Server] -> IO [(ThreadId, MVar ())] 
multiServeNoBlock l = mapM serveNoBlock l

-- |Start a list of servers and wait for all server threads
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