module Happstack.Server.HTTP.Listen(listen, listen',listenOn) where
import Happstack.Server.HTTP.Types
import Happstack.Server.HTTP.Handler
import Happstack.Server.HTTP.Socket (acceptLite)
import Control.Exception.Extensible as E
import Control.Concurrent
import Network.BSD (getProtocolNumber)
import Network(sClose, Socket)
import Network.Socket as Socket (SocketOption(KeepAlive), setSocketOption,
socket, Family(..), SockAddr,
SocketOption(..), SockAddr(..),
iNADDR_ANY, maxListenQueue, SocketType(..),
bindSocket)
import qualified Network.Socket as Socket (listen)
import System.IO
import System.Posix.Signals
import System.Log.Logger (Priority(..), logM)
log':: Priority -> String -> IO ()
log' = logM "Happstack.Server.HTTP.Listen"
listenOn :: Int -> IO Socket
listenOn portm = do
proto <- getProtocolNumber "tcp"
E.bracketOnError
(socket AF_INET Stream proto)
(sClose)
(\sock -> do
setSocketOption sock ReuseAddr 1
bindSocket sock (SockAddrInet (fromIntegral portm) iNADDR_ANY)
Socket.listen sock maxListenQueue
return sock
)
listen :: Conf -> (Request -> IO Response) -> IO ()
listen conf hand = do
let port' = port conf
socketm <- listenOn port'
setSocketOption socketm KeepAlive 1
listen' socketm conf hand
listen' :: Socket -> Conf -> (Request -> IO Response) -> IO ()
listen' s conf hand = do
installHandler openEndedPipe Ignore Nothing
let port' = port conf
log' NOTICE ("Listening on port " ++ show port')
let work (h,hn,p) = do
let eh (x::SomeException) = log' ERROR ("HTTP request failed with: "++show x)
request conf h (hn,fromIntegral p) hand `E.catch` eh
hClose h
let loop = do acceptLite s >>= forkIO . work
loop
let pe e = log' ERROR ("ERROR in accept thread: "++
show e)
let infi = loop `catchSome` pe >> infi
infi `finally` sClose s
installHandler openEndedPipe Ignore Nothing
return ()
where
catchSome op h = op `E.catches` [
Handler $ \(e :: ArithException) -> h (toException e),
Handler $ \(e :: ArrayException) -> h (toException e)
]