{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables #-}
module Happstack.Server.Internal.Listen(listen, listen',listenOn,listenOnIPv4) where
import Happstack.Server.Internal.Types (Conf(..), Request, Response)
import Happstack.Server.Internal.Handler (request)
import Happstack.Server.Internal.Socket (acceptLite)
import Happstack.Server.Internal.TimeoutManager (cancel, initialize, register, forceTimeoutAll)
import Happstack.Server.Internal.TimeoutSocket as TS
import qualified Control.Concurrent.Thread.Group as TG
import Control.Exception.Extensible as E
import Control.Concurrent (forkIO, killThread, myThreadId)
import Control.Monad
import qualified Data.Maybe as Maybe
import Network.BSD (getProtocolNumber)
import qualified Network.Socket as Socket
import System.IO.Error (isFullError)
import System.Posix.Signals
import System.Log.Logger (Priority(..), logM)
log':: Priority -> String -> IO ()
log' :: Priority -> String -> IO ()
log' = String -> Priority -> String -> IO ()
logM "Happstack.Server.HTTP.Listen"
listenOn :: Int -> IO Socket.Socket
listenOn :: Int -> IO Socket
listenOn portm :: Int
portm = do
ProtocolNumber
proto <- String -> IO ProtocolNumber
getProtocolNumber "tcp"
IO Socket
-> (Socket -> IO ()) -> (Socket -> IO Socket) -> IO Socket
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracketOnError
(Family -> SocketType -> ProtocolNumber -> IO Socket
Socket.socket Family
Socket.AF_INET SocketType
Socket.Stream ProtocolNumber
proto)
(Socket -> IO ()
Socket.close)
(\sock :: Socket
sock -> do
Socket -> SocketOption -> Int -> IO ()
Socket.setSocketOption Socket
sock SocketOption
Socket.ReuseAddr 1
Socket -> SockAddr -> IO ()
Socket.bind Socket
sock (PortNumber -> HostAddress -> SockAddr
Socket.SockAddrInet (Int -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
portm) HostAddress
iNADDR_ANY)
Socket -> Int -> IO ()
Socket.listen Socket
sock (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max 1024 Int
Socket.maxListenQueue)
Socket -> IO Socket
forall (m :: * -> *) a. Monad m => a -> m a
return Socket
sock
)
listenOnIPv4 :: String
-> Int
-> IO Socket.Socket
listenOnIPv4 :: String -> Int -> IO Socket
listenOnIPv4 ip :: String
ip portm :: Int
portm = do
ProtocolNumber
proto <- String -> IO ProtocolNumber
getProtocolNumber "tcp"
HostAddress
hostAddr <- String -> IO HostAddress
inet_addr String
ip
IO Socket
-> (Socket -> IO ()) -> (Socket -> IO Socket) -> IO Socket
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracketOnError
(Family -> SocketType -> ProtocolNumber -> IO Socket
Socket.socket Family
Socket.AF_INET SocketType
Socket.Stream ProtocolNumber
proto)
(Socket -> IO ()
Socket.close)
(\sock :: Socket
sock -> do
Socket -> SocketOption -> Int -> IO ()
Socket.setSocketOption Socket
sock SocketOption
Socket.ReuseAddr 1
Socket -> SockAddr -> IO ()
Socket.bind Socket
sock (PortNumber -> HostAddress -> SockAddr
Socket.SockAddrInet (Int -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
portm) HostAddress
hostAddr)
Socket -> Int -> IO ()
Socket.listen Socket
sock (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max 1024 Int
Socket.maxListenQueue)
Socket -> IO Socket
forall (m :: * -> *) a. Monad m => a -> m a
return Socket
sock
)
inet_addr :: String -> IO Socket.HostAddress
inet_addr :: String -> IO HostAddress
inet_addr ip :: String
ip = do
[AddrInfo]
addrInfos <- Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
Socket.getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
Socket.defaultHints) (String -> Maybe String
forall a. a -> Maybe a
Just String
ip) (String -> Maybe String
forall a. a -> Maybe a
Just "tcp")
let getHostAddress :: AddrInfo -> Maybe HostAddress
getHostAddress addrInfo :: AddrInfo
addrInfo = case AddrInfo -> SockAddr
Socket.addrAddress AddrInfo
addrInfo of
Socket.SockAddrInet _ hostAddress :: HostAddress
hostAddress -> HostAddress -> Maybe HostAddress
forall a. a -> Maybe a
Just HostAddress
hostAddress
_ -> Maybe HostAddress
forall a. Maybe a
Nothing
IO HostAddress
-> (HostAddress -> IO HostAddress)
-> Maybe HostAddress
-> IO HostAddress
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> IO HostAddress
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "inet_addr: no HostAddress") HostAddress -> IO HostAddress
forall (f :: * -> *) a. Applicative f => a -> f a
pure
(Maybe HostAddress -> IO HostAddress)
-> ([HostAddress] -> Maybe HostAddress)
-> [HostAddress]
-> IO HostAddress
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [HostAddress] -> Maybe HostAddress
forall a. [a] -> Maybe a
Maybe.listToMaybe
([HostAddress] -> IO HostAddress)
-> [HostAddress] -> IO HostAddress
forall a b. (a -> b) -> a -> b
$ (AddrInfo -> Maybe HostAddress) -> [AddrInfo] -> [HostAddress]
forall a b. (a -> Maybe b) -> [a] -> [b]
Maybe.mapMaybe AddrInfo -> Maybe HostAddress
getHostAddress [AddrInfo]
addrInfos
iNADDR_ANY :: Socket.HostAddress
iNADDR_ANY :: HostAddress
iNADDR_ANY = 0
listen :: Conf -> (Request -> IO Response) -> IO ()
listen :: Conf -> (Request -> IO Response) -> IO ()
listen conf :: Conf
conf hand :: Request -> IO Response
hand = do
let port' :: Int
port' = Conf -> Int
port Conf
conf
Socket
lsocket <- Int -> IO Socket
listenOn Int
port'
Socket -> SocketOption -> Int -> IO ()
Socket.setSocketOption Socket
lsocket SocketOption
Socket.KeepAlive 1
Socket -> Conf -> (Request -> IO Response) -> IO ()
listen' Socket
lsocket Conf
conf Request -> IO Response
hand
listen' :: Socket.Socket -> Conf -> (Request -> IO Response) -> IO ()
listen' :: Socket -> Conf -> (Request -> IO Response) -> IO ()
listen' s :: Socket
s conf :: Conf
conf hand :: Request -> IO Response
hand = do
IO Handler -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Handler -> IO ()) -> IO Handler -> IO ()
forall a b. (a -> b) -> a -> b
$ ProtocolNumber -> Handler -> Maybe SignalSet -> IO Handler
installHandler ProtocolNumber
openEndedPipe Handler
Ignore Maybe SignalSet
forall a. Maybe a
Nothing
let port' :: Int
port' = Conf -> Int
port Conf
conf
fork :: IO () -> IO ThreadId
fork = case Conf -> Maybe ThreadGroup
threadGroup Conf
conf of
Nothing -> IO () -> IO ThreadId
forkIO
Just tg :: ThreadGroup
tg -> \m :: IO ()
m -> (ThreadId, IO (Result ())) -> ThreadId
forall a b. (a, b) -> a
fst ((ThreadId, IO (Result ())) -> ThreadId)
-> IO (ThreadId, IO (Result ())) -> IO ThreadId
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` ThreadGroup -> IO () -> IO (ThreadId, IO (Result ()))
forall a. ThreadGroup -> IO a -> IO (ThreadId, IO (Result a))
TG.forkIO ThreadGroup
tg IO ()
m
Manager
tm <- Int -> IO Manager
initialize ((Conf -> Int
timeout Conf
conf) Int -> Int -> Int
forall a. Num a => a -> a -> a
* (10Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^(6 :: Int)))
Priority -> String -> IO ()
log' Priority
NOTICE ("Listening for http:// on port " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
port')
let eh :: SomeException -> IO ()
eh (SomeException
x::SomeException) = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((SomeException -> Maybe AsyncException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
x) Maybe AsyncException -> Maybe AsyncException -> Bool
forall a. Eq a => a -> a -> Bool
/= AsyncException -> Maybe AsyncException
forall a. a -> Maybe a
Just AsyncException
ThreadKilled) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Priority -> String -> IO ()
log' Priority
ERROR ("HTTP request failed with: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
x)
work :: (Socket, String, a) -> IO ()
work (sock :: Socket
sock, hn :: String
hn, p :: a
p) =
do ThreadId
tid <- IO ThreadId
myThreadId
Handle
thandle <- Manager -> IO () -> IO Handle
register Manager
tm (ThreadId -> IO ()
killThread ThreadId
tid)
let timeoutIO :: TimeoutIO
timeoutIO = Handle -> Socket -> TimeoutIO
TS.timeoutSocketIO Handle
thandle Socket
sock
TimeoutIO
-> Maybe (LogAccess UTCTime)
-> Host
-> (Request -> IO Response)
-> IO ()
request TimeoutIO
timeoutIO (Conf -> forall t. FormatTime t => Maybe (LogAccess t)
logAccess Conf
conf) (String
hn,a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
p) Request -> IO Response
hand IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` SomeException -> IO ()
eh
Handle -> IO ()
cancel Handle
thandle
Socket -> IO ()
Socket.close Socket
sock
loop :: IO b
loop = IO ThreadId -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO ThreadId -> IO b) -> IO ThreadId -> IO b
forall a b. (a -> b) -> a -> b
$ do (Socket, String, PortNumber)
w <- Socket -> IO (Socket, String, PortNumber)
acceptLite Socket
s
IO () -> IO ThreadId
fork (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ (Socket, String, PortNumber) -> IO ()
forall a. Integral a => (Socket, String, a) -> IO ()
work (Socket, String, PortNumber)
w
pe :: a -> IO ()
pe e :: a
e = Priority -> String -> IO ()
log' Priority
ERROR ("ERROR in http accept thread: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
e)
infi :: IO ()
infi :: IO ()
infi = IO ()
forall b. IO b
loop IO () -> (SomeException -> IO ()) -> IO ()
`catchSome` SomeException -> IO ()
forall a. Show a => a -> IO ()
pe IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
infi
IO ()
infi IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` (Socket -> IO ()
Socket.close Socket
s IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Manager -> IO ()
forceTimeoutAll Manager
tm)
IO Handler -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Handler -> IO ()) -> IO Handler -> IO ()
forall a b. (a -> b) -> a -> b
$ ProtocolNumber -> Handler -> Maybe SignalSet -> IO Handler
installHandler ProtocolNumber
openEndedPipe Handler
Ignore Maybe SignalSet
forall a. Maybe a
Nothing
where
catchSome :: IO () -> (SomeException -> IO ()) -> IO ()
catchSome op :: IO ()
op h :: SomeException -> IO ()
h = IO ()
op IO () -> [Handler ()] -> IO ()
forall a. IO a -> [Handler a] -> IO a
`E.catches` [
(ArithException -> IO ()) -> Handler ()
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((ArithException -> IO ()) -> Handler ())
-> (ArithException -> IO ()) -> Handler ()
forall a b. (a -> b) -> a -> b
$ \(ArithException
e :: ArithException) -> SomeException -> IO ()
h (ArithException -> SomeException
forall e. Exception e => e -> SomeException
toException ArithException
e),
(ArrayException -> IO ()) -> Handler ()
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((ArrayException -> IO ()) -> Handler ())
-> (ArrayException -> IO ()) -> Handler ()
forall a b. (a -> b) -> a -> b
$ \(ArrayException
e :: ArrayException) -> SomeException -> IO ()
h (ArrayException -> SomeException
forall e. Exception e => e -> SomeException
toException ArrayException
e),
(IOException -> IO ()) -> Handler ()
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((IOException -> IO ()) -> Handler ())
-> (IOException -> IO ()) -> Handler ()
forall a b. (a -> b) -> a -> b
$ \(IOException
e :: IOException) ->
if IOException -> Bool
isFullError IOException
e
then () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else IOException -> IO ()
forall a e. Exception e => e -> a
throw IOException
e
]