    {-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables #-}
    module Happstack.Server.Internal.Listen(listen, listen',listenOn,listenOnIPv4) where

    import Data.Maybe                               (isNothing)
    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
        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 -> 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 (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 Int
    1024 Int
    Socket.maxListenQueue)
                Socket -> IO Socket
    forall a. a -> IO a
    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
        hostAddr <- String -> IO HostAddress
    inet_addr String
    ip
        E.bracketOnError
            (Socket.socket Socket.AF_INET Socket.Stream proto)
            (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 (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 Int
    1024 Int
    Socket.maxListenQueue)
                Socket -> IO Socket
    forall a. a -> IO a
    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
      addrInfos <- Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
    forall (t :: * -> *).
    GetAddrInfo t =>
    Maybe AddrInfo -> Maybe String -> Maybe String -> IO (t 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) Maybe String
    forall a. Maybe a
    Nothing
      let getHostAddress AddrInfo
    addrInfo = case AddrInfo -> SockAddr
    Socket.addrAddress AddrInfo
    addrInfo of
            Socket.SockAddrInet PortNumber
    _ HostAddress
    hostAddress -> HostAddress -> Maybe HostAddress
    forall a. a -> Maybe a
    Just HostAddress
    hostAddress
            SockAddr
    _ -> Maybe HostAddress
    forall a. Maybe a
    Nothing
      maybe (fail "inet_addr: no HostAddress") pure
        . Maybe.listToMaybe
        $ Maybe.mapMaybe getHostAddress 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
        lsocket <- Int -> IO Socket
    listenOn Int
    port'
        Socket.setSocketOption lsocket Socket.KeepAlive 1
        listen' lsocket conf 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
    -}
      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
    $ CInt -> Handler -> Maybe SignalSet -> IO Handler
    installHandler CInt
    openEndedPipe Handler
    Ignore Maybe SignalSet
    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 -> (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
      tm <- Int -> IO Manager
    initialize ((Conf -> Int
    timeout Conf
    conf) Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * (Int
    10Int -> Int -> Int
    forall a b. (Num a, Integral b) => a -> b -> a
    ^(Int
    6 :: Int)))
      -- http:// loop
      log' NOTICE ("Listening for http:// on port " ++ show port')
      let 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 (String
    "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
    sock, String
    hn, a
    p) =
              do tid <- IO ThreadId
    myThreadId
                 thandle <- register tm (killThread tid)
                 let timeoutIO = Handle -> Socket -> TimeoutIO
    TS.timeoutSocketIO Handle
    thandle Socket
    sock
                 request timeoutIO (logAccess conf) (hn,fromIntegral p) hand `E.catch` eh
                 -- remove thread from timeout table
                 cancel thandle
                 Socket.close sock
          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 w <- Socket -> IO (Socket, String, PortNumber)
    acceptLite Socket
    s
                              fork $ work w
          pe a
    e = Priority -> String -> IO ()
    log' Priority
    ERROR (String
    "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 ()
    forall {b}. IO b
    loop IO () -> (SomeException -> IO ()) -> IO ()
    `catchSome` SomeException -> IO ()
    forall {a}. Show a => a -> IO ()
    pe IO () -> IO () -> IO ()
    forall a b. IO a -> IO b -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> IO ()
    infi

      infi `finally` (Socket.close s >> when (isNothing $ threadGroup conf) (forceTimeoutAll tm))

    {--
    #ifndef mingw32_HOST_OS
    -}
      void $ installHandler openEndedPipe Ignore Nothing
    {-
    #endif
    -}
      where  -- why are these handlers needed?

        catchSome :: IO () -> (SomeException -> IO ()) -> IO ()
    catchSome IO ()
    op 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 a. a -> IO a
    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 IOException -> IO ()
    forall a e. (HasCallStack, Exception e) => e -> a
    throw IOException
    e
              ]