diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,21 +1,19 @@ -The Glasgow Haskell Compiler License - -Copyright 2002, The University Court of the University of Glasgow. -All rights reserved. +Copyright (c) 2002-2010, The University Court of the University of Glasgow. +Copyright (c) 2007-2010, Johan Tibell Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - + - Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - + - Neither name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without -specific prior written permission. +specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, diff --git a/Network/Socket.hsc b/Network/Socket.hsc --- a/Network/Socket.hsc +++ b/Network/Socket.hsc @@ -24,26 +24,9 @@ -- NOTE: ##, we want this interpreted when compiling the .hs, not by hsc2hs. ##include "Typeable.h" -#if defined(HAVE_WINSOCK_H) && !defined(cygwin32_HOST_OS) -#define WITH_WINSOCK 1 -#endif - -#if !defined(mingw32_HOST_OS) && !defined(_WIN32) -#define DOMAIN_SOCKET_SUPPORT 1 -#endif - -#if !defined(CALLCONV) -#ifdef WITH_WINSOCK -#define CALLCONV stdcall -#else -#define CALLCONV ccall -#endif -#endif - -- In order to process this file, you need to have CALLCONV defined. module Network.Socket ( - -- * Types Socket(..), -- instance Eq, Show Family(..), @@ -104,6 +87,8 @@ socketToHandle, -- :: Socket -> IOMode -> IO Handle + -- ** Sending and receiving data + -- $sendrecv sendTo, -- :: Socket -> String -> SockAddr -> IO Int sendBufTo, -- :: Socket -> Ptr a -> Int -> SockAddr -> IO Int @@ -640,6 +625,17 @@ foreign import ccall unsafe "free" c_free:: Ptr a -> IO () #endif + +----------------------------------------------------------------------------- +-- ** Sending and reciving data + +-- $sendrecv +-- +-- Do not use the @send@ and @recv@ functions defined in this module +-- in new code, as they incorrectly represent binary data as a Unicode +-- string. As a result, these functions are inefficient and may lead +-- to bugs in the program. Instead use the @send@ and @recv@ +-- functions defined in the 'Network.Socket.ByteString' module. ----------------------------------------------------------------------------- -- sendTo & recvFrom diff --git a/Network/Socket/ByteString.hsc b/Network/Socket/ByteString.hsc new file mode 100644 --- /dev/null +++ b/Network/Socket/ByteString.hsc @@ -0,0 +1,373 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface #-} + +#include "HsNet.h" + +-- | +-- Module : Network.Socket.ByteString +-- Copyright : (c) Johan Tibell 2007-2010 +-- License : BSD-style +-- +-- Maintainer : johan.tibell@gmail.com +-- Stability : stable +-- Portability : portable +-- +-- This module provides access to the BSD /socket/ interface. This +-- module is generally more efficient than the 'String' based network +-- functions in 'Network.Socket'. For detailed documentation, consult +-- your favorite POSIX socket reference. All functions communicate +-- failures by converting the error number to 'System.IO.IOError'. +-- +-- This module is made to be imported with 'Network.Socket' like so: +-- +-- > import Network.Socket hiding (send, sendTo, recv, recvFrom) +-- > import Network.Socket.ByteString +-- +module Network.Socket.ByteString + ( -- * Send data to a socket + send + , sendAll + , sendTo + , sendAllTo + + -- ** Vectored I/O + -- $vectored + , sendMany + , sendManyTo + + -- * Receive data from a socket + , recv + , recvFrom + + -- * Example + -- $example + ) where + +import Control.Monad (liftM, when) +import Data.ByteString (ByteString) +import Data.ByteString.Internal (createAndTrim) +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) +import Data.Word (Word8) +import Foreign.C.Types (CInt) +import Foreign.Marshal.Alloc (allocaBytes) +import Foreign.Ptr (Ptr, castPtr) +import Network.Socket (SockAddr, Socket(..), sendBufTo, recvBufFrom) + +import qualified Data.ByteString as B + +import Network.Socket.ByteString.Internal + +#if !defined(mingw32_HOST_OS) +import Control.Monad (zipWithM_) +import Foreign.C.Types (CChar, CSize) +import Foreign.Marshal.Array (allocaArray) +import Foreign.Marshal.Utils (with) +import Foreign.Ptr (plusPtr) +import Foreign.Storable (Storable(..)) +import Network.Socket.Internal (throwSocketErrorIfMinus1RetryMayBlock, + withSockAddr) + +import Network.Socket.ByteString.IOVec (IOVec(..)) +import Network.Socket.ByteString.MsgHdr (MsgHdr(..)) + +# if defined(__GLASGOW_HASKELL__) +import GHC.Conc (threadWaitRead, threadWaitWrite) +# endif +#else +# if defined(__GLASGOW_HASKELL__) +# if __GLASGOW_HASKELL__ >= 611 +import GHC.IO.FD +# else +import GHC.Handle (readRawBufferPtr, writeRawBufferPtr) +# endif +# endif +#endif + +#if !defined(mingw32_HOST_OS) +foreign import CALLCONV unsafe "send" + c_send :: CInt -> Ptr a -> CSize -> CInt -> IO CInt +foreign import CALLCONV unsafe "recv" + c_recv :: CInt -> Ptr CChar -> CSize -> CInt -> IO CInt +#endif + +-- ---------------------------------------------------------------------------- +-- Sending + +-- | Send data to the socket. The socket must be connected to a +-- remote socket. Returns the number of bytes sent. Applications are +-- responsible for ensuring that all data has been sent. +send :: Socket -- ^ Connected socket + -> ByteString -- ^ Data to send + -> IO Int -- ^ Number of bytes sent +send (MkSocket s _ _ _ _) xs = + unsafeUseAsCStringLen xs $ \(str, len) -> + liftM fromIntegral $ +#if defined(__GLASGOW_HASKELL__) && defined(mingw32_HOST_OS) +# if __GLASGOW_HASKELL__ >= 611 + writeRawBufferPtr "Network.Socket.ByteString.send" + (FD s 1) (castPtr str) 0 (fromIntegral len) +# else + writeRawBufferPtr "Network.Socket.ByteString.send" + (fromIntegral s) True str 0 (fromIntegral len) +# endif +#else +# if !defined(__HUGS__) + throwSocketErrorIfMinus1RetryMayBlock "send" + (threadWaitWrite (fromIntegral s)) $ +# endif + c_send s str (fromIntegral len) 0 +#endif + +-- | Send data to the socket. The socket must be connected to a +-- remote socket. Unlike 'send', this function continues to send data +-- until either all data has been sent or an error occurs. On error, +-- an exception is raised, and there is no way to determine how much +-- data, if any, was successfully sent. +sendAll :: Socket -- ^ Connected socket + -> ByteString -- ^ Data to send + -> IO () +sendAll sock bs = do + sent <- send sock bs + when (sent < B.length bs) $ sendAll sock (B.drop sent bs) + +-- | Send data to the socket. The recipient can be specified +-- explicitly, so the socket need not be in a connected state. +-- Returns the number of bytes sent. Applications are responsible for +-- ensuring that all data has been sent. +sendTo :: Socket -- ^ Socket + -> ByteString -- ^ Data to send + -> SockAddr -- ^ Recipient address + -> IO Int -- ^ Number of bytes sent +sendTo sock xs addr = + unsafeUseAsCStringLen xs $ \(str, len) -> sendBufTo sock str len addr + +-- | Send data to the socket. The recipient can be specified +-- explicitly, so the socket need not be in a connected state. Unlike +-- 'sendTo', this function continues to send data until either all +-- data has been sent or an error occurs. On error, an exception is +-- raised, and there is no way to determine how much data, if any, was +-- successfully sent. +sendAllTo :: Socket -- ^ Socket + -> ByteString -- ^ Data to send + -> SockAddr -- ^ Recipient address + -> IO () +sendAllTo sock xs addr = do + sent <- sendTo sock xs addr + when (sent < B.length xs) $ sendAllTo sock (B.drop sent xs) addr + +-- ---------------------------------------------------------------------------- +-- ** Vectored I/O + +-- $vectored +-- +-- Vectored I\/O, also known as scatter\/gather I\/O, allows multiple +-- data segments to be sent using a single system call, without first +-- concatenating the segments. For example, given a list of +-- @ByteString@s, @xs@, +-- +-- > sendMany sock xs +-- +-- is equivalent to +-- +-- > sendAll sock (concat xs) +-- +-- but potentially more efficient. +-- +-- Vectored I\/O are often useful when implementing network protocols +-- that, for example, group data into segments consisting of one or +-- more fixed-length headers followed by a variable-length body. + +-- | Send data to the socket. The socket must be in a connected +-- state. The data is sent as if the parts have been concatenated. +-- This function continues to send data until either all data has been +-- sent or an error occurs. On error, an exception is raised, and +-- there is no way to determine how much data, if any, was +-- successfully sent. +sendMany :: Socket -- ^ Connected socket + -> [ByteString] -- ^ Data to send + -> IO () +#if !defined(mingw32_HOST_OS) +sendMany sock@(MkSocket fd _ _ _ _) cs = do + sent <- sendManyInner + when (sent < totalLength cs) $ sendMany sock (remainingChunks sent cs) + where + sendManyInner = + liftM fromIntegral . withIOVec cs $ \(iovsPtr, iovsLen) -> + throwSocketErrorIfMinus1RetryMayBlock "writev" + (threadWaitWrite (fromIntegral fd)) $ + c_writev (fromIntegral fd) iovsPtr (fromIntegral iovsLen) +#else +sendMany sock = sendAll sock . B.concat +#endif + +-- | Send data to the socket. The recipient can be specified +-- explicitly, so the socket need not be in a connected state. The +-- data is sent as if the parts have been concatenated. This function +-- continues to send data until either all data has been sent or an +-- error occurs. On error, an exception is raised, and there is no +-- way to determine how much data, if any, was successfully sent. +sendManyTo :: Socket -- ^ Socket + -> [ByteString] -- ^ Data to send + -> SockAddr -- ^ Recipient address + -> IO () +#if !defined(mingw32_HOST_OS) +sendManyTo sock@(MkSocket fd _ _ _ _) cs addr = do + sent <- liftM fromIntegral sendManyToInner + when (sent < totalLength cs) $ sendManyTo sock (remainingChunks sent cs) addr + where + sendManyToInner = + withSockAddr addr $ \addrPtr addrSize -> + withIOVec cs $ \(iovsPtr, iovsLen) -> do + let msgHdr = MsgHdr + addrPtr (fromIntegral addrSize) + iovsPtr (fromIntegral iovsLen) + with msgHdr $ \msgHdrPtr -> + throwSocketErrorIfMinus1RetryMayBlock "sendmsg" + (threadWaitWrite (fromIntegral fd)) $ + c_sendmsg (fromIntegral fd) msgHdrPtr 0 +#else +sendManyTo sock cs = sendAllTo sock (B.concat cs) +#endif + +-- ---------------------------------------------------------------------------- +-- Receiving + +-- | Receive data from the socket. The socket must be in a connected +-- state. This function may return fewer bytes than specified. If +-- the message is longer than the specified length, it may be +-- discarded depending on the type of socket. This function may block +-- until a message arrives. +-- +-- Considering hardware and network realities, the maximum number of bytes to +-- receive should be a small power of 2, e.g., 4096. +-- +-- For TCP sockets, a zero length return value means the peer has +-- closed its half side of the connection. +recv :: Socket -- ^ Connected socket + -> Int -- ^ Maximum number of bytes to receive + -> IO ByteString -- ^ Data received +recv (MkSocket s _ _ _ _) nbytes + | nbytes < 0 = ioError (mkInvalidRecvArgError "Network.Socket.ByteString.recv") + | otherwise = createAndTrim nbytes $ recvInner s nbytes + +recvInner :: CInt -> Int -> Ptr Word8 -> IO Int +recvInner s nbytes ptr = + fmap fromIntegral $ +#if defined(__GLASGOW_HASKELL__) && defined(mingw32_HOST_OS) +# if __GLASGOW_HASKELL__ >= 611 + readRawBufferPtr "Network.Socket.ByteString.recv" (FD s 1) ptr 0 (fromIntegral nbytes) +# else + readRawBufferPtr "Network.Socket.ByteString.recv" (fromIntegral s) + True (castPtr ptr) 0 (fromIntegral nbytes) +# endif +#else +# if !defined(__HUGS__) + throwSocketErrorIfMinus1RetryMayBlock "recv" + (threadWaitRead (fromIntegral s)) $ +# endif + c_recv s (castPtr ptr) (fromIntegral nbytes) 0 +#endif + +-- | Receive data from the socket. The socket need not be in a +-- connected state. Returns @(bytes, address)@ where @bytes@ is a +-- 'ByteString' representing the data received and @address@ is a +-- 'SockAddr' representing the address of the sending socket. +recvFrom :: Socket -- ^ Socket + -> Int -- ^ Maximum number of bytes to receive + -> IO (ByteString, SockAddr) -- ^ Data received and sender address +recvFrom sock nbytes = + allocaBytes nbytes $ \ptr -> do + (len, sockaddr) <- recvBufFrom sock ptr nbytes + str <- B.packCStringLen (ptr, len) + return (str, sockaddr) + +-- ---------------------------------------------------------------------------- +-- Not exported + +#if !defined(mingw32_HOST_OS) +-- | Suppose we try to transmit a list of chunks @cs@ via a gathering write +-- operation and find that @n@ bytes were sent. Then @remainingChunks n cs@ is +-- list of chunks remaining to be sent. +remainingChunks :: Int -> [ByteString] -> [ByteString] +remainingChunks _ [] = [] +remainingChunks i (x:xs) + | i < len = B.drop i x : xs + | otherwise = let i' = i - len in i' `seq` remainingChunks i' xs + where + len = B.length x + +-- | @totalLength cs@ is the sum of the lengths of the chunks in the list @cs@. +totalLength :: [ByteString] -> Int +totalLength = sum . map B.length + +-- | @withIOVec cs f@ executes the computation @f@, passing as argument a pair +-- consisting of a pointer to a temporarily allocated array of pointers to +-- 'IOVec' made from @cs@ and the number of pointers (@length cs@). +-- /Unix only/. +withIOVec :: [ByteString] -> ((Ptr IOVec, Int) -> IO a) -> IO a +withIOVec cs f = + allocaArray csLen $ \aPtr -> do + zipWithM_ pokeIov (ptrs aPtr) cs + f (aPtr, csLen) + where + csLen = length cs + ptrs = iterate (`plusPtr` sizeOf (undefined :: IOVec)) + pokeIov ptr s = + unsafeUseAsCStringLen s $ \(sPtr, sLen) -> + poke ptr $ IOVec sPtr (fromIntegral sLen) +#endif + +-- --------------------------------------------------------------------- +-- Example + +-- $example +-- +-- Here are two minimal example programs using the TCP/IP protocol: a +-- server that echoes all data that it receives back (servicing only +-- one client) and a client using it. +-- +-- > -- Echo server program +-- > module Main where +-- > +-- > import Control.Monad (unless) +-- > import Network.Socket hiding (recv) +-- > import qualified Data.ByteString as S +-- > import Network.Socket.ByteString (recv, sendAll) +-- > +-- > main :: IO () +-- > main = withSocketsDo $ +-- > do addrinfos <- getAddrInfo +-- > (Just (defaultHints {addrFlags = [AI_PASSIVE]})) +-- > Nothing (Just "3000") +-- > let serveraddr = head addrinfos +-- > sock <- socket (addrFamily serveraddr) Stream defaultProtocol +-- > bindSocket sock (addrAddress serveraddr) +-- > listen sock 1 +-- > (conn, _) <- accept sock +-- > talk conn +-- > sClose conn +-- > sClose sock +-- > +-- > where +-- > talk :: Socket -> IO () +-- > talk conn = +-- > do msg <- recv conn 1024 +-- > unless (S.null msg) $ sendAll conn msg >> talk conn +-- +-- > -- Echo client program +-- > module Main where +-- > +-- > import Network.Socket hiding (recv) +-- > import Network.Socket.ByteString (recv, sendAll) +-- > import qualified Data.ByteString.Char8 as C +-- > +-- > main :: IO () +-- > main = withSocketsDo $ +-- > do addrinfos <- getAddrInfo Nothing (Just "") (Just "3000") +-- > let serveraddr = head addrinfos +-- > sock <- socket (addrFamily serveraddr) Stream defaultProtocol +-- > connect sock (addrAddress serveraddr) +-- > sendAll sock $ C.pack "Hello, world!" +-- > msg <- recv sock 1024 +-- > sClose sock +-- > putStr "Received " +-- > C.putStrLn msg diff --git a/Network/Socket/ByteString/IOVec.hsc b/Network/Socket/ByteString/IOVec.hsc new file mode 100644 --- /dev/null +++ b/Network/Socket/ByteString/IOVec.hsc @@ -0,0 +1,28 @@ +-- | Support module for the POSIX writev system call. +module Network.Socket.ByteString.IOVec + ( IOVec(..) + ) where + +import Foreign.C.Types (CChar, CInt, CSize) +import Foreign.Ptr (Ptr) +import Foreign.Storable (Storable(..)) + +#include + +data IOVec = IOVec + { iovBase :: Ptr CChar + , iovLen :: CSize + } + +instance Storable IOVec where + sizeOf _ = (#const sizeof(struct iovec)) + alignment _ = alignment (undefined :: CInt) + + peek p = do + base <- (#peek struct iovec, iov_base) p + len <- (#peek struct iovec, iov_len) p + return $ IOVec base len + + poke p iov = do + (#poke struct iovec, iov_base) p (iovBase iov) + (#poke struct iovec, iov_len) p (iovLen iov) diff --git a/Network/Socket/ByteString/Internal.hs b/Network/Socket/ByteString/Internal.hs new file mode 100644 --- /dev/null +++ b/Network/Socket/ByteString/Internal.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface #-} + +-- | +-- Module : Network.Socket.ByteString.Internal +-- Copyright : (c) Johan Tibell 2007-2010 +-- License : BSD-style +-- +-- Maintainer : johan.tibell@gmail.com +-- Stability : stable +-- Portability : portable +-- +module Network.Socket.ByteString.Internal + ( mkInvalidRecvArgError +#if !defined(mingw32_HOST_OS) + , c_writev + , c_sendmsg +#endif + ) where + +import System.IO.Error (ioeSetErrorString, mkIOError) + +#if !defined(mingw32_HOST_OS) +import Foreign.C.Types (CInt) +import Foreign.Ptr (Ptr) +import System.Posix.Types (CSsize) + +import Network.Socket.ByteString.IOVec (IOVec) +import Network.Socket.ByteString.MsgHdr (MsgHdr) +#endif + +#ifdef __GLASGOW_HASKELL__ +# if __GLASGOW_HASKELL__ < 611 +import GHC.IOBase (IOErrorType(..)) +# else +import GHC.IO.Exception (IOErrorType(..)) +# endif +#elif __HUGS__ +import Hugs.Prelude (IOErrorType(..)) +#endif + +mkInvalidRecvArgError :: String -> IOError +mkInvalidRecvArgError loc = ioeSetErrorString (mkIOError +#ifdef __GLASGOW_HASKELL__ + InvalidArgument +#else + IllegalOperation +#endif + loc Nothing Nothing) "non-positive length" + +#if !defined(mingw32_HOST_OS) +foreign import ccall unsafe "writev" + c_writev :: CInt -> Ptr IOVec -> CInt -> IO CSsize + +foreign import ccall unsafe "sendmsg" + c_sendmsg :: CInt -> Ptr MsgHdr -> CInt -> IO CSsize +#endif diff --git a/Network/Socket/ByteString/Lazy.hsc b/Network/Socket/ByteString/Lazy.hsc new file mode 100644 --- /dev/null +++ b/Network/Socket/ByteString/Lazy.hsc @@ -0,0 +1,153 @@ +{-# LANGUAGE BangPatterns, CPP, ForeignFunctionInterface #-} + +-- | +-- Module : Network.Socket.ByteString.Lazy +-- Copyright : (c) Bryan O'Sullivan 2009 +-- License : BSD-style +-- +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : POSIX, GHC +-- +-- This module provides access to the BSD /socket/ interface. This +-- module is generally more efficient than the 'String' based network +-- functions in 'Network.Socket'. For detailed documentation, consult +-- your favorite POSIX socket reference. All functions communicate +-- failures by converting the error number to 'System.IO.IOError'. +-- +-- This module is made to be imported with 'Network.Socket' like so: +-- +-- > import Network.Socket hiding (send, sendTo, recv, recvFrom) +-- > import Network.Socket.ByteString.Lazy +-- > import Prelude hiding (getContents) +-- +module Network.Socket.ByteString.Lazy + ( +#if !defined(mingw32_HOST_OS) + -- * Send data to a socket + send, + sendAll, +#endif + + -- * Receive data from a socket + getContents, + recv + ) where + +import Control.Monad (liftM) +import Data.ByteString.Lazy.Internal (ByteString(..), defaultChunkSize) +import Data.Int (Int64) +import Network.Socket (Socket(..), ShutdownCmd(..), shutdown) +import Prelude hiding (getContents) +import System.IO.Unsafe (unsafeInterleaveIO) + +import qualified Data.ByteString as S +import qualified Network.Socket.ByteString as N + +#if !defined(mingw32_HOST_OS) +import Control.Monad (unless) +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) +import Foreign.Marshal.Array (allocaArray) +import Foreign.Ptr (plusPtr) +import Foreign.Storable (Storable(..)) +import Network.Socket.ByteString.IOVec (IOVec(IOVec)) +import Network.Socket.ByteString.Internal (c_writev) +import Network.Socket.Internal (throwSocketErrorIfMinus1RetryMayBlock) + +import qualified Data.ByteString.Lazy as L + +# if defined(__GLASGOW_HASKELL__) +import GHC.Conc (threadWaitWrite) +# endif +#endif + +#if !defined(mingw32_HOST_OS) +-- ----------------------------------------------------------------------------- +-- Sending + +-- | Send data to the socket. The socket must be in a connected state. +-- Returns the number of bytes sent. Applications are responsible for +-- ensuring that all data has been sent. +-- +-- Because a lazily generated 'ByteString' may be arbitrarily long, +-- this function caps the amount it will attempt to send at 4MB. This +-- number is large (so it should not penalize performance on fast +-- networks), but not outrageously so (to avoid demanding lazily +-- computed data unnecessarily early). Before being sent, the lazy +-- 'ByteString' will be converted to a list of strict 'ByteString's +-- with 'L.toChunks'; at most 1024 chunks will be sent. /Unix only/. +send :: Socket -- ^ Connected socket + -> ByteString -- ^ Data to send + -> IO Int64 -- ^ Number of bytes sent +send (MkSocket fd _ _ _ _) s = do + let cs = take maxNumChunks (L.toChunks s) + len = length cs + liftM fromIntegral . allocaArray len $ \ptr -> + withPokes cs ptr $ \niovs -> +# if !defined(__HUGS__) + throwSocketErrorIfMinus1RetryMayBlock "writev" + (threadWaitWrite (fromIntegral fd)) $ +# endif + c_writev (fromIntegral fd) ptr niovs + where + withPokes ss p f = loop ss p 0 0 + where loop (c:cs) q k !niovs + | k < maxNumBytes = + unsafeUseAsCStringLen c $ \(ptr,len) -> do + poke q $ IOVec ptr (fromIntegral len) + loop cs (q `plusPtr` sizeOf (undefined :: IOVec)) + (k + fromIntegral len) (niovs + 1) + | otherwise = f niovs + loop _ _ _ niovs = f niovs + maxNumBytes = 4194304 :: Int -- maximum number of bytes to transmit in one system call + maxNumChunks = 1024 :: Int -- maximum number of chunks to transmit in one system call + +-- | Send data to the socket. The socket must be in a connected +-- state. This function continues to send data until either all data +-- has been sent or an error occurs. If there is an error, an +-- exception is raised, and there is no way to determine how much data +-- was sent. /Unix only/. +sendAll :: Socket -- ^ Connected socket + -> ByteString -- ^ Data to send + -> IO () +sendAll sock bs = do + sent <- send sock bs + let bs' = L.drop sent bs + unless (L.null bs') $ sendAll sock bs' +#endif + +-- ----------------------------------------------------------------------------- +-- Receiving + +-- | Receive data from the socket. The socket must be in a connected +-- state. Data is received on demand, in chunks; each chunk will be +-- sized to reflect the amount of data received by individual 'recv' +-- calls. +-- +-- All remaining data from the socket is consumed. When there is no +-- more data to be received, the receiving side of the socket is shut +-- down. If there is an error and an exception is thrown, the socket +-- is not shut down. +getContents :: Socket -- ^ Connected socket + -> IO ByteString -- ^ Data received +getContents sock = loop where + loop = unsafeInterleaveIO $ do + s <- N.recv sock defaultChunkSize + if S.null s + then shutdown sock ShutdownReceive >> return Empty + else Chunk s `liftM` loop + +-- | Receive data from the socket. The socket must be in a connected +-- state. This function may return fewer bytes than specified. If +-- the received data is longer than the specified length, it may be +-- discarded depending on the type of socket. This function may block +-- until a message arrives. +-- +-- If there is no more data to be received, returns an empty 'ByteString'. +recv :: Socket -- ^ Connected socket + -> Int64 -- ^ Maximum number of bytes to receive + -> IO ByteString -- ^ Data received +recv sock nbytes = chunk `liftM` N.recv sock (fromIntegral nbytes) where + chunk k + | S.null k = Empty + | otherwise = Chunk k Empty diff --git a/Network/Socket/ByteString/MsgHdr.hsc b/Network/Socket/ByteString/MsgHdr.hsc new file mode 100644 --- /dev/null +++ b/Network/Socket/ByteString/MsgHdr.hsc @@ -0,0 +1,42 @@ +{-# LANGUAGE CPP #-} + +-- | Support module for the POSIX 'sendmsg' system call. +module Network.Socket.ByteString.MsgHdr + ( MsgHdr(..) + ) where + +#include +#include + +import Foreign.C.Types (CInt, CSize) +import Foreign.Ptr (Ptr) +import Foreign.Storable (Storable(..)) +import Network.Socket (SockAddr) + +import Network.Socket.ByteString.IOVec (IOVec) + +-- We don't use msg_control, msg_controllen, and msg_flags as these +-- don't exist on OpenSolaris. +data MsgHdr = MsgHdr + { msgName :: Ptr SockAddr + , msgNameLen :: CSize + , msgIov :: Ptr IOVec + , msgIovLen :: CSize + } + +instance Storable MsgHdr where + sizeOf _ = (#const sizeof(struct msghdr)) + alignment _ = alignment (undefined :: CInt) + + peek p = do + name <- (#peek struct msghdr, msg_name) p + nameLen <- (#peek struct msghdr, msg_namelen) p + iov <- (#peek struct msghdr, msg_iov) p + iovLen <- (#peek struct msghdr, msg_iovlen) p + return $ MsgHdr name nameLen iov iovLen + + poke p mh = do + (#poke struct msghdr, msg_name) p (msgName mh) + (#poke struct msghdr, msg_namelen) p (msgNameLen mh) + (#poke struct msghdr, msg_iov) p (msgIov mh) + (#poke struct msghdr, msg_iovlen) p (msgIovLen mh) diff --git a/Network/Socket/Internal.hsc b/Network/Socket/Internal.hsc --- a/Network/Socket/Internal.hsc +++ b/Network/Socket/Internal.hsc @@ -18,22 +18,6 @@ #include "HsNet.h" -#if defined(HAVE_WINSOCK2_H) && !defined(cygwin32_HOST_OS) -#define WITH_WINSOCK 1 -#endif - -#if !defined(mingw32_HOST_OS) && !defined(_WIN32) -#define DOMAIN_SOCKET_SUPPORT 1 -#endif - -#if !defined(CALLCONV) -#ifdef WITH_WINSOCK -#define CALLCONV stdcall -#else -#define CALLCONV ccall -#endif -#endif - module Network.Socket.Internal ( -- * Socket addresses diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,4 @@ +To build this package using Cabal directly from git, you must run +"autoreconf" before the usual Cabal build steps (configure/build/install). +autoreconf is included in the GNU autoconf tools. There is no need to run +the "configure" script: the "setup configure" step will do this for you. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,6 +1,17 @@ module Main (main) where -import Distribution.Simple +import Control.Monad (unless) +import Distribution.Simple (defaultMainWithHooks, runTests, simpleUserHooks) +import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..)) +import Distribution.Simple.Utils (die) +import System.Cmd (system) +import System.Directory (doesDirectoryExist) main :: IO () -main = defaultMainWithHooks defaultUserHooks +main = defaultMainWithHooks $ simpleUserHooks { runTests = runTests' } + where + runTests' _ _ _ lbi = do + built <- doesDirectoryExist $ buildDir lbi + unless built $ die "Run the 'build' command first." + system "runhaskell -i./dist/build tests/Simple.hs" + return () diff --git a/examples/EchoClient.hs b/examples/EchoClient.hs new file mode 100644 --- /dev/null +++ b/examples/EchoClient.hs @@ -0,0 +1,18 @@ +-- Echo client program +module Main where + +import Network.Socket hiding (recv) +import Network.Socket.ByteString (recv, sendAll) +import qualified Data.ByteString.Char8 as C + +main :: IO () +main = withSocketsDo $ + do addrinfos <- getAddrInfo Nothing (Just "") (Just "3000") + let serveraddr = head addrinfos + sock <- socket (addrFamily serveraddr) Stream defaultProtocol + connect sock (addrAddress serveraddr) + sendAll sock $ C.pack "Hello, world!" + msg <- recv sock 1024 + sClose sock + putStr "Received " + C.putStrLn msg diff --git a/examples/EchoServer.hs b/examples/EchoServer.hs new file mode 100644 --- /dev/null +++ b/examples/EchoServer.hs @@ -0,0 +1,27 @@ +-- Echo server program +module Main where + +import Control.Monad (unless) +import Network.Socket hiding (recv) +import qualified Data.ByteString as S +import Network.Socket.ByteString (recv, sendAll) + +main :: IO () +main = withSocketsDo $ + do addrinfos <- getAddrInfo + (Just (defaultHints {addrFlags = [AI_PASSIVE]})) + Nothing (Just "3000") + let serveraddr = head addrinfos + sock <- socket (addrFamily serveraddr) Stream defaultProtocol + bindSocket sock (addrAddress serveraddr) + listen sock 1 + (conn, _) <- accept sock + talk conn + sClose conn + sClose sock + + where + talk :: Socket -> IO () + talk conn = + do msg <- recv conn 1024 + unless (S.null msg) $ sendAll conn msg >> talk conn diff --git a/include/HsNet.h b/include/HsNet.h --- a/include/HsNet.h +++ b/include/HsNet.h @@ -174,4 +174,20 @@ } #endif +#if defined(HAVE_WINSOCK_H) && !defined(cygwin32_HOST_OS) +# define WITH_WINSOCK 1 #endif + +#if !defined(mingw32_HOST_OS) && !defined(_WIN32) +# define DOMAIN_SOCKET_SUPPORT 1 +#endif + +#if !defined(CALLCONV) +# if defined(WITH_WINSOCK) +# define CALLCONV stdcall +# else +# define CALLCONV ccall +# endif +#endif + +#endif /* HSNET_H */ diff --git a/network.cabal b/network.cabal --- a/network.cabal +++ b/network.cabal @@ -1,46 +1,66 @@ name: network -version: 2.2.1.10 +version: 2.2.3 license: BSD3 license-file: LICENSE maintainer: Johan Tibell -synopsis: Networking-related facilities +synopsis: Low-level networking interface +description: Low-level networking interface category: Network build-type: Configure cabal-version: >=1.6 extra-tmp-files: - config.log config.status autom4te.cache - network.buildinfo include/HsNetworkConfig.h + config.log config.status autom4te.cache network.buildinfo + include/HsNetworkConfig.h extra-source-files: - config.guess config.sub install-sh - configure.ac configure - network.buildinfo.in include/HsNetworkConfig.h.in - include/HsNet.h include/Typeable.h - -- C sources only used on some systems - cbits/ancilData.c - cbits/asyncAccept.c cbits/initWinSock.c cbits/winSockErr.c + README examples/*.hs tests/*.hs config.guess config.sub install-sh + configure.ac configure network.buildinfo.in + include/HsNetworkConfig.h.in include/HsNet.h include/Typeable.h + -- C sources only used on some systems + cbits/ancilData.c cbits/asyncAccept.c cbits/initWinSock.c + cbits/winSockErr.c +homepage: http://github.com/haskell/network bug-reports: http://trac.haskell.org/network/ flag base4 library exposed-modules: - Network Network.BSD Network.Socket.Internal Network.Socket - Network.URI - build-depends: base < 5, parsec + Network + Network.BSD + Network.Socket + Network.Socket.ByteString + Network.Socket.ByteString.Lazy + Network.Socket.Internal + Network.URI + other-modules: + Network.Socket.ByteString.Internal + if !os(windows) + other-modules: + Network.Socket.ByteString.IOVec + Network.Socket.ByteString.MsgHdr + + build-depends: + base < 5, + bytestring < 1.0, + parsec + + if !os(windows) + build-depends: + unix >= 2 && < 3 + if flag(base4) - build-depends: base >= 4 && < 4.4 - cpp-options: -DBASE4 + build-depends: base >= 4 && < 4.4 + cpp-options: -DBASE4 else - build-depends: base<4 + build-depends: base<4 - extensions: CPP, DeriveDataTypeable, ForeignFunctionInterface, - TypeSynonymInstances - include-dirs: include - includes: HsNet.h - install-includes: - HsNet.h HsNetworkConfig.h - c-sources: cbits/HsNet.c + extensions: + CPP, DeriveDataTypeable, ForeignFunctionInterface, TypeSynonymInstances + include-dirs: include + includes: HsNet.h + install-includes: HsNet.h HsNetworkConfig.h + c-sources: cbits/HsNet.c source-repository head type: git diff --git a/tests/Simple.hs b/tests/Simple.hs new file mode 100644 --- /dev/null +++ b/tests/Simple.hs @@ -0,0 +1,141 @@ +module Main where + +import Control.Concurrent (forkIO) +import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) +import Control.Exception (bracket) +import Control.Monad (when) +import Network.Socket hiding (recv, recvFrom, send) +import System.Exit (exitFailure) +import Test.HUnit (Counts(..), Test(..), (@=?), runTestTT) + +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as C +import qualified Data.ByteString.Lazy.Char8 as L + +import Network.Socket.ByteString (recv, recvFrom, send, sendAll, sendMany) +import qualified Network.Socket.ByteString.Lazy as NSBL + +------------------------------------------------------------------------ + +port :: PortNumber +port = fromIntegral (3000 :: Int) + +testMsg :: S.ByteString +testMsg = C.pack "This is a test message." + +testLazySend :: Test +testLazySend = TestCase $ connectedTest client server + where + server sock = recv sock 1024 >>= (@=?) (C.take 1024 strictTestMsg) + client sock = NSBL.send sock lazyTestMsg >>= (@=?) 1024 + + -- message containing too many chunks to be sent in one system call + lazyTestMsg = let alphabet = map C.singleton ['a'..'z'] + in L.fromChunks (concat (replicate 100 alphabet)) + + strictTestMsg = C.concat . L.toChunks $ lazyTestMsg + +------------------------------------------------------------------------ +-- Tests + +testSendAll :: Test +testSendAll = TestCase $ connectedTest client server + where + server sock = recv sock 1024 >>= (@=?) testMsg + client sock = sendAll sock testMsg + +testSendMany :: Test +testSendMany = TestCase $ connectedTest client server + 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." + +testRecv :: Test +testRecv = TestCase $ connectedTest client server + where + server sock = recv sock 1024 >>= (@=?) testMsg + client sock = send sock testMsg + +testOverFlowRecv :: Test +testOverFlowRecv = TestCase $ connectedTest 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 + + client sock = send sock testMsg + +testRecvFrom :: Test +testRecvFrom = TestCase $ connectedTest client server + where + server sock = do (msg, _) <- recvFrom sock 1024 + testMsg @=? msg + + client sock = send sock testMsg + +testOverFlowRecvFrom :: Test +testOverFlowRecvFrom = TestCase $ connectedTest 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 + + client sock = send sock testMsg + +------------------------------------------------------------------------ +-- Test helpers + +-- | Run a client/server pair and synchronize them so that the server +-- is started before the client and the specified server action is +-- finished before the client closes the connection. +connectedTest :: (Socket -> IO a) -> (Socket -> IO b) -> IO () +connectedTest clientAct serverAct = do + barrier <- newEmptyMVar + forkIO $ server barrier + client barrier + where + server barrier = do + addr <- inet_addr "127.0.0.1" + bracket (socket AF_INET Stream defaultProtocol) sClose $ \sock -> do + setSocketOption sock ReuseAddr 1 + bindSocket sock (SockAddrInet port addr) + listen sock 1 + serverReady + (clientSock, _) <- accept sock + serverAct clientSock + sClose clientSock + putMVar barrier () + where + -- | Signal to the client that it can proceed. + serverReady = putMVar barrier () + + client barrier = do + takeMVar barrier + bracket (socket AF_INET Stream defaultProtocol) sClose $ \sock -> do + addr <- inet_addr "127.0.0.1" + connect sock $ SockAddrInet port addr + clientAct sock + takeMVar barrier + +------------------------------------------------------------------------ +-- Test harness + +main :: IO () +main = withSocketsDo $ do + counts <- runTestTT tests + when (errors counts + failures counts > 0) exitFailure + +tests :: Test +tests = TestList [ TestLabel "testLazySend" testLazySend + , TestLabel "testSendAll" testSendMany + , TestLabel "testSendMany" testSendMany + , TestLabel "testRecv" testRecv + , TestLabel "testOverFlowRecv" testOverFlowRecv + , TestLabel "testRecvFrom" testRecvFrom + , TestLabel "testOverFlowRecvFrom" testOverFlowRecvFrom + ] diff --git a/tests/net001.hs b/tests/net001.hs new file mode 100644 --- /dev/null +++ b/tests/net001.hs @@ -0,0 +1,27 @@ +module Main where + +import Network +import Control.Concurrent +import System.IO + +-- NOTE: this test depends on non-blocking I/O support, +-- which win32 doesn't support. Rather than having the +-- test program block, we fail to initialise WinSock +-- (via withSocketsDo) here so that the test will fall over +-- (and repeatedly remind us to implement Win32 support +-- for non-blocking I/O !) + +main = {- withSocketsDo $ -} do + forkIO server + threadDelay 1000000 + h <- connectTo "localhost" (PortNumber 22222) + l <- hGetLine h + hClose h + print l + where + server = do + s <- listenOn (PortNumber 22222) + (h, host, port) <- accept s + hPutStrLn h "hello" + hClose h + diff --git a/tests/net002.hs b/tests/net002.hs new file mode 100644 --- /dev/null +++ b/tests/net002.hs @@ -0,0 +1,133 @@ +-- $Id: net002.hs,v 1.5 2005/01/17 09:57:24 simonmar Exp $ +-- http://www.bagley.org/~doug/shootout/ +-- Haskell echo/client server +-- written by Brian Gregor +-- compile with: +-- ghc -O -o echo -package net -package concurrent -package lang echo.hs + +-- !!! exposed a bug in 5.02.2's network library, accept wasn't setting the +-- socket it returned to non-blocking mode. + +-- NOTE: this test depends on non-blocking I/O support, +-- which win32 doesn't support. Rather than having the +-- test program block, we fail to initialise WinSock +-- (via withSocketsDo) here so that the test will fall over +-- (and repeatedly remind us to implement Win32 support +-- for non-blocking I/O !) + +module Main where + +import Network.Socket + +import Prelude hiding (putStr) +import System.IO hiding (putStr) +import qualified System.IO +import System.IO.Error +import Control.Concurrent +import System.Environment ( getArgs ) +import System.Exit ( exitFailure ) +import Control.Exception ( finally ) + +server_sock :: IO (Socket) +server_sock = do + s <- socket AF_INET Stream 6 + setSocketOption s ReuseAddr 1 + -- bindSocket s (SockAddrInet (mkPortNumber portnum) iNADDR_ANY) + bindSocket s (SockAddrInet (PortNum portnum) iNADDR_ANY) + listen s 2 + return s + +eofAsEmptyHandler :: IOError -> IO String +eofAsEmptyHandler e + | isEOFError e = return "" + | otherwise = ioError e + +-- For debugging, enable the putStr below. Turn it off to get deterministic +-- results: on a multiprocessor we can't predict the order of the messages. +putStr = const (return ()) +-- putStr = System.IO.putStr + +echo_server s = do + (s', clientAddr) <- accept s + proc <- read_data s' 0 + putStrLn ("server processed "++(show proc)++" bytes") + sClose s' + where + read_data sock totalbytes = do + -- (str,i) <- readSocket sock 19 + str <- recv sock 19 `catch` eofAsEmptyHandler + -- if (i >= 19) + putStr ("Server recv: " ++ str) + if ((length str) >= 19) + then do + putStr ("Server read: " ++ str) + -- writ <- writeSocket sock str + writ <- send sock str + putStr ("Server wrote: " ++ str) + -- + read_data sock $! (totalbytes+(length $! str)) + -- read_data sock (totalbytes+(length str)) + else do + putStr ("server read: " ++ str) + return totalbytes + +local = "127.0.0.1" +message = "Hello there sailor\n" +portnum = 7001 + +client_sock = do + s <- socket AF_INET Stream 6 + ia <- inet_addr local + -- connect s (SockAddrInet (mkPortNumber portnum) ia) + connect s (SockAddrInet (PortNum portnum) ia) + return s + +echo_client n = do + s <- client_sock + drop <- server_echo s n + sClose s + where + server_echo sock n = if n > 0 + then do + -- writeSocket sock message + send sock message + putStr ("Client wrote: " ++ message) + -- + -- (str,i) <- readSocket sock 19 + str <- recv sock 19 `catch` eofAsEmptyHandler + if (str /= message) + then do + putStr ("Client read error: " ++ str ++ "\n") + exitFailure + else do + putStr ("Client read success") + server_echo sock (n-1) + else do + putStr "Client read nil\n" + return [] + +main = {- withSocketsDo $ -} do + ~[n] <- getArgs + -- server & client semaphores + -- get the server socket + ssock <- server_sock + -- fork off the server + s <- myForkIO (echo_server ssock) + -- fork off the client + c <- myForkIO (echo_client (read n::Int)) + -- let 'em run until they've signaled they're done + join s + System.IO.putStr "join s\n" + join c + System.IO.putStr "join c\n" + +-- these are used to make the main thread wait until +-- the child threads have exited +myForkIO :: IO () -> IO (MVar ()) +myForkIO io = do + mvar <- newEmptyMVar + forkIO (io `finally` putMVar mvar ()) + return mvar + +join :: MVar () -> IO () +join mvar = readMVar mvar diff --git a/tests/uri001.hs b/tests/uri001.hs new file mode 100644 --- /dev/null +++ b/tests/uri001.hs @@ -0,0 +1,1166 @@ +-------------------------------------------------------------------------------- +-- $Id: URITest.hs,v 1.8 2005/07/19 22:01:27 gklyne Exp $ +-- +-- Copyright (c) 2004, G. KLYNE. All rights reserved. +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : URITest +-- Copyright : (c) 2004, Graham Klyne +-- License : BSD-style (see end of this file) +-- +-- Maintainer : Graham Klyne +-- Stability : provisional +-- Portability : H98 +-- +-- This Module contains test cases for module URI. +-- +-- Using GHC, I compile with this command line: +-- ghc --make -fglasgow-exts +-- -i..\;C:\Dev\Haskell\Lib\HUnit;C:\Dev\Haskell\Lib\Parsec +-- -o URITest.exe URITest -main-is URITest.main +-- The -i line may need changing for alternative installations. +-- +-------------------------------------------------------------------------------- + +module Main where + +import Network.URI + ( URI(..), URIAuth(..) + , nullURI + , parseURI, parseURIReference, parseRelativeReference, parseAbsoluteURI + , parseabsoluteURI + , isURI, isURIReference, isRelativeReference, isAbsoluteURI + , isIPv6address, isIPv4address + , relativeTo, nonStrictRelativeTo + , relativeFrom + , uriToString + , isUnescapedInURI, escapeURIString, unEscapeString + , normalizeCase, normalizeEscape, normalizePathSegments + ) + +import Test.HUnit + +import IO ( Handle, openFile, IOMode(WriteMode), hClose, hPutStr, hPutStrLn ) + +import Maybe ( fromJust ) + +-- Test supplied string for valid URI reference syntax +-- isValidURIRef :: String -> Bool +-- Test supplied string for valid absolute URI reference syntax +-- isAbsoluteURIRef :: String -> Bool +-- Test supplied string for valid absolute URI syntax +-- isAbsoluteURI :: String -> Bool + +data URIType = AbsId -- URI form (absolute, no fragment) + | AbsRf -- Absolute URI reference + | RelRf -- Relative URI reference + | InvRf -- Invalid URI reference +isValidT :: URIType -> Bool +isValidT InvRf = False +isValidT _ = True + +isAbsRfT :: URIType -> Bool +isAbsRfT AbsId = True +isAbsRfT AbsRf = True +isAbsRfT _ = False + +isRelRfT :: URIType -> Bool +isRelRfT RelRf = True +isRelRfT _ = False + +isAbsIdT :: URIType -> Bool +isAbsIdT AbsId = True +isAbsIdT _ = False + +testEq :: (Eq a, Show a) => String -> a -> a -> Test +testEq lab a1 a2 = TestCase ( assertEqual lab a1 a2 ) + +testURIRef :: URIType -> String -> Test +testURIRef t u = TestList + [ testEq ("test_isURIReference:"++u) (isValidT t) (isURIReference u) + , testEq ("test_isRelativeReference:"++u) (isRelRfT t) (isRelativeReference u) + , testEq ("test_isAbsoluteURI:"++u) (isAbsIdT t) (isAbsoluteURI u) + ] + +testURIRefComponents :: String -> (Maybe URI) -> String -> Test +testURIRefComponents lab uv us = + testEq ("testURIRefComponents:"++us) uv (parseURIReference us) + + +testURIRef001 = testURIRef AbsRf "http://example.org/aaa/bbb#ccc" +testURIRef002 = testURIRef AbsId "mailto:local@domain.org" +testURIRef003 = testURIRef AbsRf "mailto:local@domain.org#frag" +testURIRef004 = testURIRef AbsRf "HTTP://EXAMPLE.ORG/AAA/BBB#CCC" +testURIRef005 = testURIRef RelRf "//example.org/aaa/bbb#ccc" +testURIRef006 = testURIRef RelRf "/aaa/bbb#ccc" +testURIRef007 = testURIRef RelRf "bbb#ccc" +testURIRef008 = testURIRef RelRf "#ccc" +testURIRef009 = testURIRef RelRf "#" +testURIRef010 = testURIRef RelRf "/" +-- escapes +testURIRef011 = testURIRef AbsRf "http://example.org/aaa%2fbbb#ccc" +testURIRef012 = testURIRef AbsRf "http://example.org/aaa%2Fbbb#ccc" +testURIRef013 = testURIRef RelRf "%2F" +testURIRef014 = testURIRef RelRf "aaa%2Fbbb" +-- ports +testURIRef015 = testURIRef AbsRf "http://example.org:80/aaa/bbb#ccc" +testURIRef016 = testURIRef AbsRf "http://example.org:/aaa/bbb#ccc" +testURIRef017 = testURIRef AbsRf "http://example.org./aaa/bbb#ccc" +testURIRef018 = testURIRef AbsRf "http://example.123./aaa/bbb#ccc" +-- bare authority +testURIRef019 = testURIRef AbsId "http://example.org" +-- IPv6 literals (from RFC2732): +testURIRef021 = testURIRef AbsId "http://[FEDC:BA98:7654:3210:FEDC:BA98:7654:3210]:80/index.html" +testURIRef022 = testURIRef AbsId "http://[1080:0:0:0:8:800:200C:417A]/index.html" +testURIRef023 = testURIRef AbsId "http://[3ffe:2a00:100:7031::1]" +testURIRef024 = testURIRef AbsId "http://[1080::8:800:200C:417A]/foo" +testURIRef025 = testURIRef AbsId "http://[::192.9.5.5]/ipng" +testURIRef026 = testURIRef AbsId "http://[::FFFF:129.144.52.38]:80/index.html" +testURIRef027 = testURIRef AbsId "http://[2010:836B:4179::836B:4179]" +testURIRef028 = testURIRef RelRf "//[2010:836B:4179::836B:4179]" +testURIRef029 = testURIRef InvRf "[2010:836B:4179::836B:4179]" +-- RFC2396 test cases +testURIRef031 = testURIRef RelRf "./aaa" +testURIRef032 = testURIRef RelRf "../aaa" +testURIRef033 = testURIRef AbsId "g:h" +testURIRef034 = testURIRef RelRf "g" +testURIRef035 = testURIRef RelRf "./g" +testURIRef036 = testURIRef RelRf "g/" +testURIRef037 = testURIRef RelRf "/g" +testURIRef038 = testURIRef RelRf "//g" +testURIRef039 = testURIRef RelRf "?y" +testURIRef040 = testURIRef RelRf "g?y" +testURIRef041 = testURIRef RelRf "#s" +testURIRef042 = testURIRef RelRf "g#s" +testURIRef043 = testURIRef RelRf "g?y#s" +testURIRef044 = testURIRef RelRf ";x" +testURIRef045 = testURIRef RelRf "g;x" +testURIRef046 = testURIRef RelRf "g;x?y#s" +testURIRef047 = testURIRef RelRf "." +testURIRef048 = testURIRef RelRf "./" +testURIRef049 = testURIRef RelRf ".." +testURIRef050 = testURIRef RelRf "../" +testURIRef051 = testURIRef RelRf "../g" +testURIRef052 = testURIRef RelRf "../.." +testURIRef053 = testURIRef RelRf "../../" +testURIRef054 = testURIRef RelRf "../../g" +testURIRef055 = testURIRef RelRf "../../../g" +testURIRef056 = testURIRef RelRf "../../../../g" +testURIRef057 = testURIRef RelRf "/./g" +testURIRef058 = testURIRef RelRf "/../g" +testURIRef059 = testURIRef RelRf "g." +testURIRef060 = testURIRef RelRf ".g" +testURIRef061 = testURIRef RelRf "g.." +testURIRef062 = testURIRef RelRf "..g" +testURIRef063 = testURIRef RelRf "./../g" +testURIRef064 = testURIRef RelRf "./g/." +testURIRef065 = testURIRef RelRf "g/./h" +testURIRef066 = testURIRef RelRf "g/../h" +testURIRef067 = testURIRef RelRf "g;x=1/./y" +testURIRef068 = testURIRef RelRf "g;x=1/../y" +testURIRef069 = testURIRef RelRf "g?y/./x" +testURIRef070 = testURIRef RelRf "g?y/../x" +testURIRef071 = testURIRef RelRf "g#s/./x" +testURIRef072 = testURIRef RelRf "g#s/../x" +testURIRef073 = testURIRef RelRf "" +testURIRef074 = testURIRef RelRf "A'C" +testURIRef075 = testURIRef RelRf "A$C" +testURIRef076 = testURIRef RelRf "A@C" +testURIRef077 = testURIRef RelRf "A,C" +-- Invalid +testURIRef080 = testURIRef InvRf "http://foo.org:80Path/More" +testURIRef081 = testURIRef InvRf "::" +testURIRef082 = testURIRef InvRf " " +testURIRef083 = testURIRef InvRf "%" +testURIRef084 = testURIRef InvRf "A%Z" +testURIRef085 = testURIRef InvRf "%ZZ" +testURIRef086 = testURIRef InvRf "%AZ" +testURIRef087 = testURIRef InvRf "A C" +-- testURIRef088 = -- (case removed) +-- testURIRef089 = -- (case removed) +testURIRef090 = testURIRef InvRf "A\"C" +testURIRef091 = testURIRef InvRf "A`C" +testURIRef092 = testURIRef InvRf "AC" +testURIRef094 = testURIRef InvRf "A^C" +testURIRef095 = testURIRef InvRf "A\\C" +testURIRef096 = testURIRef InvRf "A{C" +testURIRef097 = testURIRef InvRf "A|C" +testURIRef098 = testURIRef InvRf "A}C" +-- From RFC2396: +-- rel_segment = 1*( unreserved | escaped | +-- ";" | "@" | "&" | "=" | "+" | "$" | "," ) +-- unreserved = alphanum | mark +-- mark = "-" | "_" | "." | "!" | "~" | "*" | "'" | +-- "(" | ")" +-- Note RFC 2732 allows '[', ']' ONLY for reserved purpose of IPv6 literals, +-- or does it? +testURIRef101 = testURIRef InvRf "A[C" +testURIRef102 = testURIRef InvRf "A]C" +testURIRef103 = testURIRef InvRf "A[**]C" +testURIRef104 = testURIRef InvRf "http://[xyz]/" +testURIRef105 = testURIRef InvRf "http://]/" +testURIRef106 = testURIRef InvRf "http://example.org/[2010:836B:4179::836B:4179]" +testURIRef107 = testURIRef InvRf "http://example.org/abc#[2010:836B:4179::836B:4179]" +testURIRef108 = testURIRef InvRf "http://example.org/xxx/[qwerty]#a[b]" +-- Random other things that crop up +testURIRef111 = testURIRef AbsRf "http://example/Andrȷ" +testURIRef112 = testURIRef AbsId "file:///C:/DEV/Haskell/lib/HXmlToolbox-3.01/examples/" +testURIRef113 = testURIRef AbsId "http://46229EFFE16A9BD60B9F1BE88B2DB047ADDED785/demo.mp3" +testURIRef114 = testURIRef InvRf "http://example.org/xxx/qwerty#a#b" +testURIRef115 = testURIRef InvRf "dcp.tcp.pft://192.168.0.1:1002:3002?fec=1&crc=0" +testURIRef116 = testURIRef AbsId "dcp.tcp.pft://192.168.0.1:1002?fec=1&crc=0" +testURIRef117 = testURIRef AbsId "foo://" + +testURIRefSuite = TestLabel "Test URIrefs" testURIRefList +testURIRefList = TestList + [ + testURIRef001, testURIRef002, testURIRef003, testURIRef004, + testURIRef005, testURIRef006, testURIRef007, testURIRef008, + testURIRef009, testURIRef010, + -- + testURIRef011, testURIRef012, testURIRef013, testURIRef014, + testURIRef015, testURIRef016, testURIRef017, testURIRef018, + -- + testURIRef019, + -- + testURIRef021, testURIRef022, testURIRef023, testURIRef024, + testURIRef025, testURIRef026, testURIRef027, testURIRef028, + testURIRef029, + -- + testURIRef031, testURIRef032, testURIRef033, testURIRef034, + testURIRef035, testURIRef036, testURIRef037, testURIRef038, + testURIRef039, + testURIRef040, testURIRef041, testURIRef042, testURIRef043, + testURIRef044, testURIRef045, testURIRef046, testURIRef047, + testURIRef048, testURIRef049, + testURIRef050, testURIRef051, testURIRef052, testURIRef053, + testURIRef054, testURIRef055, testURIRef056, testURIRef057, + testURIRef058, testURIRef059, + testURIRef060, testURIRef061, testURIRef062, testURIRef063, + testURIRef064, testURIRef065, testURIRef066, testURIRef067, + testURIRef068, testURIRef069, + testURIRef070, testURIRef071, testURIRef072, testURIRef073, + testURIRef074, testURIRef075, testURIRef076, testURIRef077, + -- + testURIRef080, + testURIRef081, testURIRef082, testURIRef083, testURIRef084, + testURIRef085, testURIRef086, testURIRef087, -- testURIRef088, + -- testURIRef089, + testURIRef090, testURIRef091, testURIRef092, testURIRef093, + testURIRef094, testURIRef095, testURIRef096, testURIRef097, + testURIRef098, -- testURIRef099, + -- + testURIRef101, testURIRef102, testURIRef103, testURIRef104, + testURIRef105, testURIRef106, testURIRef107, testURIRef108, + -- + testURIRef111, testURIRef112, testURIRef113, testURIRef114, + testURIRef115, testURIRef116, testURIRef117 + ] + +-- test decomposition of URI into components +testComponent01 = testURIRefComponents "testComponent01" + ( Just $ URI + { uriScheme = "http:" + , uriAuthority = Just (URIAuth "user:pass@" "example.org" ":99") + , uriPath = "/aaa/bbb" + , uriQuery = "?qqq" + , uriFragment = "#fff" + } ) + "http://user:pass@example.org:99/aaa/bbb?qqq#fff" +testComponent02 = testURIRefComponents "testComponent02" + ( const Nothing + ( Just $ URI + { uriScheme = "http:" + , uriAuthority = Just (URIAuth "user:pass@" "example.org" ":99") + , uriPath = "aaa/bbb" + , uriQuery = "" + , uriFragment = "" + } ) + ) + "http://user:pass@example.org:99aaa/bbb" +testComponent03 = testURIRefComponents "testComponent03" + ( Just $ URI + { uriScheme = "http:" + , uriAuthority = Just (URIAuth "user:pass@" "example.org" ":99") + , uriPath = "" + , uriQuery = "?aaa/bbb" + , uriFragment = "" + } ) + "http://user:pass@example.org:99?aaa/bbb" +testComponent04 = testURIRefComponents "testComponent03" + ( Just $ URI + { uriScheme = "http:" + , uriAuthority = Just (URIAuth "user:pass@" "example.org" ":99") + , uriPath = "" + , uriQuery = "" + , uriFragment = "#aaa/bbb" + } ) + "http://user:pass@example.org:99#aaa/bbb" +-- These test cases contributed by Robert Buck (mathworks.com) +testComponent11 = testURIRefComponents "testComponent03" + ( Just $ URI + { uriScheme = "about:" + , uriAuthority = Nothing + , uriPath = "" + , uriQuery = "" + , uriFragment = "" + } ) + "about:" +testComponent12 = testURIRefComponents "testComponent03" + ( Just $ URI + { uriScheme = "file:" + , uriAuthority = Just (URIAuth "" "windowsauth" "") + , uriPath = "/d$" + , uriQuery = "" + , uriFragment = "" + } ) + "file://windowsauth/d$" + +testComponentSuite = TestLabel "Test URIrefs" $ TestList + [ testComponent01 + , testComponent02 + , testComponent03 + , testComponent04 + , testComponent11 + , testComponent12 + ] + +-- Get reference relative to given base +-- relativeRef :: String -> String -> String +-- +-- Get absolute URI given base and relative reference +-- absoluteURI :: String -> String -> String +-- +-- Test cases taken from: http://www.w3.org/2000/10/swap/uripath.py +-- (Thanks, Dan Connolly) +-- +-- NOTE: absoluteURI base (relativeRef base u) is always equivalent to u. +-- cf. http://lists.w3.org/Archives/Public/uri/2003Jan/0008.html + +testRelSplit :: String -> String -> String -> String -> Test +testRelSplit label base uabs urel = + testEq label urel (mkrel puabs pubas) + where + mkrel (Just u1) (Just u2) = show (u1 `relativeFrom` u2) + mkrel Nothing _ = "Invalid URI: "++urel + mkrel _ Nothing = "Invalid URI: "++uabs + puabs = parseURIReference uabs + pubas = parseURIReference base + +testRelJoin :: String -> String -> String -> String -> Test +testRelJoin label base urel uabs = + testEq label uabs (mkabs purel pubas) + where + mkabs (Just u1) (Just u2) = shabs (u1 `relativeTo` u2) + mkabs Nothing _ = "Invalid URI: "++urel + mkabs _ Nothing = "Invalid URI: "++uabs + shabs (Just u) = show u + shabs Nothing = "No result" + purel = parseURIReference urel + pubas = parseURIReference base + +testRelative :: String -> String -> String -> String -> Test +testRelative label base uabs urel = TestList + [ + (testRelSplit (label++"(rel)") base uabs urel), + (testRelJoin (label++"(abs)") base urel uabs) + ] + +testRelative01 = testRelative "testRelative01" + "foo:xyz" "bar:abc" "bar:abc" +testRelative02 = testRelative "testRelative02" + "http://example/x/y/z" "http://example/x/abc" "../abc" +testRelative03 = testRelative "testRelative03" + "http://example2/x/y/z" "http://example/x/abc" "//example/x/abc" + -- "http://example2/x/y/z" "http://example/x/abc" "http://example/x/abc" +testRelative04 = testRelative "testRelative04" + "http://ex/x/y/z" "http://ex/x/r" "../r" +testRelative05 = testRelative "testRelative05" + "http://ex/x/y/z" "http://ex/r" "/r" + -- "http://ex/x/y/z" "http://ex/r" "../../r" +testRelative06 = testRelative "testRelative06" + "http://ex/x/y/z" "http://ex/x/y/q/r" "q/r" +testRelative07 = testRelative "testRelative07" + "http://ex/x/y" "http://ex/x/q/r#s" "q/r#s" +testRelative08 = testRelative "testRelative08" + "http://ex/x/y" "http://ex/x/q/r#s/t" "q/r#s/t" +testRelative09 = testRelative "testRelative09" + "http://ex/x/y" "ftp://ex/x/q/r" "ftp://ex/x/q/r" +testRelative10 = testRelative "testRelative10" + -- "http://ex/x/y" "http://ex/x/y" "y" + "http://ex/x/y" "http://ex/x/y" "" +testRelative11 = testRelative "testRelative11" + -- "http://ex/x/y/" "http://ex/x/y/" "./" + "http://ex/x/y/" "http://ex/x/y/" "" +testRelative12 = testRelative "testRelative12" + -- "http://ex/x/y/pdq" "http://ex/x/y/pdq" "pdq" + "http://ex/x/y/pdq" "http://ex/x/y/pdq" "" +testRelative13 = testRelative "testRelative13" + "http://ex/x/y/" "http://ex/x/y/z/" "z/" +testRelative14 = testRelative "testRelative14" + -- "file:/swap/test/animal.rdf" "file:/swap/test/animal.rdf#Animal" "animal.rdf#Animal" + "file:/swap/test/animal.rdf" "file:/swap/test/animal.rdf#Animal" "#Animal" +testRelative15 = testRelative "testRelative15" + "file:/e/x/y/z" "file:/e/x/abc" "../abc" +testRelative16 = testRelative "testRelative16" + "file:/example2/x/y/z" "file:/example/x/abc" "/example/x/abc" +testRelative17 = testRelative "testRelative17" + "file:/ex/x/y/z" "file:/ex/x/r" "../r" +testRelative18 = testRelative "testRelative18" + "file:/ex/x/y/z" "file:/r" "/r" +testRelative19 = testRelative "testRelative19" + "file:/ex/x/y" "file:/ex/x/q/r" "q/r" +testRelative20 = testRelative "testRelative20" + "file:/ex/x/y" "file:/ex/x/q/r#s" "q/r#s" +testRelative21 = testRelative "testRelative21" + "file:/ex/x/y" "file:/ex/x/q/r#" "q/r#" +testRelative22 = testRelative "testRelative22" + "file:/ex/x/y" "file:/ex/x/q/r#s/t" "q/r#s/t" +testRelative23 = testRelative "testRelative23" + "file:/ex/x/y" "ftp://ex/x/q/r" "ftp://ex/x/q/r" +testRelative24 = testRelative "testRelative24" + -- "file:/ex/x/y" "file:/ex/x/y" "y" + "file:/ex/x/y" "file:/ex/x/y" "" +testRelative25 = testRelative "testRelative25" + -- "file:/ex/x/y/" "file:/ex/x/y/" "./" + "file:/ex/x/y/" "file:/ex/x/y/" "" +testRelative26 = testRelative "testRelative26" + -- "file:/ex/x/y/pdq" "file:/ex/x/y/pdq" "pdq" + "file:/ex/x/y/pdq" "file:/ex/x/y/pdq" "" +testRelative27 = testRelative "testRelative27" + "file:/ex/x/y/" "file:/ex/x/y/z/" "z/" +testRelative28 = testRelative "testRelative28" + "file:/devel/WWW/2000/10/swap/test/reluri-1.n3" + "file://meetings.example.com/cal#m1" "//meetings.example.com/cal#m1" + -- "file:/devel/WWW/2000/10/swap/test/reluri-1.n3" + -- "file://meetings.example.com/cal#m1" "file://meetings.example.com/cal#m1" +testRelative29 = testRelative "testRelative29" + "file:/home/connolly/w3ccvs/WWW/2000/10/swap/test/reluri-1.n3" + "file://meetings.example.com/cal#m1" "//meetings.example.com/cal#m1" + -- "file:/home/connolly/w3ccvs/WWW/2000/10/swap/test/reluri-1.n3" + -- "file://meetings.example.com/cal#m1" "file://meetings.example.com/cal#m1" +testRelative30 = testRelative "testRelative30" + "file:/some/dir/foo" "file:/some/dir/#blort" "./#blort" +testRelative31 = testRelative "testRelative31" + "file:/some/dir/foo" "file:/some/dir/#" "./#" +testRelative32 = testRelative "testRelative32" + "http://ex/x/y" "http://ex/x/q:r" "./q:r" + -- see RFC2396bis, section 5 ^^ +testRelative33 = testRelative "testRelative33" + "http://ex/x/y" "http://ex/x/p=q:r" "./p=q:r" + -- "http://ex/x/y" "http://ex/x/p=q:r" "p=q:r" +testRelative34 = testRelative "testRelative34" + "http://ex/x/y?pp/qq" "http://ex/x/y?pp/rr" "?pp/rr" +testRelative35 = testRelative "testRelative35" + "http://ex/x/y?pp/qq" "http://ex/x/y/z" "y/z" +testRelative36 = testRelative "testRelative36" + "mailto:local" + "mailto:local/qual@domain.org#frag" + "local/qual@domain.org#frag" +testRelative37 = testRelative "testRelative37" + "mailto:local/qual1@domain1.org" + "mailto:local/more/qual2@domain2.org#frag" + "more/qual2@domain2.org#frag" +testRelative38 = testRelative "testRelative38" + "http://ex/x/z?q" "http://ex/x/y?q" "y?q" +testRelative39 = testRelative "testRelative39" + "http://ex?p" "http://ex/x/y?q" "/x/y?q" +testRelative40 = testRelative "testRelative40" + "foo:a/b" "foo:a/c/d" "c/d" +testRelative41 = testRelative "testRelative41" + "foo:a/b" "foo:/c/d" "/c/d" +testRelative42 = testRelative "testRelative42" + "foo:a/b?c#d" "foo:a/b?c" "" +testRelative43 = testRelative "testRelative42" + "foo:a" "foo:b/c" "b/c" +testRelative44 = testRelative "testRelative44" + "foo:/a/y/z" "foo:/a/b/c" "../b/c" +testRelative45 = testRelJoin "testRelative45" + "foo:a" "./b/c" "foo:b/c" +testRelative46 = testRelJoin "testRelative46" + "foo:a" "/./b/c" "foo:/b/c" +testRelative47 = testRelJoin "testRelative47" + "foo://a//b/c" "../../d" "foo://a/d" +testRelative48 = testRelJoin "testRelative48" + "foo:a" "." "foo:" +testRelative49 = testRelJoin "testRelative49" + "foo:a" ".." "foo:" + +-- add escape tests +testRelative50 = testRelative "testRelative50" + "http://example/x/y%2Fz" "http://example/x/abc" "abc" +testRelative51 = testRelative "testRelative51" + "http://example/a/x/y/z" "http://example/a/x%2Fabc" "../../x%2Fabc" +testRelative52 = testRelative "testRelative52" + "http://example/a/x/y%2Fz" "http://example/a/x%2Fabc" "../x%2Fabc" +testRelative53 = testRelative "testRelative53" + "http://example/x%2Fy/z" "http://example/x%2Fy/abc" "abc" +testRelative54 = testRelative "testRelative54" + "http://ex/x/y" "http://ex/x/q%3Ar" "q%3Ar" +testRelative55 = testRelative "testRelative55" + "http://example/x/y%2Fz" "http://example/x%2Fabc" "/x%2Fabc" +-- Apparently, TimBL prefers the following way to 41, 42 above +-- cf. http://lists.w3.org/Archives/Public/uri/2003Feb/0028.html +-- He also notes that there may be different relative fuctions +-- that satisfy the basic equivalence axiom: +-- cf. http://lists.w3.org/Archives/Public/uri/2003Jan/0008.html +testRelative56 = testRelative "testRelative56" + "http://example/x/y/z" "http://example/x%2Fabc" "/x%2Fabc" +testRelative57 = testRelative "testRelative57" + "http://example/x/y%2Fz" "http://example/x%2Fabc" "/x%2Fabc" + +-- Other oddball tests + -- Check segment normalization code: +testRelative60 = testRelJoin "testRelative60" + "ftp://example/x/y" "http://example/a/b/../../c" "http://example/c" +testRelative61 = testRelJoin "testRelative61" + "ftp://example/x/y" "http://example/a/b/c/../../" "http://example/a/" +testRelative62 = testRelJoin "testRelative62" + "ftp://example/x/y" "http://example/a/b/c/./" "http://example/a/b/c/" +testRelative63 = testRelJoin "testRelative63" + "ftp://example/x/y" "http://example/a/b/c/.././" "http://example/a/b/" +testRelative64 = testRelJoin "testRelative64" + "ftp://example/x/y" "http://example/a/b/c/d/../../../../e" "http://example/e" +testRelative65 = testRelJoin "testRelative65" + "ftp://example/x/y" "http://example/a/b/c/d/../.././../../e" "http://example/e" + -- Check handling of queries and fragments with non-relative paths +testRelative70 = testRelative "testRelative70" + "mailto:local1@domain1?query1" "mailto:local2@domain2" + "local2@domain2" +testRelative71 = testRelative "testRelative71" + "mailto:local1@domain1" "mailto:local2@domain2?query2" + "local2@domain2?query2" +testRelative72 = testRelative "testRelative72" + "mailto:local1@domain1?query1" "mailto:local2@domain2?query2" + "local2@domain2?query2" +testRelative73 = testRelative "testRelative73" + "mailto:local@domain?query1" "mailto:local@domain?query2" + "?query2" +testRelative74 = testRelative "testRelative74" + "mailto:?query1" "mailto:local@domain?query2" + "local@domain?query2" +testRelative75 = testRelative "testRelative75" + "mailto:local@domain?query1" "mailto:local@domain?query2" + "?query2" +testRelative76 = testRelative "testRelative76" + "foo:bar" "http://example/a/b?c/../d" "http://example/a/b?c/../d" +testRelative77 = testRelative "testRelative77" + "foo:bar" "http://example/a/b#c/../d" "http://example/a/b#c/../d" +{- These (78-81) are some awkward test cases thrown up by a question on the URI list: + http://lists.w3.org/Archives/Public/uri/2005Jul/0013 + Mote that RFC 3986 discards path segents after the final '/' only when merging two + paths - otherwise the final segment in the base URI is mnaintained. This leads to + difficulty in constructinmg a reversible relativeTo/relativeFrom pair of functions. +-} +testRelative78 = testRelative "testRelative78" + "http://www.example.com/data/limit/.." "http://www.example.com/data/limit/test.xml" + "test.xml" +testRelative79 = testRelative "testRelative79" + "file:/some/dir/foo" "file:/some/dir/#blort" "./#blort" +testRelative80 = testRelative "testRelative80" + "file:/some/dir/foo" "file:/some/dir/#" "./#" +testRelative81 = testRelative "testRelative81" + "file:/some/dir/.." "file:/some/dir/#blort" "./#blort" + +-- testRelative base abs rel +-- testRelSplit base abs rel +-- testRelJoin base rel abs +testRelative91 = testRelSplit "testRelative91" + "http://example.org/base/uri" "http:this" + "this" +testRelative92 = testRelJoin "testRelative92" + "http://example.org/base/uri" "http:this" + "http:this" +testRelative93 = testRelJoin "testRelative93" + "http:base" "http:this" + "http:this" +testRelative94 = testRelJoin "testRelative94" + "f:/a" ".//g" + "f://g" +testRelative95 = testRelJoin "testRelative95" + "f://example.org/base/a" "b/c//d/e" + "f://example.org/base/b/c//d/e" +testRelative96 = testRelJoin "testRelative96" + "mid:m@example.ord/c@example.org" "m2@example.ord/c2@example.org" + "mid:m@example.ord/m2@example.ord/c2@example.org" +testRelative97 = testRelJoin "testRelative97" + "file:///C:/DEV/Haskell/lib/HXmlToolbox-3.01/examples/" "mini1.xml" + "file:///C:/DEV/Haskell/lib/HXmlToolbox-3.01/examples/mini1.xml" +testRelative98 = testRelative "testRelative98" + "foo:a/y/z" "foo:a/b/c" "../b/c" +testRelative99 = testRelJoin "testRelative99" + "f:/a/" "..//g" + "f://g" + + +testRelativeSuite = TestLabel "Test Relative URIs" testRelativeList +testRelativeList = TestList + [ testRelative01, testRelative02, testRelative03, testRelative04 + , testRelative05, testRelative06, testRelative07, testRelative08 + , testRelative09 + , testRelative10, testRelative11, testRelative12, testRelative13 + , testRelative14, testRelative15, testRelative16, testRelative17 + , testRelative18, testRelative19 + , testRelative20, testRelative21, testRelative22, testRelative23 + , testRelative24, testRelative25, testRelative26, testRelative27 + , testRelative28, testRelative29 + , testRelative30, testRelative31, testRelative32, testRelative33 + , testRelative34, testRelative35, testRelative36, testRelative37 + , testRelative38, testRelative39 + , testRelative40, testRelative41, testRelative42, testRelative43 + , testRelative44, testRelative45, testRelative46, testRelative47 + , testRelative48, testRelative49 + -- + , testRelative50, testRelative51, testRelative52, testRelative53 + , testRelative54, testRelative55, testRelative56, testRelative57 + -- + , testRelative60, testRelative61, testRelative62, testRelative63 + , testRelative64, testRelative65 + -- + , testRelative70, testRelative71, testRelative72, testRelative73 + , testRelative74, testRelative75, testRelative76, testRelative77 + -- Awkward cases: + , testRelative78, testRelative79, testRelative80, testRelative81 + -- + -- , testRelative90 + , testRelative91, testRelative92, testRelative93 + , testRelative94, testRelative95, testRelative96 + , testRelative97, testRelative98, testRelative99 + ] + +-- RFC2396 relative-to-absolute URI tests + +rfcbase = "http://a/b/c/d;p?q" +-- normal cases, RFC2396bis 5.4.1 +testRFC01 = testRelJoin "testRFC01" rfcbase "g:h" "g:h" +testRFC02 = testRelJoin "testRFC02" rfcbase "g" "http://a/b/c/g" +testRFC03 = testRelJoin "testRFC03" rfcbase "./g" "http://a/b/c/g" +testRFC04 = testRelJoin "testRFC04" rfcbase "g/" "http://a/b/c/g/" +testRFC05 = testRelJoin "testRFC05" rfcbase "/g" "http://a/g" +testRFC06 = testRelJoin "testRFC06" rfcbase "//g" "http://g" +testRFC07 = testRelJoin "testRFC07" rfcbase "?y" "http://a/b/c/d;p?y" +testRFC08 = testRelJoin "testRFC08" rfcbase "g?y" "http://a/b/c/g?y" +testRFC09 = testRelJoin "testRFC09" rfcbase "?q#s" "http://a/b/c/d;p?q#s" +testRFC23 = testRelJoin "testRFC10" rfcbase "#s" "http://a/b/c/d;p?q#s" +testRFC10 = testRelJoin "testRFC11" rfcbase "g#s" "http://a/b/c/g#s" +testRFC11 = testRelJoin "testRFC12" rfcbase "g?y#s" "http://a/b/c/g?y#s" +testRFC12 = testRelJoin "testRFC13" rfcbase ";x" "http://a/b/c/;x" +testRFC13 = testRelJoin "testRFC14" rfcbase "g;x" "http://a/b/c/g;x" +testRFC14 = testRelJoin "testRFC15" rfcbase "g;x?y#s" "http://a/b/c/g;x?y#s" +testRFC24 = testRelJoin "testRFC16" rfcbase "" "http://a/b/c/d;p?q" +testRFC15 = testRelJoin "testRFC17" rfcbase "." "http://a/b/c/" +testRFC16 = testRelJoin "testRFC18" rfcbase "./" "http://a/b/c/" +testRFC17 = testRelJoin "testRFC19" rfcbase ".." "http://a/b/" +testRFC18 = testRelJoin "testRFC20" rfcbase "../" "http://a/b/" +testRFC19 = testRelJoin "testRFC21" rfcbase "../g" "http://a/b/g" +testRFC20 = testRelJoin "testRFC22" rfcbase "../.." "http://a/" +testRFC21 = testRelJoin "testRFC23" rfcbase "../../" "http://a/" +testRFC22 = testRelJoin "testRFC24" rfcbase "../../g" "http://a/g" +-- abnormal cases, RFC2396bis 5.4.2 +testRFC31 = testRelJoin "testRFC31" rfcbase "?q" rfcbase +testRFC32 = testRelJoin "testRFC32" rfcbase "../../../g" "http://a/g" +testRFC33 = testRelJoin "testRFC33" rfcbase "../../../../g" "http://a/g" +testRFC34 = testRelJoin "testRFC34" rfcbase "/./g" "http://a/g" +testRFC35 = testRelJoin "testRFC35" rfcbase "/../g" "http://a/g" +testRFC36 = testRelJoin "testRFC36" rfcbase "g." "http://a/b/c/g." +testRFC37 = testRelJoin "testRFC37" rfcbase ".g" "http://a/b/c/.g" +testRFC38 = testRelJoin "testRFC38" rfcbase "g.." "http://a/b/c/g.." +testRFC39 = testRelJoin "testRFC39" rfcbase "..g" "http://a/b/c/..g" +testRFC40 = testRelJoin "testRFC40" rfcbase "./../g" "http://a/b/g" +testRFC41 = testRelJoin "testRFC41" rfcbase "./g/." "http://a/b/c/g/" +testRFC42 = testRelJoin "testRFC42" rfcbase "g/./h" "http://a/b/c/g/h" +testRFC43 = testRelJoin "testRFC43" rfcbase "g/../h" "http://a/b/c/h" +testRFC44 = testRelJoin "testRFC44" rfcbase "g;x=1/./y" "http://a/b/c/g;x=1/y" +testRFC45 = testRelJoin "testRFC45" rfcbase "g;x=1/../y" "http://a/b/c/y" +testRFC46 = testRelJoin "testRFC46" rfcbase "g?y/./x" "http://a/b/c/g?y/./x" +testRFC47 = testRelJoin "testRFC47" rfcbase "g?y/../x" "http://a/b/c/g?y/../x" +testRFC48 = testRelJoin "testRFC48" rfcbase "g#s/./x" "http://a/b/c/g#s/./x" +testRFC49 = testRelJoin "testRFC49" rfcbase "g#s/../x" "http://a/b/c/g#s/../x" +testRFC50 = testRelJoin "testRFC50" rfcbase "http:x" "http:x" + +-- Null path tests +-- See RFC2396bis, section 5.2, +-- "If the base URI's path component is the empty string, then a single +-- slash character is copied to the buffer" +testRFC60 = testRelative "testRFC60" "http://ex" "http://ex/x/y?q" "/x/y?q" +testRFC61 = testRelJoin "testRFC61" "http://ex" "x/y?q" "http://ex/x/y?q" +testRFC62 = testRelative "testRFC62" "http://ex?p" "http://ex/x/y?q" "/x/y?q" +testRFC63 = testRelJoin "testRFC63" "http://ex?p" "x/y?q" "http://ex/x/y?q" +testRFC64 = testRelative "testRFC64" "http://ex#f" "http://ex/x/y?q" "/x/y?q" +testRFC65 = testRelJoin "testRFC65" "http://ex#f" "x/y?q" "http://ex/x/y?q" +testRFC66 = testRelative "testRFC66" "http://ex?p" "http://ex/x/y#g" "/x/y#g" +testRFC67 = testRelJoin "testRFC67" "http://ex?p" "x/y#g" "http://ex/x/y#g" +testRFC68 = testRelative "testRFC68" "http://ex" "http://ex/" "/" +testRFC69 = testRelJoin "testRFC69" "http://ex" "./" "http://ex/" +testRFC70 = testRelative "testRFC70" "http://ex" "http://ex/a/b" "/a/b" +testRFC71 = testRelative "testRFC71" "http://ex/a/b" "http://ex" "./" + +testRFC2396Suite = TestLabel "Test RFC2396 examples" testRFC2396List +testRFC2396List = TestList + [ + testRFC01, testRFC02, testRFC03, testRFC04, + testRFC05, testRFC06, testRFC07, testRFC08, + testRFC09, + testRFC10, testRFC11, testRFC12, testRFC13, + testRFC14, testRFC15, testRFC16, testRFC17, + testRFC18, testRFC19, + testRFC20, testRFC21, testRFC22, testRFC23, + testRFC24, + -- testRFC30, + testRFC31, testRFC32, testRFC33, + testRFC34, testRFC35, testRFC36, testRFC37, + testRFC38, testRFC39, + testRFC40, testRFC41, testRFC42, testRFC43, + testRFC44, testRFC45, testRFC46, testRFC47, + testRFC48, testRFC49, + testRFC50, + -- + testRFC60, testRFC61, testRFC62, testRFC63, + testRFC64, testRFC65, testRFC66, testRFC67, + testRFC68, testRFC69, + testRFC70 + ] + +-- And some other oddballs: +mailbase = "mailto:local/option@domain.org?notaquery#frag" +testMail01 = testRelJoin "testMail01" + mailbase "more@domain" + "mailto:local/more@domain" +testMail02 = testRelJoin "testMail02" + mailbase "#newfrag" + "mailto:local/option@domain.org?notaquery#newfrag" +testMail03 = testRelJoin "testMail03" + mailbase "l1/q1@domain" + "mailto:local/l1/q1@domain" + +testMail11 = testRelJoin "testMail11" + "mailto:local1@domain1?query1" "mailto:local2@domain2" + "mailto:local2@domain2" +testMail12 = testRelJoin "testMail12" + "mailto:local1@domain1" "mailto:local2@domain2?query2" + "mailto:local2@domain2?query2" +testMail13 = testRelJoin "testMail13" + "mailto:local1@domain1?query1" "mailto:local2@domain2?query2" + "mailto:local2@domain2?query2" +testMail14 = testRelJoin "testMail14" + "mailto:local@domain?query1" "mailto:local@domain?query2" + "mailto:local@domain?query2" +testMail15 = testRelJoin "testMail15" + "mailto:?query1" "mailto:local@domain?query2" + "mailto:local@domain?query2" +testMail16 = testRelJoin "testMail16" + "mailto:local@domain?query1" "?query2" + "mailto:local@domain?query2" +testInfo17 = testRelJoin "testInfo17" + "info:name/1234/../567" "name/9876/../543" + "info:name/name/543" +testInfo18 = testRelJoin "testInfo18" + "info:/name/1234/../567" "name/9876/../543" + "info:/name/name/543" + +testOddballSuite = TestLabel "Test oddball examples" testOddballList +testOddballList = TestList + [ testMail01, testMail02, testMail03 + , testMail11, testMail12, testMail13, testMail14, testMail15, testMail16 + , testInfo17 + ] + +-- Normalization tests + +-- Case normalization; cf. RFC2396bis section 6.2.2.1 +-- NOTE: authority case normalization is not performed +testNormalize01 = testEq "testNormalize01" + "http://EXAMPLE.com/Root/%2A?%2B#%2C" + (normalizeCase "HTTP://EXAMPLE.com/Root/%2a?%2b#%2c") + +-- Encoding normalization; cf. RFC2396bis section 6.2.2.2 +testNormalize11 = testEq "testNormalize11" + "HTTP://EXAMPLE.com/Root/~Me/" + (normalizeEscape "HTTP://EXAMPLE.com/Root/%7eMe/") +testNormalize12 = testEq "testNormalize12" + "foo:%40AZ%5b%60az%7b%2f09%3a-._~" + (normalizeEscape "foo:%40%41%5a%5b%60%61%7a%7b%2f%30%39%3a%2d%2e%5f%7e") +testNormalize13 = testEq "testNormalize13" + "foo:%3a%2f%3f%23%5b%5d%40" + (normalizeEscape "foo:%3a%2f%3f%23%5b%5d%40") + +-- Path segment normalization; cf. RFC2396bis section 6.2.2.4 +testNormalize21 = testEq "testNormalize21" + "http://example/c" + (normalizePathSegments "http://example/a/b/../../c") +testNormalize22 = testEq "testNormalize22" + "http://example/a/" + (normalizePathSegments "http://example/a/b/c/../../") +testNormalize23 = testEq "testNormalize23" + "http://example/a/b/c/" + (normalizePathSegments "http://example/a/b/c/./") +testNormalize24 = testEq "testNormalize24" + "http://example/a/b/" + (normalizePathSegments "http://example/a/b/c/.././") +testNormalize25 = testEq "testNormalize25" + "http://example/e" + (normalizePathSegments "http://example/a/b/c/d/../../../../e") +testNormalize26 = testEq "testNormalize26" + "http://example/e" + (normalizePathSegments "http://example/a/b/c/d/../.././../../e") +testNormalize27 = testEq "testNormalize27" + "http://example/e" + (normalizePathSegments "http://example/a/b/../.././../../e") +testNormalize28 = testEq "testNormalize28" + "foo:e" + (normalizePathSegments "foo:a/b/../.././../../e") + +testNormalizeSuite = TestList + [ testNormalize01 + , testNormalize11 + , testNormalize12 + , testNormalize13 + , testNormalize21, testNormalize22, testNormalize23, testNormalize24 + , testNormalize25, testNormalize26, testNormalize27, testNormalize28 + ] + +-- URI formatting (show) tests + +ts02URI = URI { uriScheme = "http:" + , uriAuthority = Just (URIAuth "user:pass@" "example.org" ":99") + , uriPath = "/aaa/bbb" + , uriQuery = "?ccc" + , uriFragment = "#ddd/eee" + } + +ts04URI = URI { uriScheme = "http:" + , uriAuthority = Just (URIAuth "user:anonymous@" "example.org" ":99") + , uriPath = "/aaa/bbb" + , uriQuery = "?ccc" + , uriFragment = "#ddd/eee" + } + +ts02str = "http://user:...@example.org:99/aaa/bbb?ccc#ddd/eee" +ts03str = "http://user:pass@example.org:99/aaa/bbb?ccc#ddd/eee" +ts04str = "http://user:...@example.org:99/aaa/bbb?ccc#ddd/eee" + +testShowURI01 = testEq "testShowURI01" "" (show nullURI) +testShowURI02 = testEq "testShowURI02" ts02str (show ts02URI) +testShowURI03 = testEq "testShowURI03" ts03str ((uriToString id ts02URI) "") +testShowURI04 = testEq "testShowURI04" ts04str (show ts04URI) + +testShowURI = TestList + [ testShowURI01 + , testShowURI02 + , testShowURI03 + , testShowURI04 + ] + + +-- URI escaping tests + +te01str = "http://example.org/az/09-_/.~:/?#[]@!$&'()*+,;=" +te02str = "http://example.org/a/c%/d /e" +te02esc = "http://example.org/a%3C/b%3E/c%25/d%20/e" + +testEscapeURIString01 = testEq "testEscapeURIString01" + te01str (escapeURIString isUnescapedInURI te01str) + +testEscapeURIString02 = testEq "testEscapeURIString02" + te02esc (escapeURIString isUnescapedInURI te02str) + +testEscapeURIString03 = testEq "testEscapeURIString03" + te01str (unEscapeString te01str) + +testEscapeURIString04 = testEq "testEscapeURIString04" + te02str (unEscapeString te02esc) + + +testEscapeURIString = TestList + [ testEscapeURIString01 + , testEscapeURIString02 + , testEscapeURIString03 + , testEscapeURIString04 + ] + +-- URI string normalization tests + +tn01str = "eXAMPLE://a/b/%7bfoo%7d" +tn01nrm = "example://a/b/%7Bfoo%7D" + +tn02str = "example://a/b/%63/" +tn02nrm = "example://a/b/c/" + +tn03str = "example://a/./b/../b/c/foo" +tn03nrm = "example://a/b/c/foo" + +tn04str = "eXAMPLE://a/b/%7bfoo%7d" -- From RFC2396bis, 6.2.2 +tn04nrm = "example://a/b/%7Bfoo%7D" + +tn06str = "file:/x/..//y" +tn06nrm = "file://y" + +tn07str = "file:x/..//y/" +tn07nrm = "file:/y/" + +testNormalizeURIString01 = testEq "testNormalizeURIString01" + tn01nrm (normalizeCase tn01str) +testNormalizeURIString02 = testEq "testNormalizeURIString02" + tn02nrm (normalizeEscape tn02str) +testNormalizeURIString03 = testEq "testNormalizeURIString03" + tn03nrm (normalizePathSegments tn03str) +testNormalizeURIString04 = testEq "testNormalizeURIString04" + tn04nrm ((normalizeCase . normalizeEscape . normalizePathSegments) tn04str) +testNormalizeURIString05 = testEq "testNormalizeURIString05" + tn04nrm ((normalizePathSegments . normalizeEscape . normalizeCase) tn04str) +testNormalizeURIString06 = testEq "testNormalizeURIString06" + tn06nrm (normalizePathSegments tn06str) +testNormalizeURIString07 = testEq "testNormalizeURIString07" + tn07nrm (normalizePathSegments tn07str) + +testNormalizeURIString = TestList + [ testNormalizeURIString01 + , testNormalizeURIString02 + , testNormalizeURIString03 + , testNormalizeURIString04 + , testNormalizeURIString05 + , testNormalizeURIString06 + , testNormalizeURIString07 + ] + +tnus67 = runTestTT $ TestList + [ testNormalizeURIString06 + , testNormalizeURIString07 + ] + +-- Test strict vs non-strict relativeTo logic + +trbase = fromJust $ parseURIReference "http://bar.org/" + +testRelativeTo01 = testEq "testRelativeTo01" + "http://bar.org/foo" + (show . fromJust $ + (fromJust $ parseURIReference "foo") `relativeTo` trbase) + +testRelativeTo02 = testEq "testRelativeTo02" + "http:foo" + (show . fromJust $ + (fromJust $ parseURIReference "http:foo") `relativeTo` trbase) + +testRelativeTo03 = testEq "testRelativeTo03" + "http://bar.org/foo" + (show . fromJust $ + (fromJust $ parseURIReference "http:foo") `nonStrictRelativeTo` trbase) + +testRelativeTo = TestList + [ testRelativeTo01 + , testRelativeTo02 + , testRelativeTo03 + ] + +-- Test alternative parsing functions +testAltFn01 = testEq "testAltFn01" "Just http://a.b/c#f" + (show . parseURI $ "http://a.b/c#f") +testAltFn02 = testEq "testAltFn02" "Just http://a.b/c#f" + (show . parseURIReference $ "http://a.b/c#f") +testAltFn03 = testEq "testAltFn03" "Just c/d#f" + (show . parseRelativeReference $ "c/d#f") +testAltFn04 = testEq "testAltFn04" "Nothing" + (show . parseRelativeReference $ "http://a.b/c#f") +testAltFn05 = testEq "testAltFn05" "Just http://a.b/c" + (show . parseAbsoluteURI $ "http://a.b/c") +testAltFn06 = testEq "testAltFn06" "Nothing" + (show . parseAbsoluteURI $ "http://a.b/c#f") +testAltFn07 = testEq "testAltFn07" "Nothing" + (show . parseAbsoluteURI $ "c/d") +testAltFn08 = testEq "testAltFn08" "Just http://a.b/c" + (show . parseabsoluteURI $ "http://a.b/c") + +testAltFn11 = testEq "testAltFn11" True (isURI "http://a.b/c#f") +testAltFn12 = testEq "testAltFn12" True (isURIReference "http://a.b/c#f") +testAltFn13 = testEq "testAltFn13" True (isRelativeReference "c/d#f") +testAltFn14 = testEq "testAltFn14" False (isRelativeReference "http://a.b/c#f") +testAltFn15 = testEq "testAltFn15" True (isAbsoluteURI "http://a.b/c") +testAltFn16 = testEq "testAltFn16" False (isAbsoluteURI "http://a.b/c#f") +testAltFn17 = testEq "testAltFn17" False (isAbsoluteURI "c/d") + +testAltFn = TestList + [ testAltFn01 + , testAltFn02 + , testAltFn03 + , testAltFn04 + , testAltFn05 + , testAltFn06 + , testAltFn07 + , testAltFn08 + , testAltFn11 + , testAltFn12 + , testAltFn13 + , testAltFn14 + , testAltFn15 + , testAltFn16 + , testAltFn17 + ] + +-- Full test suite +allTests = TestList + [ testURIRefSuite + , testComponentSuite + , testRelativeSuite + , testRFC2396Suite + , testOddballSuite + , testNormalizeSuite + , testShowURI + , testEscapeURIString + , testNormalizeURIString + , testRelativeTo + , testAltFn + ] + +main = runTestTT allTests + +runTestFile t = do + h <- openFile "a.tmp" WriteMode + runTestText (putTextToHandle h False) t + hClose h +tf = runTestFile +tt = runTestTT + +-- Miscellaneous values for hand-testing/debugging in Hugs: + +uref = testURIRefSuite +tr01 = testRelative01 +tr02 = testRelative02 +tr03 = testRelative03 +tr04 = testRelative04 +rel = testRelativeSuite +rfc = testRFC2396Suite +oddb = testOddballSuite + +(Just bu02) = parseURIReference "http://example/x/y/z" +(Just ou02) = parseURIReference "../abc" +(Just ru02) = parseURIReference "http://example/x/abc" +-- fileuri = testURIReference "file:///C:/DEV/Haskell/lib/HXmlToolbox-3.01/examples/" + +cu02 = ou02 `relativeTo` bu02 + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2004, G. KLYNE. All rights reserved. +-- Distributed as free software under the following license. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions +-- are met: +-- +-- - Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- +-- - Neither name of the copyright holders nor the names of its +-- contributors may be used to endorse or promote products derived from +-- this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND THE CONTRIBUTORS +-- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +-- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +-- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +-- HOLDERS OR THE CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, +-- INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, +-- BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS +-- OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +-- ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR +-- TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +-- USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- +-------------------------------------------------------------------------------- +-- $Source: /srv/cvs/cvs.haskell.org/fptools/libraries/network/tests/URITest.hs,v $ +-- $Author: gklyne $ +-- $Revision: 1.8 $ +-- $Log: URITest.hs,v $ +-- Revision 1.8 2005/07/19 22:01:27 gklyne +-- Added some additional test cases raised by discussion on URI@w3.org mailing list about 2005-07-19. The test p[roposed by this discussion exposed a subtle bug in relativeFrom not being an exact inverse of relativeTo. +-- +-- Revision 1.7 2005/06/06 16:31:44 gklyne +-- Added two new test cases. +-- +-- Revision 1.6 2005/05/31 17:18:36 gklyne +-- Added some additional test cases triggered by URI-list discussions. +-- +-- Revision 1.5 2005/04/07 11:09:37 gklyne +-- Added test cases for alternate parsing functions (including deprecated 'parseabsoluteURI') +-- +-- Revision 1.4 2005/04/05 12:47:32 gklyne +-- Added test case. +-- Changed module name, now requires GHC -main-is to compile. +-- All tests run OK with GHC 6.4 on MS-Windows. +-- +-- Revision 1.3 2004/11/05 17:29:09 gklyne +-- Changed password-obscuring logic to reflect late change in revised URI +-- specification (password "anonymous" is no longer a special case). +-- Updated URI test module to use function 'escapeURIString'. +-- (Should unEscapeString be similarly updated?) +-- +-- Revision 1.2 2004/10/27 13:06:55 gklyne +-- Updated URI module function names per: +-- http://www.haskell.org//pipermail/cvs-libraries/2004-October/002916.html +-- Added test cases to give better covereage of module functions. +-- +-- Revision 1.1 2004/10/14 16:11:30 gklyne +-- Add URI unit test to cvs.haskell.org repository +-- +-- Revision 1.17 2004/10/14 11:51:09 graham +-- Confirm that URITest runs with GHC. +-- Fix up some comments and other minor details. +-- +-- Revision 1.16 2004/10/14 11:45:30 graham +-- Use moduke name main for GHC 6.2 +-- +-- Revision 1.15 2004/08/11 11:07:39 graham +-- Add new test case. +-- +-- Revision 1.14 2004/06/30 11:35:27 graham +-- Update URI code to use hierarchical libraries for Parsec and Network. +-- +-- Revision 1.13 2004/06/22 16:19:16 graham +-- New URI test case added. +-- +-- Revision 1.12 2004/04/21 15:13:29 graham +-- Add test case +-- +-- Revision 1.11 2004/04/21 14:54:05 graham +-- Fix up some tests +-- +-- Revision 1.10 2004/04/20 14:54:13 graham +-- Fix up test cases related to port number in authority, +-- and add some more URI decomposition tests. +-- +-- Revision 1.9 2004/04/07 15:06:17 graham +-- Add extra test case +-- Revise syntax in line with changes to RFC2396bis +-- +-- Revision 1.8 2004/03/17 14:34:58 graham +-- Add Network.HTTP files to CVS +-- +-- Revision 1.7 2004/03/16 14:19:38 graham +-- Change licence to BSD style; add nullURI definition; new test cases. +-- +-- Revision 1.6 2004/02/20 12:12:00 graham +-- Add URI normalization functions +-- +-- Revision 1.5 2004/02/19 23:19:35 graham +-- Network.URI module passes all test cases +-- +-- Revision 1.4 2004/02/17 20:06:02 graham +-- Revised URI parser to reflect latest RFC2396bis (-04) +-- +-- Revision 1.3 2004/02/11 14:32:14 graham +-- Added work-in-progress notes. +-- +-- Revision 1.2 2004/02/02 14:00:39 graham +-- Fix optional host name in URI. Add test cases. +-- +-- Revision 1.1 2004/01/27 21:13:45 graham +-- New URI module and test suite added, +-- implementing the GHC Network.URI interface. +--