    {-# LANGUAGE BangPatterns        #-}
    {-# LANGUAGE CPP                 #-}
    {-# LANGUAGE OverloadedStrings   #-}
    {-# LANGUAGE RankNTypes          #-}
    {-# LANGUAGE ScopedTypeVariables #-}
    module Snap.Internal.Http.Server.Socket
      ( bindSocket
      , bindSocketImpl
      , bindUnixSocket
      , httpAcceptFunc
      , haProxyAcceptFunc
      , sendFileFunc
      , acceptAndInitialize
      ) where

    ------------------------------------------------------------------------------
    import           Control.Exception                 (bracketOnError, finally, throwIO)
    import           Control.Monad                     (when)
    import           Data.Bits                         (complement, (.&.))
    import           Data.ByteString.Char8             (ByteString)
    import           Network.Socket                    (Socket, SocketOption (NoDelay, ReuseAddr), accept, close, getSocketName, setSocketOption, socket)
    import qualified Network.Socket                    as N
    #ifdef HAS_SENDFILE
    import           Network.Socket                    (fdSocket)
    import           System.Posix.IO                   (OpenMode (..), closeFd, defaultFileFlags, openFd)
    import           System.Posix.Types                (Fd (..))
    import           System.SendFile                   (sendFile, sendHeaders)
    #else
    import           Data.ByteString.Builder           (byteString)
    import           Data.ByteString.Builder.Extra     (flush)
    import           Network.Socket.ByteString         (sendAll)
    #endif
    #ifdef HAS_UNIX_SOCKETS
    import           Control.Exception                 (bracket)
    import qualified Control.Exception                 as E (catch)
    import           System.FilePath                   (isRelative)
    import           System.IO.Error                   (isDoesNotExistError)
    import           System.Posix.Files                (accessModes, removeLink, setFileCreationMask)
    #endif

    ------------------------------------------------------------------------------
    import qualified System.IO.Streams                 as Streams
    ------------------------------------------------------------------------------
    import           Snap.Internal.Http.Server.Address (AddressNotSupportedException (..), getAddress, getSockAddr)
    import           Snap.Internal.Http.Server.Types   (AcceptFunc (..), SendFileHandler)
    import qualified System.IO.Streams.Network.HAProxy as HA

    ------------------------------------------------------------------------------
    bindSocket :: ByteString -> Int -> IO Socket
    bindSocket :: ByteString -> Int -> IO Socket
    bindSocket = (Socket -> SocketOption -> Int -> IO ())
    -> (Socket -> SockAddr -> IO ())
    -> (Socket -> Int -> IO ())
    -> ByteString
    -> Int
    -> IO Socket
    bindSocketImpl Socket -> SocketOption -> Int -> IO ()
    setSocketOption Socket -> SockAddr -> IO ()
    bind Socket -> Int -> IO ()
    N.listen
      where
    #if MIN_VERSION_network(2,7,0)
        bind :: Socket -> SockAddr -> IO ()
    bind = Socket -> SockAddr -> IO ()
    N.bind
    #else
        bind = N.bindSocket
    #endif
    {-# INLINE bindSocket #-}

    ------------------------------------------------------------------------------
    bindSocketImpl
        :: (Socket -> SocketOption -> Int -> IO ()) -- ^ mock setSocketOption
        -> (Socket -> N.SockAddr -> IO ())          -- ^ bindSocket
        -> (Socket -> Int -> IO ())                 -- ^ listen
        -> ByteString
        -> Int
        -> IO Socket
    bindSocketImpl :: (Socket -> SocketOption -> Int -> IO ())
    -> (Socket -> SockAddr -> IO ())
    -> (Socket -> Int -> IO ())
    -> ByteString
    -> Int
    -> IO Socket
    bindSocketImpl Socket -> SocketOption -> Int -> IO ()
    _setSocketOption Socket -> SockAddr -> IO ()
    _bindSocket Socket -> Int -> IO ()
    _listen ByteString
    bindAddr Int
    bindPort = do
        (family, addr) <- Int -> ByteString -> IO (Family, SockAddr)
    getSockAddr Int
    bindPort ByteString
    bindAddr
        bracketOnError (socket family N.Stream 0) N.close $ \Socket
    sock -> do
            Socket -> SocketOption -> Int -> IO ()
    _setSocketOption Socket
    sock SocketOption
    ReuseAddr Int
    1
            Socket -> SocketOption -> Int -> IO ()
    _setSocketOption Socket
    sock SocketOption
    NoDelay Int
    1
            Socket -> SockAddr -> IO ()
    _bindSocket Socket
    sock SockAddr
    addr
            Socket -> Int -> IO ()
    _listen Socket
    sock Int
    150
            Socket -> IO Socket
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Socket -> IO Socket) -> Socket -> IO Socket
    forall a b. (a -> b) -> a -> b
    $! Socket
    sock

    bindUnixSocket :: Maybe Int -> String -> IO Socket
    #if HAS_UNIX_SOCKETS
    bindUnixSocket :: Maybe Int -> [Char] -> IO Socket
    bindUnixSocket Maybe Int
    mode [Char]
    path = do
       Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when ([Char] -> Bool
    isRelative [Char]
    path) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $
          AddressNotSupportedException -> IO ()
    forall e a. (HasCallStack, Exception e) => e -> IO a
    throwIO (AddressNotSupportedException -> IO ())
    -> AddressNotSupportedException -> IO ()
    forall a b. (a -> b) -> a -> b
    $ [Char] -> AddressNotSupportedException
    AddressNotSupportedException
                    ([Char] -> AddressNotSupportedException)
    -> [Char] -> AddressNotSupportedException
    forall a b. (a -> b) -> a -> b
    $! [Char]
    "Refusing to bind unix socket to non-absolute path: " [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    path

       IO Socket
    -> (Socket -> IO ()) -> (Socket -> IO Socket) -> IO Socket
    forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
    bracketOnError (Family -> SocketType -> ProtocolNumber -> IO Socket
    socket Family
    N.AF_UNIX SocketType
    N.Stream ProtocolNumber
    0) Socket -> IO ()
    N.close ((Socket -> IO Socket) -> IO Socket)
    -> (Socket -> IO Socket) -> IO Socket
    forall a b. (a -> b) -> a -> b
    $ \Socket
    sock -> do
          IO () -> (IOError -> IO ()) -> IO ()
    forall e a. Exception e => IO a -> (e -> IO a) -> IO a
    E.catch ([Char] -> IO ()
    removeLink [Char]
    path) ((IOError -> IO ()) -> IO ()) -> (IOError -> IO ()) -> IO ()
    forall a b. (a -> b) -> a -> b
    $ \IOError
    e -> Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Bool -> Bool
    not (Bool -> Bool) -> Bool -> Bool
    forall a b. (a -> b) -> a -> b
    $ IOError -> Bool
    isDoesNotExistError IOError
    e) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ IOError -> IO ()
    forall e a. (HasCallStack, Exception e) => e -> IO a
    throwIO IOError
    e
          case Maybe Int
    mode of
             Maybe Int
    Nothing -> Socket -> SockAddr -> IO ()
    bind Socket
    sock ([Char] -> SockAddr
    N.SockAddrUnix [Char]
    path)
             Just Int
    mode' -> IO FileMode
    -> (FileMode -> IO FileMode) -> (FileMode -> IO ()) -> IO ()
    forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
    bracket (FileMode -> IO FileMode
    setFileCreationMask (FileMode -> IO FileMode) -> FileMode -> IO FileMode
    forall a b. (a -> b) -> a -> b
    $ Int -> FileMode
    forall {a}. Integral a => a -> FileMode
    modeToMask Int
    mode')
                                  FileMode -> IO FileMode
    setFileCreationMask
                                  (IO () -> FileMode -> IO ()
    forall a b. a -> b -> a
    const (IO () -> FileMode -> IO ()) -> IO () -> FileMode -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Socket -> SockAddr -> IO ()
    bind Socket
    sock ([Char] -> SockAddr
    N.SockAddrUnix [Char]
    path))
          Socket -> Int -> IO ()
    N.listen Socket
    sock Int
    150
          Socket -> IO Socket
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Socket -> IO Socket) -> Socket -> IO Socket
    forall a b. (a -> b) -> a -> b
    $! Socket
    sock
       where
    #if MIN_VERSION_network(2,7,0)
         bind :: Socket -> SockAddr -> IO ()
    bind = Socket -> SockAddr -> IO ()
    N.bind
    #else
         bind = N.bindSocket
    #endif
         modeToMask :: a -> FileMode
    modeToMask a
    p = FileMode
    accessModes FileMode -> FileMode -> FileMode
    forall a. Bits a => a -> a -> a
    .&. FileMode -> FileMode
    forall a. Bits a => a -> a
    complement (a -> FileMode
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral a
    p)
    #else
    bindUnixSocket _ path = throwIO (AddressNotSupportedException $ "unix:" ++ path)
    #endif

    ------------------------------------------------------------------------------
    -- TODO(greg): move buffer size configuration into config
    bUFSIZ :: Int
    bUFSIZ :: Int
    bUFSIZ = Int
    4064

    ------------------------------------------------------------------------------
    acceptAndInitialize :: Socket        -- ^ bound socket
                        -> (forall b . IO b -> IO b)
                        -> ((Socket, N.SockAddr) -> IO a)
                        -> IO a
    acceptAndInitialize :: forall a.
    Socket
    -> (forall b. IO b -> IO b) -> ((Socket, SockAddr) -> IO a) -> IO a
    acceptAndInitialize Socket
    boundSocket forall b. IO b -> IO b
    restore (Socket, SockAddr) -> IO a
    f =
        IO (Socket, SockAddr)
    -> ((Socket, SockAddr) -> IO ())
    -> ((Socket, SockAddr) -> IO a)
    -> IO a
    forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
    bracketOnError (IO (Socket, SockAddr) -> IO (Socket, SockAddr)
    forall b. IO b -> IO b
    restore (IO (Socket, SockAddr) -> IO (Socket, SockAddr))
    -> IO (Socket, SockAddr) -> IO (Socket, SockAddr)
    forall a b. (a -> b) -> a -> b
    $ Socket -> IO (Socket, SockAddr)
    accept Socket
    boundSocket)
                       (Socket -> IO ()
    close (Socket -> IO ())
    -> ((Socket, SockAddr) -> Socket) -> (Socket, SockAddr) -> IO ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Socket, SockAddr) -> Socket
    forall a b. (a, b) -> a
    fst)
                       (Socket, SockAddr) -> IO a
    f

    ------------------------------------------------------------------------------
    haProxyAcceptFunc :: Socket     -- ^ bound socket
                      -> AcceptFunc
    haProxyAcceptFunc :: Socket -> AcceptFunc
    haProxyAcceptFunc Socket
    boundSocket =
        ((forall b. IO b -> IO b)
     -> IO
          (SendFileHandler, ByteString, Int, ByteString, Int,
           InputStream ByteString, OutputStream ByteString, IO ()))
    -> AcceptFunc
    AcceptFunc (((forall b. IO b -> IO b)
      -> IO
           (SendFileHandler, ByteString, Int, ByteString, Int,
            InputStream ByteString, OutputStream ByteString, IO ()))
     -> AcceptFunc)
    -> ((forall b. IO b -> IO b)
        -> IO
             (SendFileHandler, ByteString, Int, ByteString, Int,
              InputStream ByteString, OutputStream ByteString, IO ()))
    -> AcceptFunc
    forall a b. (a -> b) -> a -> b
    $ \forall b. IO b -> IO b
    restore ->
        Socket
    -> (forall b. IO b -> IO b)
    -> ((Socket, SockAddr)
        -> IO
             (SendFileHandler, ByteString, Int, ByteString, Int,
              InputStream ByteString, OutputStream ByteString, IO ()))
    -> IO
         (SendFileHandler, ByteString, Int, ByteString, Int,
          InputStream ByteString, OutputStream ByteString, IO ())
    forall a.
    Socket
    -> (forall b. IO b -> IO b) -> ((Socket, SockAddr) -> IO a) -> IO a
    acceptAndInitialize Socket
    boundSocket IO b -> IO b
    forall b. IO b -> IO b
    restore (((Socket, SockAddr)
      -> IO
           (SendFileHandler, ByteString, Int, ByteString, Int,
            InputStream ByteString, OutputStream ByteString, IO ()))
     -> IO
          (SendFileHandler, ByteString, Int, ByteString, Int,
           InputStream ByteString, OutputStream ByteString, IO ()))
    -> ((Socket, SockAddr)
        -> IO
             (SendFileHandler, ByteString, Int, ByteString, Int,
              InputStream ByteString, OutputStream ByteString, IO ()))
    -> IO
         (SendFileHandler, ByteString, Int, ByteString, Int,
          InputStream ByteString, OutputStream ByteString, IO ())
    forall a b. (a -> b) -> a -> b
    $ \(Socket
    sock, SockAddr
    saddr) -> do
            (readEnd, writeEnd)      <- Int
    -> Socket -> IO (InputStream ByteString, OutputStream ByteString)
    Streams.socketToStreamsWithBufferSize
                                            Int
    bUFSIZ Socket
    sock
            localPInfo               <- HA.socketToProxyInfo sock saddr
            pinfo                    <- HA.decodeHAProxyHeaders localPInfo readEnd
            (localPort, localHost)   <- getAddress $ HA.getDestAddr pinfo
            (remotePort, remoteHost) <- getAddress $ HA.getSourceAddr pinfo
            let cleanup              =  Maybe ByteString -> OutputStream ByteString -> IO ()
    forall a. Maybe a -> OutputStream a -> IO ()
    Streams.write Maybe ByteString
    forall a. Maybe a
    Nothing OutputStream ByteString
    writeEnd
                                            IO () -> IO () -> IO ()
    forall a b. IO a -> IO b -> IO a
    `finally` Socket -> IO ()
    close Socket
    sock
            return $! ( sendFileFunc sock
                      , localHost
                      , localPort
                      , remoteHost
                      , remotePort
                      , readEnd
                      , writeEnd
                      , cleanup
                      )

    ------------------------------------------------------------------------------
    httpAcceptFunc :: Socket                     -- ^ bound socket
                   -> AcceptFunc
    httpAcceptFunc :: Socket -> AcceptFunc
    httpAcceptFunc Socket
    boundSocket =
        ((forall b. IO b -> IO b)
     -> IO
          (SendFileHandler, ByteString, Int, ByteString, Int,
           InputStream ByteString, OutputStream ByteString, IO ()))
    -> AcceptFunc
    AcceptFunc (((forall b. IO b -> IO b)
      -> IO
           (SendFileHandler, ByteString, Int, ByteString, Int,
            InputStream ByteString, OutputStream ByteString, IO ()))
     -> AcceptFunc)
    -> ((forall b. IO b -> IO b)
        -> IO
             (SendFileHandler, ByteString, Int, ByteString, Int,
              InputStream ByteString, OutputStream ByteString, IO ()))
    -> AcceptFunc
    forall a b. (a -> b) -> a -> b
    $ \forall b. IO b -> IO b
    restore ->
        Socket
    -> (forall b. IO b -> IO b)
    -> ((Socket, SockAddr)
        -> IO
             (SendFileHandler, ByteString, Int, ByteString, Int,
              InputStream ByteString, OutputStream ByteString, IO ()))
    -> IO
         (SendFileHandler, ByteString, Int, ByteString, Int,
          InputStream ByteString, OutputStream ByteString, IO ())
    forall a.
    Socket
    -> (forall b. IO b -> IO b) -> ((Socket, SockAddr) -> IO a) -> IO a
    acceptAndInitialize Socket
    boundSocket IO b -> IO b
    forall b. IO b -> IO b
    restore (((Socket, SockAddr)
      -> IO
           (SendFileHandler, ByteString, Int, ByteString, Int,
            InputStream ByteString, OutputStream ByteString, IO ()))
     -> IO
          (SendFileHandler, ByteString, Int, ByteString, Int,
           InputStream ByteString, OutputStream ByteString, IO ()))
    -> ((Socket, SockAddr)
        -> IO
             (SendFileHandler, ByteString, Int, ByteString, Int,
              InputStream ByteString, OutputStream ByteString, IO ()))
    -> IO
         (SendFileHandler, ByteString, Int, ByteString, Int,
          InputStream ByteString, OutputStream ByteString, IO ())
    forall a b. (a -> b) -> a -> b
    $ \(Socket
    sock, SockAddr
    remoteAddr) -> do
            localAddr                <- Socket -> IO SockAddr
    getSocketName Socket
    sock
            (localPort, localHost)   <- getAddress localAddr
            (remotePort, remoteHost) <- getAddress remoteAddr
            (readEnd, writeEnd)      <- Streams.socketToStreamsWithBufferSize bUFSIZ
                                                                              sock
            let cleanup              =  Maybe ByteString -> OutputStream ByteString -> IO ()
    forall a. Maybe a -> OutputStream a -> IO ()
    Streams.write Maybe ByteString
    forall a. Maybe a
    Nothing OutputStream ByteString
    writeEnd
                                          IO () -> IO () -> IO ()
    forall a b. IO a -> IO b -> IO a
    `finally` Socket -> IO ()
    close Socket
    sock
            return $! ( sendFileFunc sock
                      , localHost
                      , localPort
                      , remoteHost
                      , remotePort
                      , readEnd
                      , writeEnd
                      , cleanup
                      )

    ------------------------------------------------------------------------------
    sendFileFunc :: Socket -> SendFileHandler
    #ifdef HAS_SENDFILE
    sendFileFunc :: Socket -> SendFileHandler
    sendFileFunc Socket
    sock !Buffer
    _ Builder
    builder [Char]
    fPath Word64
    offset Word64
    nbytes = IO Fd -> (Fd -> IO ()) -> (Fd -> IO ()) -> IO ()
    forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
    bracket IO Fd
    acquire Fd -> IO ()
    closeFd Fd -> IO ()
    go
      where
    #if MIN_VERSION_unix(2,8,0)
        acquire :: IO Fd
    acquire   = [Char] -> OpenMode -> OpenFileFlags -> IO Fd
    openFd [Char]
    fPath OpenMode
    ReadOnly OpenFileFlags
    defaultFileFlags
    #else
        acquire   = openFd fPath ReadOnly Nothing defaultFileFlags
    #endif

    #if MIN_VERSION_network(3,0,0)
        go :: Fd -> IO ()
    go Fd
    fileFd = do sockFd <- ProtocolNumber -> Fd
    Fd (ProtocolNumber -> Fd) -> IO ProtocolNumber -> IO Fd
    forall a b. (a -> b) -> IO a -> IO b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    `fmap` Socket -> IO ProtocolNumber
    fdSocket Socket
    sock
                       sendHeaders builder sockFd
                       sendFile sockFd fileFd offset nbytes
    #else
        go fileFd = do let sockFd = Fd $ fdSocket sock
                       sendHeaders builder sockFd
                       sendFile sockFd fileFd offset nbytes
    #endif

    #else
    sendFileFunc sock buffer builder fPath offset nbytes =
        Streams.unsafeWithFileAsInputStartingAt (fromIntegral offset) fPath $
                \fileInput0 -> do
            fileInput <- Streams.takeBytes (fromIntegral nbytes) fileInput0 >>=
                         Streams.map byteString
            input     <- Streams.fromList [builder] >>=
                         flip Streams.appendInputStream fileInput
            output    <- Streams.makeOutputStream sendChunk >>=
                         Streams.unsafeBuilderStream (return buffer)
            Streams.supply input output
            Streams.write (Just flush) output

      where
        sendChunk (Just s) = sendAll sock s
        sendChunk Nothing  = return $! ()
    #endif