module Snap.Internal.Http.Server.HttpPort
( bindHttp
, createSession
, endSession
, recv
, send
) where
import Data.ByteString (ByteString)
import Foreign
import Foreign.C
import Network.Socket hiding (recv, send)
import Unsafe.Coerce
#ifdef PORTABLE
import qualified Data.ByteString as B
import qualified Network.Socket.ByteString as SB
#else
import qualified Data.ByteString.Internal as BI
import qualified Data.ByteString.Unsafe as BI
#endif
import Snap.Internal.Debug
import Snap.Internal.Http.Server.Backend
import Snap.Internal.Http.Server.Address
bindHttp :: ByteString -> Int -> IO ListenSocket
bindHttp bindAddr bindPort = do
(family, addr) <- getSockAddr bindPort bindAddr
sock <- socket family Stream 0
debug $ "bindHttp: binding port " ++ show addr
setSocketOption sock ReuseAddr 1
bindSocket sock addr
listen sock 150
debug $ "bindHttp: bound socket " ++ show sock
return $! ListenHttp sock
createSession :: Int -> CInt -> IO () -> IO NetworkSession
createSession buffSize s _ =
return $! NetworkSession s (unsafeCoerce ()) $ fromIntegral buffSize
endSession :: NetworkSession -> IO ()
endSession _ = return ()
#ifdef PORTABLE
recv :: Socket -> IO () -> NetworkSession -> IO (Maybe ByteString)
recv sock _ (NetworkSession { _recvLen = s }) = do
bs <- SB.recv sock (fromIntegral s)
return $! if B.null bs then Nothing else Just bs
send :: Socket -> IO () -> IO () -> NetworkSession -> ByteString -> IO ()
send sock tickle _ _ bs = SB.sendAll sock bs >> tickle
#else
recv :: IO () -> NetworkSession -> IO (Maybe ByteString)
recv onBlock (NetworkSession s _ buffSize) = do
fp <- BI.mallocByteString $ fromEnum buffSize
sz <- withForeignPtr fp $ \p ->
throwErrnoIfMinus1RetryMayBlock
"recv"
(c_read s p $ toEnum buffSize)
onBlock
if sz == 0
then return Nothing
else return $! Just $! BI.fromForeignPtr fp 0 $! fromEnum sz
send :: IO () -> IO () -> NetworkSession -> ByteString -> IO ()
send tickleTimeout onBlock (NetworkSession s _ _) bs =
BI.unsafeUseAsCStringLen bs $ uncurry loop
where
loop ptr len = do
sent <- throwErrnoIfMinus1RetryMayBlock
"send"
(c_write s ptr $ toEnum len)
onBlock
let sent' = fromIntegral sent
if sent' < len
then tickleTimeout >> loop (plusPtr ptr sent') (len sent')
else tickleTimeout
foreign import ccall unsafe "unistd.h read" c_read
:: CInt -> Ptr a -> CSize -> IO (CSize)
foreign import ccall unsafe "unistd.h write" c_write
:: CInt -> Ptr a -> CSize -> IO (CSize)
#endif