diff --git a/Network/Socket.hsc b/Network/Socket.hsc --- a/Network/Socket.hsc +++ b/Network/Socket.hsc @@ -1305,6 +1305,9 @@ }) poke p (AddrInfo flags family socketType protocol _ _) = do +#if defined(darwin_HOST_OS) + zeroMemory p (#const sizeof(struct addrinfo)) +#endif c_stype <- packSocketTypeOrThrow "AddrInfo.poke" socketType (#poke struct addrinfo, ai_flags) p (packBits aiFlagMapping flags) diff --git a/Network/URI.hs b/Network/URI.hs --- a/Network/URI.hs +++ b/Network/URI.hs @@ -970,9 +970,50 @@ -- unEscapeString :: String -> String unEscapeString [] = "" -unEscapeString ('%':x1:x2:s) | isHexDigit x1 && isHexDigit x2 = - chr (digitToInt x1 * 16 + digitToInt x2) : unEscapeString s -unEscapeString (c:s) = c : unEscapeString s +unEscapeString s@(c:cs) = case unEscapeByte s of + Just (byte, rest) -> unEscapeUtf8 byte rest + Nothing -> c : unEscapeString cs + +unEscapeByte :: String -> Maybe (Int, String) +unEscapeByte ('%':x1:x2:s) | isHexDigit x1 && isHexDigit x2 = + Just (digitToInt x1 * 16 + digitToInt x2, s) +unEscapeByte _ = Nothing + +-- Adapted from http://hackage.haskell.org/package/utf8-string +-- by Eric Mertens, BSD3 +unEscapeUtf8 :: Int -> String -> String +unEscapeUtf8 c rest + | c < 0x80 = chr c : unEscapeString rest + | c < 0xc0 = replacement_character : unEscapeString rest + | c < 0xe0 = multi1 + | c < 0xf0 = multi_byte 2 0xf 0x800 + | c < 0xf8 = multi_byte 3 0x7 0x10000 + | c < 0xfc = multi_byte 4 0x3 0x200000 + | c < 0xfe = multi_byte 5 0x1 0x4000000 + | otherwise = replacement_character : unEscapeString rest + where + replacement_character = '\xfffd' + multi1 = case unEscapeByte rest of + Just (c1, ds) | c1 .&. 0xc0 == 0x80 -> + let d = ((fromEnum c .&. 0x1f) `shiftL` 6) .|. fromEnum (c1 .&. 0x3f) + in if d >= 0x000080 then toEnum d : unEscapeString ds + else replacement_character : unEscapeString ds + _ -> replacement_character : unEscapeString rest + + multi_byte i mask overlong = + aux i rest (unEscapeByte rest) (c .&. mask) + where + aux 0 rs _ acc + | overlong <= acc && acc <= 0x10ffff && + (acc < 0xd800 || 0xdfff < acc) && + (acc < 0xfffe || 0xffff < acc) = chr acc : unEscapeString rs + | otherwise = replacement_character : unEscapeString rs + + aux n _ (Just (r, rs)) acc + | r .&. 0xc0 == 0x80 = aux (n-1) rs (unEscapeByte rs) + $! shiftL acc 6 .|. (r .&. 0x3f) + + aux _ rs _ _ = replacement_character : unEscapeString rs ------------------------------------------------------------ -- Resolving a relative URI relative to a base URI diff --git a/include/HsNet.h b/include/HsNet.h --- a/include/HsNet.h +++ b/include/HsNet.h @@ -172,4 +172,8 @@ # endif #endif +#if !defined(IOV_MAX) +# define IOV_MAX 1024 +#endif + #endif /* HSNET_H */ diff --git a/network.cabal b/network.cabal --- a/network.cabal +++ b/network.cabal @@ -1,5 +1,5 @@ name: network -version: 2.4.1.0 +version: 2.4.1.1 license: BSD3 license-file: LICENSE maintainer: Johan Tibell @@ -80,7 +80,8 @@ HUnit, network, test-framework, - test-framework-hunit + test-framework-hunit, + test-framework-quickcheck2 source-repository head type: git diff --git a/tests/Simple.hs b/tests/Simple.hs --- a/tests/Simple.hs +++ b/tests/Simple.hs @@ -3,7 +3,7 @@ module Main where import Control.Concurrent (ThreadId, forkIO, myThreadId) -import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) +import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar, readMVar) import qualified Control.Exception as E import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as C @@ -15,9 +15,6 @@ ------------------------------------------------------------------------ -serverPort :: PortNumber -serverPort = fromIntegral (3000 :: Int) - serverAddr :: String serverAddr = "127.0.0.1" @@ -32,84 +29,88 @@ testSend :: Assertion testSend = tcpTest client server - where - server sock = recv sock 1024 >>= (@=?) testMsg - client sock = send sock testMsg + where + server sock = recv sock 1024 >>= (@=?) testMsg + client sock = send sock testMsg testSendAll :: Assertion testSendAll = tcpTest client server - where - server sock = recv sock 1024 >>= (@=?) testMsg - client sock = sendAll sock testMsg + where + server sock = recv sock 1024 >>= (@=?) testMsg + client sock = sendAll sock testMsg testSendTo :: Assertion testSendTo = udpTest client server - where - server sock = recv sock 1024 >>= (@=?) testMsg - client sock = do addr <- inet_addr serverAddr - sendTo sock testMsg (SockAddrInet serverPort addr) + where + server sock = recv sock 1024 >>= (@=?) testMsg + client sock serverPort = do + addr <- inet_addr serverAddr + sendTo sock testMsg (SockAddrInet serverPort addr) testSendAllTo :: Assertion testSendAllTo = udpTest client server - where - server sock = recv sock 1024 >>= (@=?) testMsg - client sock = do addr <- inet_addr serverAddr - sendAllTo sock testMsg (SockAddrInet serverPort addr) + where + server sock = recv sock 1024 >>= (@=?) testMsg + client sock serverPort = do + addr <- inet_addr serverAddr + sendAllTo sock testMsg (SockAddrInet serverPort addr) testSendMany :: Assertion testSendMany = tcpTest client server - where - server sock = recv sock 1024 >>= (@=?) (S.append seg1 seg2) - client sock = sendMany sock [seg1, seg2] + where + server sock = recv sock 1024 >>= (@=?) (S.append seg1 seg2) + client sock = sendMany sock [seg1, seg2] - seg1 = C.pack "This is a " - seg2 = C.pack "test message." + seg1 = C.pack "This is a " + seg2 = C.pack "test message." testSendManyTo :: Assertion testSendManyTo = udpTest client server - where - server sock = recv sock 1024 >>= (@=?) (S.append seg1 seg2) - client sock = do addr <- inet_addr serverAddr - sendManyTo sock [seg1, seg2] - (SockAddrInet serverPort addr) + where + server sock = recv sock 1024 >>= (@=?) (S.append seg1 seg2) + client sock serverPort = do + addr <- inet_addr serverAddr + sendManyTo sock [seg1, seg2] (SockAddrInet serverPort addr) - seg1 = C.pack "This is a " - seg2 = C.pack "test message." + seg1 = C.pack "This is a " + seg2 = C.pack "test message." testRecv :: Assertion testRecv = tcpTest client server - where - server sock = recv sock 1024 >>= (@=?) testMsg - client sock = send sock testMsg + where + server sock = recv sock 1024 >>= (@=?) testMsg + client sock = send sock testMsg testOverFlowRecv :: Assertion testOverFlowRecv = tcpTest client server - where - server sock = do seg1 <- recv sock (S.length testMsg - 3) - seg2 <- recv sock 1024 - let msg = S.append seg1 seg2 - testMsg @=? msg + where + server sock = do seg1 <- recv sock (S.length testMsg - 3) + seg2 <- recv sock 1024 + let msg = S.append seg1 seg2 + testMsg @=? msg - client sock = send sock testMsg + client sock = send sock testMsg testRecvFrom :: Assertion testRecvFrom = tcpTest client server - where - server sock = do (msg, _) <- recvFrom sock 1024 - testMsg @=? msg + where + server sock = do (msg, _) <- recvFrom sock 1024 + testMsg @=? msg - client sock = do addr <- inet_addr serverAddr - sendTo sock testMsg (SockAddrInet serverPort addr) + client sock = do + serverPort <- getPeerPort sock + addr <- inet_addr serverAddr + sendTo sock testMsg (SockAddrInet serverPort addr) testOverFlowRecvFrom :: Assertion testOverFlowRecvFrom = tcpTest client server - where - server sock = do (seg1, _) <- recvFrom sock (S.length testMsg - 3) - (seg2, _) <- recvFrom sock 1024 - let msg = S.append seg1 seg2 - testMsg @=? msg + where + server sock = do (seg1, _) <- recvFrom sock (S.length testMsg - 3) + (seg2, _) <- recvFrom sock 1024 + let msg = S.append seg1 seg2 + testMsg @=? msg - client sock = send sock testMsg + client sock = send sock testMsg ------------------------------------------------------------------------ -- Other @@ -139,27 +140,41 @@ ------------------------------------------------------------------------ -- Test helpers +-- | Returns the 'PortNumber' of the peer. Will throw an 'error' if +-- used on a non-IP socket. +getPeerPort :: Socket -> IO PortNumber +getPeerPort sock = do + sockAddr <- getPeerName sock + case sockAddr of + (SockAddrInet port _) -> return port + (SockAddrInet6 port _ _ _) -> return port + _ -> error "getPeerPort: only works with IP sockets" + -- | Establish a connection between client and server and then run -- 'clientAct' and 'serverAct', in different threads. Both actions -- get passed a connected 'Socket', used for communicating between -- client and server. 'tcpTest' makes sure that the 'Socket' is -- closed after the actions have run. tcpTest :: (Socket -> IO a) -> (Socket -> IO b) -> IO () -tcpTest clientAct serverAct = - test clientSetup clientAct serverSetup server +tcpTest clientAct serverAct = do + portVar <- newEmptyMVar + test (clientSetup portVar) clientAct (serverSetup portVar) server where - clientSetup = do + clientSetup portVar = do sock <- socket AF_INET Stream defaultProtocol addr <- inet_addr serverAddr + serverPort <- readMVar portVar connect sock $ SockAddrInet serverPort addr return sock - serverSetup = do + serverSetup portVar = do sock <- socket AF_INET Stream defaultProtocol setSocketOption sock ReuseAddr 1 addr <- inet_addr serverAddr - bindSocket sock (SockAddrInet serverPort addr) + bindSocket sock (SockAddrInet aNY_PORT addr) listen sock 1 + serverPort <- socketPort sock + putMVar portVar serverPort return sock server sock = do @@ -169,17 +184,24 @@ -- | Create an unconnected 'Socket' for sending UDP and receiving -- datagrams and then run 'clientAct' and 'serverAct'. -udpTest :: (Socket -> IO a) -> (Socket -> IO b) -> IO () -udpTest clientAct serverAct = - test clientSetup clientAct serverSetup serverAct +udpTest :: (Socket -> PortNumber -> IO a) -> (Socket -> IO b) -> IO () +udpTest clientAct serverAct = do + portVar <- newEmptyMVar + test clientSetup (client portVar) (serverSetup portVar) serverAct where clientSetup = socket AF_INET Datagram defaultProtocol - serverSetup = do + client portVar sock = do + serverPort <- readMVar portVar + clientAct sock serverPort + + serverSetup portVar = do sock <- socket AF_INET Datagram defaultProtocol setSocketOption sock ReuseAddr 1 addr <- inet_addr serverAddr - bindSocket sock (SockAddrInet serverPort addr) + bindSocket sock (SockAddrInet aNY_PORT addr) + serverPort <- socketPort sock + putMVar portVar serverPort return sock -- | Run a client/server pair and synchronize them so that the server diff --git a/tests/uri001.hs b/tests/uri001.hs --- a/tests/uri001.hs +++ b/tests/uri001.hs @@ -56,6 +56,7 @@ import System.IO (openFile, IOMode(WriteMode), hClose) import qualified Test.Framework as TF import qualified Test.Framework.Providers.HUnit as TF +import qualified Test.Framework.Providers.QuickCheck2 as TF -- Test supplied string for valid URI reference syntax -- isValidURIRef :: String -> Bool @@ -1103,6 +1104,12 @@ "hello%C3%B8%C2%A9%E6%97%A5%E6%9C%AC" (escapeURIString isUnescapedInURIComponent "helloø©日本") +propEscapeUnEscapeLoop :: String -> Bool +propEscapeUnEscapeLoop s = s == (unEscapeString $! escaped) + where + escaped = escapeURIString (const False) s + {-# NOINLINE escaped #-} + testEscapeURIString = TF.testGroup "testEscapeURIString" [ TF.testCase "testEscapeURIString01" testEscapeURIString01 , TF.testCase "testEscapeURIString02" testEscapeURIString02 @@ -1110,6 +1117,7 @@ , TF.testCase "testEscapeURIString04" testEscapeURIString04 , TF.testCase "testEscapeURIString05" testEscapeURIString05 , TF.testCase "testEscapeURIString06" testEscapeURIString06 + , TF.testProperty "propEscapeUnEscapeLoop" propEscapeUnEscapeLoop ] -- URI string normalization tests