{-# 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 qualified Network.Socket                 as Socket
import System.IO.Error                          (isFullError)
import Foreign.C (CInt)
{-
#ifndef mingw32_HOST_OS
-}
import System.Posix.Signals
{-
#endif
-}
import System.Log.Logger (Priority(..), logM)
log':: Priority -> String -> IO ()
log' :: Priority -> String -> IO ()
log' = String -> Priority -> String -> IO ()
logM String
"Happstack.Server.HTTP.Listen"

-- Meant to be TCP in practise.
-- See https://www.gnu.org/software/libc/manual/html_node/Creating-a-Socket.html
-- which says "zero is usually right".  It could theoretically be SCTP, but it
-- would be a bizarre system that defaults to SCTP over TCP.
proto :: CInt
proto :: CInt
proto = CInt
Socket.defaultProtocol

{-
   Network.listenOn binds randomly to IPv4 or IPv6 or both,
   depending on system and local settings.
   Lets make it use IPv4 only for now.
-}

listenOn :: Int -> IO Socket.Socket
listenOn :: Int -> IO Socket
listenOn Int
portm = do
    forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracketOnError
        (Family -> SocketType -> CInt -> IO Socket
Socket.socket Family
Socket.AF_INET SocketType
Socket.Stream CInt
proto)
        (Socket -> IO ()
Socket.close)
        (\Socket
sock -> do
            Socket -> SocketOption -> Int -> IO ()
Socket.setSocketOption Socket
sock SocketOption
Socket.ReuseAddr Int
1
            Socket -> SockAddr -> IO ()
Socket.bind Socket
sock (PortNumber -> HostAddress -> SockAddr
Socket.SockAddrInet (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
portm) HostAddress
iNADDR_ANY)
            Socket -> Int -> IO ()
Socket.listen Socket
sock (forall a. Ord a => a -> a -> a
max Int
1024 Int
Socket.maxListenQueue)
            forall (m :: * -> *) a. Monad m => a -> m a
return Socket
sock
        )

listenOnIPv4 :: String  -- ^ IP address to listen on (must be an IP address not a host name)
             -> Int     -- ^ port number to listen on
             -> IO Socket.Socket
listenOnIPv4 :: String -> Int -> IO Socket
listenOnIPv4 String
ip Int
portm = do
    HostAddress
hostAddr <- String -> IO HostAddress
inet_addr String
ip
    forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracketOnError
        (Family -> SocketType -> CInt -> IO Socket
Socket.socket Family
Socket.AF_INET SocketType
Socket.Stream CInt
proto)
        (Socket -> IO ()
Socket.close)
        (\Socket
sock -> do
            Socket -> SocketOption -> Int -> IO ()
Socket.setSocketOption Socket
sock SocketOption
Socket.ReuseAddr Int
1
            Socket -> SockAddr -> IO ()
Socket.bind Socket
sock (PortNumber -> HostAddress -> SockAddr
Socket.SockAddrInet (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
portm) HostAddress
hostAddr)
            Socket -> Int -> IO ()
Socket.listen Socket
sock (forall a. Ord a => a -> a -> a
max Int
1024 Int
Socket.maxListenQueue)
            forall (m :: * -> *) a. Monad m => a -> m a
return Socket
sock
        )

inet_addr :: String -> IO Socket.HostAddress
inet_addr :: String -> IO HostAddress
inet_addr String
ip = do
  [AddrInfo]
addrInfos <- Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
Socket.getAddrInfo (forall a. a -> Maybe a
Just AddrInfo
Socket.defaultHints) (forall a. a -> Maybe a
Just String
ip) forall a. Maybe a
Nothing
  let getHostAddress :: AddrInfo -> Maybe HostAddress
getHostAddress AddrInfo
addrInfo = case AddrInfo -> SockAddr
Socket.addrAddress AddrInfo
addrInfo of
        Socket.SockAddrInet PortNumber
_ HostAddress
hostAddress -> forall a. a -> Maybe a
Just HostAddress
hostAddress
        SockAddr
_ -> forall a. Maybe a
Nothing
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"inet_addr: no HostAddress") forall (f :: * -> *) a. Applicative f => a -> f a
pure
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe a
Maybe.listToMaybe
    forall a b. (a -> b) -> a -> b
$ 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 = HostAddress
0

-- | Bind and listen port
listen :: Conf -> (Request -> IO Response) -> IO ()
listen :: Conf -> (Request -> IO Response) -> IO ()
listen Conf
conf 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 Int
1
    Socket -> Conf -> (Request -> IO Response) -> IO ()
listen' Socket
lsocket Conf
conf Request -> IO Response
hand

-- | Use a previously bind port and listen
listen' :: Socket.Socket -> Conf -> (Request -> IO Response) -> IO ()
listen' :: Socket -> Conf -> (Request -> IO Response) -> IO ()
listen' Socket
s Conf
conf Request -> IO Response
hand = do
{-
#ifndef mingw32_HOST_OS
-}
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ CInt -> Handler -> Maybe SignalSet -> IO Handler
installHandler CInt
openEndedPipe Handler
Ignore forall a. Maybe a
Nothing
{-
#endif
-}
  let port' :: Int
port' = Conf -> Int
port Conf
conf
      fork :: IO () -> IO ThreadId
fork = case Conf -> Maybe ThreadGroup
threadGroup Conf
conf of
               Maybe ThreadGroup
Nothing -> IO () -> IO ThreadId
forkIO
               Just ThreadGroup
tg -> \IO ()
m -> forall a b. (a, b) -> a
fst forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` 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) forall a. Num a => a -> a -> a
* (Int
10forall a b. (Num a, Integral b) => a -> b -> a
^(Int
6 :: Int)))
  -- http:// loop
  Priority -> String -> IO ()
log' Priority
NOTICE (String
"Listening for http:// on port " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
port')
  let eh :: SomeException -> IO ()
eh (SomeException
x::SomeException) = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((forall e. Exception e => SomeException -> Maybe e
fromException SomeException
x) forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just AsyncException
ThreadKilled) forall a b. (a -> b) -> a -> b
$ Priority -> String -> IO ()
log' Priority
ERROR (String
"HTTP request failed with: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show SomeException
x)
      work :: (Socket, String, a) -> IO ()
work (Socket
sock, String
hn, 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,forall a b. (Integral a, Num b) => a -> b
fromIntegral a
p) Request -> IO Response
hand forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` SomeException -> IO ()
eh
             -- remove thread from timeout table
             Handle -> IO ()
cancel Handle
thandle
             Socket -> IO ()
Socket.close Socket
sock
      loop :: IO b
loop = forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do (Socket, String, PortNumber)
w <- Socket -> IO (Socket, String, PortNumber)
acceptLite Socket
s
                          IO () -> IO ThreadId
fork forall a b. (a -> b) -> a -> b
$ forall {a}. Integral a => (Socket, String, a) -> IO ()
work (Socket, String, PortNumber)
w
      pe :: a -> IO ()
pe a
e = Priority -> String -> IO ()
log' Priority
ERROR (String
"ERROR in http accept thread: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
e)
      infi :: IO ()
      infi :: IO ()
infi = forall {b}. IO b
loop IO () -> (SomeException -> IO ()) -> IO ()
`catchSome` forall {a}. Show a => a -> IO ()
pe forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
infi

  IO ()
infi forall a b. IO a -> IO b -> IO a
`finally` (Socket -> IO ()
Socket.close Socket
s forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Manager -> IO ()
forceTimeoutAll Manager
tm)

{--
#ifndef mingw32_HOST_OS
-}
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ CInt -> Handler -> Maybe SignalSet -> IO Handler
installHandler CInt
openEndedPipe Handler
Ignore forall a. Maybe a
Nothing
{-
#endif
-}
  where  -- why are these handlers needed?

    catchSome :: IO () -> (SomeException -> IO ()) -> IO ()
catchSome IO ()
op SomeException -> IO ()
h = IO ()
op forall a. IO a -> [Handler a] -> IO a
`E.catches` [
            forall a e. Exception e => (e -> IO a) -> Handler a
Handler forall a b. (a -> b) -> a -> b
$ \(ArithException
e :: ArithException) -> SomeException -> IO ()
h (forall e. Exception e => e -> SomeException
toException ArithException
e),
            forall a e. Exception e => (e -> IO a) -> Handler a
Handler forall a b. (a -> b) -> a -> b
$ \(ArrayException
e :: ArrayException) -> SomeException -> IO ()
h (forall e. Exception e => e -> SomeException
toException ArrayException
e),
            forall a e. Exception e => (e -> IO a) -> Handler a
Handler forall a b. (a -> b) -> a -> b
$ \(IOException
e :: IOException)    ->
                if IOException -> Bool
isFullError IOException
e
                   then forall (m :: * -> *) a. Monad m => a -> m a
return () -- h (toException e) -- we could log the exception, but there could be thousands of them
                   else forall a e. Exception e => e -> a
throw IOException
e
          ]