1 {-# LANGUAGE ForeignFunctionInterface #-}
    2 {-# LANGUAGE OverloadedStrings #-}
    3 {-# LANGUAGE CPP #-}
    4 
    5 module Snap.Internal.Http.Server.HttpPort
    6   ( bindHttp
    7   , createSession
    8   , endSession
    9   , recv
   10   , send
   11   ) where
   12 
   13 
   14 ------------------------------------------------------------------------------
   15 import           Data.ByteString (ByteString)
   16 import qualified Data.ByteString as B
   17 import           Data.ByteString.Internal (w2c)
   18 import           Foreign
   19 import           Foreign.C
   20 import           Network.Socket hiding (recv, send)
   21 
   22 #ifdef PORTABLE
   23 import qualified Network.Socket.ByteString as SB
   24 #else
   25 import qualified Data.ByteString.Internal as BI
   26 import qualified Data.ByteString.Unsafe as BI
   27 #endif
   28 
   29 import           Snap.Internal.Debug
   30 import           Snap.Internal.Http.Server.Backend
   31 
   32 ------------------------------------------------------------------------------
   33 bindHttp :: ByteString -> Int -> IO ListenSocket
   34 bindHttp bindAddr bindPort = do
   35     sock <- socket AF_INET Stream 0
   36     addr <- getHostAddr bindPort bindAddr
   37     debug $ "bindHttp: binding port " ++ show addr
   38     setSocketOption sock ReuseAddr 1
   39     bindSocket sock addr
   40     listen sock 150
   41     debug $ "bindHttp: bound socket " ++ show sock
   42     return $ ListenHttp sock
   43 
   44 
   45 ------------------------------------------------------------------------------
   46 getHostAddr :: Int
   47             -> ByteString
   48             -> IO SockAddr
   49 getHostAddr p s = do
   50     h <- if s == "*"
   51           then return iNADDR_ANY
   52           else inet_addr (map w2c . B.unpack $ s)
   53 
   54     return $ SockAddrInet (fromIntegral p) h
   55 
   56 
   57 ------------------------------------------------------------------------------
   58 createSession :: Int -> CInt -> IO () -> IO NetworkSession
   59 createSession buffSize s _ =
   60     return $ NetworkSession s nullPtr $ fromIntegral buffSize
   61 
   62 
   63 ------------------------------------------------------------------------------
   64 endSession :: NetworkSession -> IO ()
   65 endSession _ = return ()
   66 
   67 #ifdef PORTABLE
   68 
   69 ------------------------------------------------------------------------------
   70 recv :: Socket -> IO () -> NetworkSession -> IO (Maybe ByteString)
   71 recv sock _ (NetworkSession { _recvLen = s }) = do
   72     bs <- SB.recv sock (fromIntegral s)
   73     if B.null bs
   74         then return Nothing
   75         else return $ Just bs
   76 
   77 
   78 ------------------------------------------------------------------------------
   79 send :: Socket -> IO () -> IO () -> NetworkSession -> ByteString -> IO ()
   80 send sock tickle _ _ bs = SB.sendAll sock bs >> tickle
   81 
   82 #else
   83 
   84 ------------------------------------------------------------------------------
   85 recv :: IO () -> NetworkSession -> IO (Maybe ByteString)
   86 recv onBlock (NetworkSession s _ buffSize) = do
   87     fp <- BI.mallocByteString $ fromEnum buffSize
   88     sz <- withForeignPtr fp $ \p ->
   89               throwErrnoIfMinus1RetryMayBlock
   90                   "recv"
   91                   (c_read s p $ toEnum buffSize)
   92                   onBlock
   93 
   94     if sz == 0
   95       then return Nothing
   96       else return $ Just $ BI.fromForeignPtr fp 0 $ fromEnum sz
   97 
   98 
   99 ------------------------------------------------------------------------------
  100 send :: IO () -> IO () -> NetworkSession -> ByteString -> IO ()
  101 send tickleTimeout onBlock (NetworkSession s _ _) bs =
  102     BI.unsafeUseAsCStringLen bs $ uncurry loop
  103   where loop ptr len = do
  104           sent <- throwErrnoIfMinus1RetryMayBlock
  105                     "send"
  106                     (c_write s ptr $ toEnum len)
  107                     onBlock
  108 
  109           let sent' = fromIntegral sent
  110           if sent' < len
  111              then tickleTimeout >> loop (plusPtr ptr sent') (len - sent')
  112              else return ()
  113 
  114 
  115 ------------------------------------------------------------------------------
  116 foreign import ccall unsafe "unistd.h read" c_read
  117     :: CInt -> Ptr a -> CSize -> IO (CSize)
  118 foreign import ccall unsafe "unistd.h write" c_write
  119     :: CInt -> Ptr a -> CSize -> IO (CSize)
  120 
  121 #endif