diff --git a/Network.hs b/Network.hs --- a/Network.hs +++ b/Network.hs @@ -9,10 +9,12 @@ -- Stability : provisional -- Portability : portable -- --- The "Network" interface is a \"higher-level\" interface to --- networking facilities, and it is recommended unless you need the --- lower-level interface in "Network.Socket". +-- This module is kept for backwards-compatibility. New users are +-- encouraged to use "Network.Socket" instead. -- +-- "Network" was intended as a \"higher-level\" interface to networking +-- facilities, and only supports TCP. +-- ----------------------------------------------------------------------------- #include "HsNetworkConfig.h" @@ -415,18 +417,7 @@ -> (a -> IO b) -- ^ computation to run last (\"release resource\") -> (a -> IO c) -- ^ computation to run in-between -> IO c -- returns the value from the in-between computation -#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 606 -bracketOnError before after thing = - Exception.block (do - a <- before - r <- Exception.catch - (Exception.unblock (thing a)) - (\e -> do { after a; Exception.throw e }) - return r - ) -#else bracketOnError = Exception.bracketOnError -#endif ----------------------------------------------------------------------------- -- Extra documentation diff --git a/Network/BSD.hsc b/Network/BSD.hsc --- a/Network/BSD.hsc +++ b/Network/BSD.hsc @@ -96,11 +96,7 @@ #if defined(HAVE_WINSOCK2_H) && !defined(cygwin32_HOST_OS) import Foreign.C.Types ( CShort ) #endif -#if __GLASGOW_HASKELL__ >= 703 import Foreign.C.Types ( CInt(..), CULong(..), CSize(..) ) -#else -import Foreign.C.Types ( CInt, CULong, CSize ) -#endif import Foreign.Ptr (Ptr, nullPtr) import Foreign.Storable (Storable(..)) import Foreign.Marshal.Array (allocaArray0, peekArray0) @@ -109,11 +105,7 @@ import System.IO.Error (ioeSetErrorString, mkIOError) import System.IO.Unsafe (unsafePerformIO) -#if __GLASGOW_HASKELL__ >= 611 import GHC.IO.Exception -#else -import GHC.IOBase -#endif import Control.Monad (liftM) diff --git a/Network/Socket.hsc b/Network/Socket.hsc --- a/Network/Socket.hsc +++ b/Network/Socket.hsc @@ -174,25 +174,20 @@ import Data.Bits import Data.List (delete, foldl') -import Data.Maybe (fromMaybe, isJust) -import Data.Word (Word8, Word16, Word32) +import Data.Maybe (isJust) +import Data.Word (Word8, Word32) import Foreign.Ptr (Ptr, castPtr, nullPtr) import Foreign.Storable (Storable(..)) import Foreign.C.Error import Foreign.C.String (CString, withCString, withCStringLen, peekCString, peekCStringLen) import Foreign.C.Types (CUInt, CChar) -#if __GLASGOW_HASKELL__ >= 703 import Foreign.C.Types (CInt(..), CSize(..)) -#else -import Foreign.C.Types (CInt, CSize) -#endif import Foreign.Marshal.Alloc ( alloca, allocaBytes ) import Foreign.Marshal.Array ( peekArray ) import Foreign.Marshal.Utils ( maybeWith, with ) import System.IO import Control.Monad (liftM, when) -import Data.Ratio ((%)) import qualified Control.Exception as E import Control.Concurrent.MVar @@ -207,20 +202,13 @@ import GHC.Conc (asyncDoProc) import Foreign (FunPtr) # endif -# if __GLASGOW_HASKELL__ >= 611 import qualified GHC.IO.Device import GHC.IO.Handle.FD import GHC.IO.Exception import GHC.IO -# else -import GHC.IOBase -import GHC.Handle -# endif import qualified System.Posix.Internals -# if __GLASGOW_HASKELL__ >= 611 import GHC.IO.FD -#endif import Network.Socket.Internal import Network.Socket.Types @@ -254,7 +242,7 @@ ----------------------------------------------------------------------------- -- Socket types -#if __GLASGOW_HASKELL__ >= 611 && defined(mingw32_HOST_OS) +#if defined(mingw32_HOST_OS) socket2FD (MkSocket fd _ _ _ _) = -- HACK, 1 means True FD{fdFD = fd,fdIsSocket_ = 1} @@ -369,11 +357,7 @@ -- | Set the socket to nonblocking, if applicable to this platform. setNonBlockIfNeeded :: CInt -> IO () setNonBlockIfNeeded fd = -#if __GLASGOW_HASKELL__ < 611 - System.Posix.Internals.setNonBlockingFD fd -#else System.Posix.Internals.setNonBlockingFD fd True -#endif ----------------------------------------------------------------------------- -- Binding a socket @@ -432,16 +416,16 @@ r <- c_connect s p_addr (fromIntegral sz) if r == -1 then throwSocketError "connect" - else return r + else return () _ -> throwSocketError "connect" #endif - else return r + else return () connectBlocked = do threadWaitWrite (fromIntegral s) err <- getSocketOption sock SoError if (err == 0) - then return 0 + then return () else throwSocketErrorCode "connect" (fromIntegral err) connectLoop @@ -463,7 +447,7 @@ ioError (userError ("listen: can't peform listen on socket in status " ++ show status)) else do - throwSocketErrorIfMinus1Retry "listen" (c_listen s (fromIntegral backlog)) + throwSocketErrorIfMinus1Retry_ "listen" (c_listen s (fromIntegral backlog)) return Listening ----------------------------------------------------------------------------- @@ -640,7 +624,6 @@ withCStringLen xs $ \(str, len) -> do liftM fromIntegral $ #if defined(mingw32_HOST_OS) -# if __GLASGOW_HASKELL__ >= 611 writeRawBufferPtr "Network.Socket.send" (socket2FD sock) @@ -648,16 +631,6 @@ 0 (fromIntegral len) #else - writeRawBufferPtr - "Network.Socket.send" - (fromIntegral s) - True - str - 0 - (fromIntegral len) -#endif - -#else throwSocketErrorWaitWrite sock "send" $ c_send s str (fromIntegral len) 0{-flags-} #endif @@ -672,22 +645,12 @@ sendBuf sock@(MkSocket s _family _stype _protocol _status) str len = do liftM fromIntegral $ #if defined(mingw32_HOST_OS) -# if __GLASGOW_HASKELL__ >= 611 writeRawBufferPtr "Network.Socket.sendBuf" (socket2FD sock) (castPtr str) 0 (fromIntegral len) -# else - writeRawBufferPtr - "Network.Socket.sendBuf" - (fromIntegral s) - True - str - 0 - (fromIntegral len) -# endif #else throwSocketErrorWaitWrite sock "sendBuf" $ c_send s str (fromIntegral len) 0{-flags-} @@ -715,14 +678,9 @@ allocaBytes nbytes $ \ptr -> do len <- #if defined(mingw32_HOST_OS) -# if __GLASGOW_HASKELL__ >= 611 readRawBufferPtr "Network.Socket.recvLen" (socket2FD sock) ptr 0 (fromIntegral nbytes) #else - readRawBufferPtr "Network.Socket.recvLen" (fromIntegral s) True ptr 0 - (fromIntegral nbytes) -#endif -#else throwSocketErrorWaitRead sock "recv" $ c_recv s ptr (fromIntegral nbytes) 0{-flags-} #endif @@ -753,14 +711,9 @@ | otherwise = do len <- #if defined(mingw32_HOST_OS) -# if __GLASGOW_HASKELL__ >= 611 readRawBufferPtr "Network.Socket.recvLenBuf" (socket2FD sock) ptr 0 (fromIntegral nbytes) #else - readRawBufferPtr "Network.Socket.recvLenBuf" (fromIntegral s) True ptr 0 - (fromIntegral nbytes) -#endif -#else throwSocketErrorWaitRead sock "recvBuf" $ c_recv s (castPtr ptr) (fromIntegral nbytes) 0{-flags-} #endif @@ -804,7 +757,7 @@ getPeerName (MkSocket s family _ _ _) = do withNewSockAddr family $ \ptr sz -> do with (fromIntegral sz) $ \int_star -> do - throwSocketErrorIfMinus1Retry "getPeerName" $ c_getpeername s ptr int_star + throwSocketErrorIfMinus1Retry_ "getPeerName" $ c_getpeername s ptr int_star _sz <- peek int_star peekSockAddr ptr @@ -812,7 +765,7 @@ getSocketName (MkSocket s family _ _ _) = do withNewSockAddr family $ \ptr sz -> do with (fromIntegral sz) $ \int_star -> do - throwSocketErrorIfMinus1Retry "getSocketName" $ c_getsockname s ptr int_star + throwSocketErrorIfMinus1Retry_ "getSocketName" $ c_getsockname s ptr int_star peekSockAddr ptr ----------------------------------------------------------------------------- @@ -978,7 +931,7 @@ (level, opt) <- packSocketOption' "getSocketOption" so alloca $ \ptr_v -> with (fromIntegral (sizeOf (undefined :: CInt))) $ \ptr_sz -> do - throwSocketErrorIfMinus1Retry "getSocketOption" $ + throwSocketErrorIfMinus1Retry_ "getSocketOption" $ c_getsockopt s level opt ptr_v ptr_sz fromIntegral `liftM` peek ptr_v @@ -1016,7 +969,7 @@ let fd = fdSocket sock alloca $ \ ptr_uid -> alloca $ \ ptr_gid -> do - throwSocketErrorIfMinus1Retry "getPeerEid" $ + throwSocketErrorIfMinus1Retry_ "getPeerEid" $ c_getpeereid fd ptr_uid ptr_gid uid <- peek ptr_uid gid <- peek ptr_gid @@ -1107,7 +1060,7 @@ -- 'ShutdownBoth', further sends and receives are disallowed. shutdown :: Socket -> ShutdownCmd -> IO () shutdown (MkSocket s _ _ _ _) stype = do - throwSocketErrorIfMinus1Retry "shutdown" (c_shutdown s (sdownCmdToInt stype)) + throwSocketErrorIfMinus1Retry_ "shutdown" (c_shutdown s (sdownCmdToInt stype)) return () -- ----------------------------------------------------------------------------- @@ -1194,26 +1147,15 @@ -- close the 'Socket' after 'socketToHandle', call 'System.IO.hClose' -- on the 'Handle'. -#ifndef __PARALLEL_HASKELL__ socketToHandle :: Socket -> IOMode -> IO Handle socketToHandle s@(MkSocket fd _ _ _ socketStatus) mode = do modifyMVar socketStatus $ \ status -> if status == ConvertedToHandle then ioError (userError ("socketToHandle: already a Handle")) else do -# if __GLASGOW_HASKELL__ >= 611 h <- fdToHandle' (fromIntegral fd) (Just GHC.IO.Device.Stream) True (show s) mode True{-bin-} -# elif __GLASGOW_HASKELL__ >= 608 - h <- fdToHandle' (fromIntegral fd) (Just System.Posix.Internals.Stream) True (show s) mode True{-bin-} -# elif __GLASGOW_HASKELL__ < 608 - h <- openFd (fromIntegral fd) (Just System.Posix.Internals.Stream) True (show s) mode True{-bin-} -# endif hSetBuffering h NoBuffering return (ConvertedToHandle, h) -#else -socketToHandle (MkSocket s family stype protocol status) m = - error "socketToHandle not implemented in a parallel setup" -#endif -- | Pack a list of values into a bitmask. The possible mappings from -- value to bit-to-set are given as the first argument. We assume diff --git a/Network/Socket/ByteString.hsc b/Network/Socket/ByteString.hsc --- a/Network/Socket/ByteString.hsc +++ b/Network/Socket/ByteString.hsc @@ -48,11 +48,7 @@ import Data.ByteString.Internal (createAndTrim) import Data.ByteString.Unsafe (unsafeUseAsCStringLen) import Data.Word (Word8) -#if __GLASGOW_HASKELL__ >= 703 import Foreign.C.Types (CInt(..)) -#else -import Foreign.C.Types (CInt) -#endif import Foreign.Marshal.Alloc (allocaBytes) import Foreign.Ptr (Ptr, castPtr) import Network.Socket (SockAddr, Socket(..), sendBufTo, recvBufFrom) @@ -66,11 +62,7 @@ #if !defined(mingw32_HOST_OS) import Control.Monad (zipWithM_) import Foreign.C.Types (CChar) -# if __GLASGOW_HASKELL__ >= 703 import Foreign.C.Types (CSize(..)) -# else -import Foreign.C.Types (CSize) -# endif import Foreign.Marshal.Array (allocaArray) import Foreign.Marshal.Utils (with) import Foreign.Ptr (plusPtr) @@ -79,13 +71,9 @@ import Network.Socket.ByteString.IOVec (IOVec(..)) import Network.Socket.ByteString.MsgHdr (MsgHdr(..)) -import GHC.Conc (threadWaitRead, threadWaitWrite) #else -# if __GLASGOW_HASKELL__ >= 611 import GHC.IO.FD -# else import GHC.Handle (readRawBufferPtr, writeRawBufferPtr) -# endif #endif #if !defined(mingw32_HOST_OS) @@ -108,13 +96,8 @@ unsafeUseAsCStringLen xs $ \(str, len) -> liftM fromIntegral $ #if 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 throwSocketErrorWaitWrite sock "send" $ c_send s str (fromIntegral len) 0 @@ -255,12 +238,7 @@ recvInner sock nbytes ptr = fmap fromIntegral $ #if 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 throwSocketErrorWaitRead sock "recv" $ c_recv s (castPtr ptr) (fromIntegral nbytes) 0 diff --git a/Network/Socket/ByteString/Internal.hs b/Network/Socket/ByteString/Internal.hs --- a/Network/Socket/ByteString/Internal.hs +++ b/Network/Socket/ByteString/Internal.hs @@ -21,24 +21,15 @@ import System.IO.Error (ioeSetErrorString, mkIOError) #if !defined(mingw32_HOST_OS) -# if __GLASGOW_HASKELL__ >= 703 import Foreign.C.Types (CInt(..)) import System.Posix.Types (CSsize(..)) -# else -import Foreign.C.Types (CInt) -import System.Posix.Types (CSsize) -# endif import Foreign.Ptr (Ptr) import Network.Socket.ByteString.IOVec (IOVec) import Network.Socket.ByteString.MsgHdr (MsgHdr) #endif -#if __GLASGOW_HASKELL__ < 611 -import GHC.IOBase (IOErrorType(..)) -#else import GHC.IO.Exception (IOErrorType(..)) -#endif mkInvalidRecvArgError :: String -> IOError mkInvalidRecvArgError loc = ioeSetErrorString (mkIOError diff --git a/Network/Socket/ByteString/Lazy.hs b/Network/Socket/ByteString/Lazy.hs new file mode 100644 --- /dev/null +++ b/Network/Socket/ByteString/Lazy.hs @@ -0,0 +1,149 @@ +{-# 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 + +import qualified Data.ByteString.Lazy as L + +import GHC.Conc (threadWaitWrite) +#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 sock@(MkSocket fd _ _ _ _) s = do + let cs = take maxNumChunks (L.toChunks s) + len = length cs + liftM fromIntegral . allocaArray len $ \ptr -> + withPokes cs ptr $ \niovs -> + throwSocketErrorWaitWrite sock "writev" $ + 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/Lazy.hsc b/Network/Socket/ByteString/Lazy.hsc deleted file mode 100644 --- a/Network/Socket/ByteString/Lazy.hsc +++ /dev/null @@ -1,149 +0,0 @@ -{-# 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 - -import qualified Data.ByteString.Lazy as L - -import GHC.Conc (threadWaitWrite) -#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 sock@(MkSocket fd _ _ _ _) s = do - let cs = take maxNumChunks (L.toChunks s) - len = length cs - liftM fromIntegral . allocaArray len $ \ptr -> - withPokes cs ptr $ \niovs -> - throwSocketErrorWaitWrite sock "writev" $ - 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/Lazy/Posix.hs b/Network/Socket/ByteString/Lazy/Posix.hs new file mode 100644 --- /dev/null +++ b/Network/Socket/ByteString/Lazy/Posix.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE BangPatterns #-} +module Network.Socket.ByteString.Lazy.Posix + ( + -- * Send data to a socket + send + , sendAll + ) where + +import Control.Monad (liftM) +import Control.Monad (unless) +import qualified Data.ByteString.Lazy as L +import Data.ByteString.Lazy.Internal (ByteString(..)) +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) +import Data.Int (Int64) +import Foreign.Marshal.Array (allocaArray) +import Foreign.Ptr (plusPtr) +import Foreign.Storable (Storable(..)) + +import Network.Socket (Socket(..)) +import Network.Socket.ByteString.IOVec (IOVec(IOVec)) +import Network.Socket.ByteString.Internal (c_writev) +import Network.Socket.Internal + +-- ----------------------------------------------------------------------------- +-- Sending + +send :: Socket -- ^ Connected socket + -> ByteString -- ^ Data to send + -> IO Int64 -- ^ Number of bytes sent +send sock@(MkSocket fd _ _ _ _) s = do + let cs = take maxNumChunks (L.toChunks s) + len = length cs + liftM fromIntegral . allocaArray len $ \ptr -> + withPokes cs ptr $ \niovs -> + throwSocketErrorWaitWrite sock "writev" $ + 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 + +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' diff --git a/Network/Socket/ByteString/Lazy/Windows.hs b/Network/Socket/ByteString/Lazy/Windows.hs new file mode 100644 --- /dev/null +++ b/Network/Socket/ByteString/Lazy/Windows.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE BangPatterns #-} +module Network.Socket.ByteString.Lazy.Windows + ( + -- * Send data to a socket + send + , sendAll + ) where + +import Control.Applicative ((<$>)) +import Control.Monad (unless) +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Data.Int (Int64) + +import Network.Socket (Socket(..)) +import qualified Network.Socket.ByteString as Socket + +-- ----------------------------------------------------------------------------- +-- Sending + +send :: Socket -- ^ Connected socket + -> L.ByteString -- ^ Data to send + -> IO Int64 -- ^ Number of bytes sent +send sock s = do + fromIntegral <$> case L.toChunks s of + -- TODO: Consider doing nothing if the string is empty. + [] -> Socket.send sock S.empty + (x:_) -> Socket.send sock x + +sendAll :: Socket -- ^ Connected socket + -> L.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' diff --git a/Network/Socket/Internal.hsc b/Network/Socket/Internal.hsc --- a/Network/Socket/Internal.hsc +++ b/Network/Socket/Internal.hsc @@ -52,6 +52,7 @@ -- * Guards for socket operations that may fail , throwSocketErrorIfMinus1_ , throwSocketErrorIfMinus1Retry + , throwSocketErrorIfMinus1Retry_ , throwSocketErrorIfMinus1RetryMayBlock -- ** Guards that wait and retry if the operation would block @@ -68,22 +69,12 @@ , zeroMemory ) where -import Data.Bits ( (.|.), shiftL, shiftR ) -import Data.Word ( Word8, Word16, Word32 ) -import Data.Typeable (Typeable) import Foreign.C.Error (throwErrno, throwErrnoIfMinus1Retry, throwErrnoIfMinus1RetryMayBlock, throwErrnoIfMinus1_, Errno(..), errnoToIOError) -import Foreign.C.String ( castCharToCChar, peekCString ) -#if __GLASGOW_HASKELL__ >= 703 -import Foreign.C.Types ( CInt(..), CSize(..) ) -#else -import Foreign.C.Types ( CInt, CSize ) -#endif -import Foreign.Marshal.Alloc ( allocaBytes ) -import Foreign.Marshal.Array ( pokeArray, pokeArray0 ) -import Foreign.Ptr ( Ptr, castPtr, plusPtr ) -import Foreign.Storable ( Storable(..) ) +import Foreign.C.String (peekCString) +import Foreign.C.Types (CInt(..)) +import Foreign.Ptr (Ptr) import GHC.Conc (threadWaitRead, threadWaitWrite) #if defined(HAVE_WINSOCK2_H) && !defined(cygwin32_HOST_OS) @@ -132,6 +123,19 @@ -> IO a {-# SPECIALIZE throwSocketErrorIfMinus1Retry :: String -> IO CInt -> IO CInt #-} + +-- | Throw an 'IOError' corresponding to the current socket error if +-- the IO action returns a result of @-1@, but retries in case of an +-- interrupted operation. Discards the result of the IO action after +-- error handling. +throwSocketErrorIfMinus1Retry_ + :: (Eq a, Num a) + => String -- ^ textual description of the location + -> IO a -- ^ the 'IO' operation to be executed + -> IO () +throwSocketErrorIfMinus1Retry_ loc m = + throwSocketErrorIfMinus1Retry loc m >> return () +{-# SPECIALIZE throwSocketErrorIfMinus1Retry_ :: String -> IO CInt -> IO () #-} -- | Throw an 'IOError' corresponding to the current socket error if -- the IO action returns a result of @-1@, but retries in case of an diff --git a/Network/Socket/Types.hsc b/Network/Socket/Types.hsc --- a/Network/Socket/Types.hsc +++ b/Network/Socket/Types.hsc @@ -75,10 +75,19 @@ (MVar SocketStatus) -- Status Flag deriving Typeable +sockFd :: Socket -> CInt sockFd (MkSocket n _ _ _ _) = n + +sockFamily :: Socket -> Family sockFamily (MkSocket _ f _ _ _) = f + +sockType :: Socket -> SocketType sockType (MkSocket _ _ t _ _) = t + +sockProtocol :: Socket -> ProtocolNumber sockProtocol (MkSocket _ _ _ p _) = p + +sockStatus :: Socket -> MVar SocketStatus sockStatus (MkSocket _ _ _ _ s) = s instance Eq Socket where diff --git a/Network/URI.hs b/Network/URI.hs deleted file mode 100644 --- a/Network/URI.hs +++ /dev/null @@ -1,1349 +0,0 @@ -{-# LANGUAGE CPP #-} --------------------------------------------------------------------------------- --- | --- Module : Network.URI --- Copyright : (c) 2004, Graham Klyne --- License : BSD-style (see end of this file) --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : portable --- --- This module defines functions for handling URIs. It presents substantially the --- same interface as the older GHC Network.URI module, but is implemented using --- Parsec rather than a Regex library that is not available with Hugs. The internal --- representation of URI has been changed so that URI strings are more --- completely preserved when round-tripping to a URI value and back. --- --- In addition, four methods are provided for parsing different --- kinds of URI string (as noted in RFC3986): --- 'parseURI', --- 'parseURIReference', --- 'parseRelativeReference' and --- 'parseAbsoluteURI'. --- --- Further, four methods are provided for classifying different --- kinds of URI string (as noted in RFC3986): --- 'isURI', --- 'isURIReference', --- 'isRelativeReference' and --- 'isAbsoluteURI'. --- --- The long-standing official reference for URI handling was RFC2396 [1], --- as updated by RFC 2732 [2], but this was replaced by a new specification, --- RFC3986 [3] in January 2005. This latter specification has been used --- as the primary reference for constructing the URI parser implemented --- here, and it is intended that there is a direct relationship between --- the syntax definition in that document and this parser implementation. --- --- RFC 1808 [4] contains a number of test cases for relative URI handling. --- Dan Connolly's Python module @uripath.py@ [5] also contains useful details --- and test cases. --- --- Some of the code has been copied from the previous GHC implementation, --- but the parser is replaced with one that performs more complete --- syntax checking of the URI itself, according to RFC3986 [3]. --- --- References --- --- (1) --- --- (2) --- --- (3) --- --- (4) --- --- (5) --- --------------------------------------------------------------------------------- - -module Network.URI - ( - -- * The URI type - URI(..) - , URIAuth(..) - , nullURI - - -- * Parsing - , parseURI - , parseURIReference - , parseRelativeReference - , parseAbsoluteURI - - -- * Test for strings containing various kinds of URI - , isURI - , isURIReference - , isRelativeReference - , isAbsoluteURI - , isIPv6address - , isIPv4address - - -- * Predicates - , uriIsAbsolute - , uriIsRelative - - -- * Relative URIs - , relativeTo - , nonStrictRelativeTo - , relativeFrom - - -- * Operations on URI strings - -- | Support for putting strings into URI-friendly - -- escaped format and getting them back again. - -- This can't be done transparently in all cases, because certain - -- characters have different meanings in different kinds of URI. - -- The URI spec [3], section 2.4, indicates that all URI components - -- should be escaped before they are assembled as a URI: - -- \"Once produced, a URI is always in its percent-encoded form\" - , uriToString - , isReserved, isUnreserved - , isAllowedInURI, isUnescapedInURI - , isUnescapedInURIComponent - , escapeURIChar - , escapeURIString - , unEscapeString - - -- * URI Normalization functions - , normalizeCase - , normalizeEscape - , normalizePathSegments - - -- * Deprecated functions - , parseabsoluteURI - , escapeString - , reserved, unreserved - , scheme, authority, path, query, fragment - ) where - -import Text.ParserCombinators.Parsec - ( GenParser, ParseError - , parse, (<|>), (), try - , option, many, many1, count, notFollowedBy - , char, satisfy, oneOf, string, eof - , unexpected - ) - -import Control.Monad (MonadPlus(..)) -import Data.Char (ord, chr, isHexDigit, toLower, toUpper, digitToInt) -import Data.Bits ((.|.),(.&.),shiftL,shiftR) -import Debug.Trace (trace) -import Numeric (showIntAtBase) - -import Data.Typeable (Typeable) -#if MIN_VERSION_base(4,0,0) -import Data.Data (Data) -#else -import Data.Generics (Data) -#endif - ------------------------------------------------------------- --- The URI datatype ------------------------------------------------------------- - --- |Represents a general universal resource identifier using --- its component parts. --- --- For example, for the URI --- --- > foo://anonymous@www.haskell.org:42/ghc?query#frag --- --- the components are: --- -data URI = URI - { uriScheme :: String -- ^ @foo:@ - , uriAuthority :: Maybe URIAuth -- ^ @\/\/anonymous\@www.haskell.org:42@ - , uriPath :: String -- ^ @\/ghc@ - , uriQuery :: String -- ^ @?query@ - , uriFragment :: String -- ^ @#frag@ - } deriving (Eq, Ord, Typeable, Data) - --- |Type for authority value within a URI -data URIAuth = URIAuth - { uriUserInfo :: String -- ^ @anonymous\@@ - , uriRegName :: String -- ^ @www.haskell.org@ - , uriPort :: String -- ^ @:42@ - } deriving (Eq, Ord, Show, Typeable, Data) - --- |Blank URI -nullURI :: URI -nullURI = URI - { uriScheme = "" - , uriAuthority = Nothing - , uriPath = "" - , uriQuery = "" - , uriFragment = "" - } - --- URI as instance of Show. Note that for security reasons, the default --- behaviour is to suppress any userinfo field (see RFC3986, section 7.5). --- This can be overridden by using uriToString directly with first --- argument @id@ (noting that this returns a ShowS value rather than a string). --- --- [[[Another design would be to embed the userinfo mapping function in --- the URIAuth value, with the default value suppressing userinfo formatting, --- but providing a function to return a new URI value with userinfo --- data exposed by show.]]] --- -instance Show URI where - showsPrec _ = uriToString defaultUserInfoMap - -defaultUserInfoMap :: String -> String -defaultUserInfoMap uinf = user++newpass - where - (user,pass) = break (==':') uinf - newpass = if null pass || (pass == "@") - || (pass == ":@") - then pass - else ":...@" - -testDefaultUserInfoMap :: [Bool] -testDefaultUserInfoMap = - [ defaultUserInfoMap "" == "" - , defaultUserInfoMap "@" == "@" - , defaultUserInfoMap "user@" == "user@" - , defaultUserInfoMap "user:@" == "user:@" - , defaultUserInfoMap "user:anonymous@" == "user:...@" - , defaultUserInfoMap "user:pass@" == "user:...@" - , defaultUserInfoMap "user:pass" == "user:...@" - , defaultUserInfoMap "user:anonymous" == "user:...@" - ] - ------------------------------------------------------------- --- Parse a URI ------------------------------------------------------------- - --- |Turn a string containing a URI into a 'URI'. --- Returns 'Nothing' if the string is not a valid URI; --- (an absolute URI with optional fragment identifier). --- --- NOTE: this is different from the previous network.URI, --- whose @parseURI@ function works like 'parseURIReference' --- in this module. --- -parseURI :: String -> Maybe URI -parseURI = parseURIAny uri - --- |Parse a URI reference to a 'URI' value. --- Returns 'Nothing' if the string is not a valid URI reference. --- (an absolute or relative URI with optional fragment identifier). --- -parseURIReference :: String -> Maybe URI -parseURIReference = parseURIAny uriReference - --- |Parse a relative URI to a 'URI' value. --- Returns 'Nothing' if the string is not a valid relative URI. --- (a relative URI with optional fragment identifier). --- -parseRelativeReference :: String -> Maybe URI -parseRelativeReference = parseURIAny relativeRef - --- |Parse an absolute URI to a 'URI' value. --- Returns 'Nothing' if the string is not a valid absolute URI. --- (an absolute URI without a fragment identifier). --- -parseAbsoluteURI :: String -> Maybe URI -parseAbsoluteURI = parseURIAny absoluteURI - --- |Test if string contains a valid URI --- (an absolute URI with optional fragment identifier). --- -isURI :: String -> Bool -isURI = isValidParse uri - --- |Test if string contains a valid URI reference --- (an absolute or relative URI with optional fragment identifier). --- -isURIReference :: String -> Bool -isURIReference = isValidParse uriReference - --- |Test if string contains a valid relative URI --- (a relative URI with optional fragment identifier). --- -isRelativeReference :: String -> Bool -isRelativeReference = isValidParse relativeRef - --- |Test if string contains a valid absolute URI --- (an absolute URI without a fragment identifier). --- -isAbsoluteURI :: String -> Bool -isAbsoluteURI = isValidParse absoluteURI - --- |Test if string contains a valid IPv6 address --- -isIPv6address :: String -> Bool -isIPv6address = isValidParse ipv6address - --- |Test if string contains a valid IPv4 address --- -isIPv4address :: String -> Bool -isIPv4address = isValidParse ipv4address - --- |Test function: parse and reconstruct a URI reference --- -testURIReference :: String -> String -testURIReference uristr = show (parseAll uriReference "" uristr) - --- Helper function for turning a string into a URI --- -parseURIAny :: URIParser URI -> String -> Maybe URI -parseURIAny parser uristr = case parseAll parser "" uristr of - Left _ -> Nothing - Right u -> Just u - --- Helper function to test a string match to a parser --- -isValidParse :: URIParser a -> String -> Bool -isValidParse parser uristr = case parseAll parser "" uristr of - -- Left e -> error (show e) - Left _ -> False - Right _ -> True - -parseAll :: URIParser a -> String -> String -> Either ParseError a -parseAll parser filename uristr = parse newparser filename uristr - where - newparser = - do { res <- parser - ; eof - ; return res - } - ------------------------------------------------------------- --- Predicates ------------------------------------------------------------- - -uriIsAbsolute :: URI -> Bool -uriIsAbsolute (URI {uriScheme = scheme}) = scheme /= "" - -uriIsRelative :: URI -> Bool -uriIsRelative = not . uriIsAbsolute - ------------------------------------------------------------- --- URI parser body based on Parsec elements and combinators ------------------------------------------------------------- - --- Parser parser type. --- Currently -type URIParser a = GenParser Char () a - --- RFC3986, section 2.1 --- --- Parse and return a 'pct-encoded' sequence --- -escaped :: URIParser String -escaped = - do { char '%' - ; h1 <- hexDigitChar - ; h2 <- hexDigitChar - ; return $ ['%',h1,h2] - } - --- RFC3986, section 2.2 --- --- |Returns 'True' if the character is a \"reserved\" character in a --- URI. To include a literal instance of one of these characters in a --- component of a URI, it must be escaped. --- -isReserved :: Char -> Bool -isReserved c = isGenDelims c || isSubDelims c - -isGenDelims :: Char -> Bool -isGenDelims c = c `elem` ":/?#[]@" - -isSubDelims :: Char -> Bool -isSubDelims c = c `elem` "!$&'()*+,;=" - -genDelims :: URIParser String -genDelims = do { c <- satisfy isGenDelims ; return [c] } - -subDelims :: URIParser String -subDelims = do { c <- satisfy isSubDelims ; return [c] } - --- RFC3986, section 2.3 --- --- |Returns 'True' if the character is an \"unreserved\" character in --- a URI. These characters do not need to be escaped in a URI. The --- only characters allowed in a URI are either \"reserved\", --- \"unreserved\", or an escape sequence (@%@ followed by two hex digits). --- -isUnreserved :: Char -> Bool -isUnreserved c = isAlphaNumChar c || (c `elem` "-_.~") - -unreservedChar :: URIParser String -unreservedChar = do { c <- satisfy isUnreserved ; return [c] } - --- RFC3986, section 3 --- --- URI = scheme ":" hier-part [ "?" query ] [ "#" fragment ] --- --- hier-part = "//" authority path-abempty --- / path-abs --- / path-rootless --- / path-empty - -uri :: URIParser URI -uri = - do { us <- try uscheme - -- ; ua <- option Nothing ( do { try (string "//") ; uauthority } ) - -- ; up <- upath - ; (ua,up) <- hierPart - ; uq <- option "" ( do { char '?' ; uquery } ) - ; uf <- option "" ( do { char '#' ; ufragment } ) - ; return $ URI - { uriScheme = us - , uriAuthority = ua - , uriPath = up - , uriQuery = uq - , uriFragment = uf - } - } - -hierPart :: URIParser ((Maybe URIAuth),String) -hierPart = - do { try (string "//") - ; ua <- uauthority - ; up <- pathAbEmpty - ; return (ua,up) - } - <|> do { up <- pathAbs - ; return (Nothing,up) - } - <|> do { up <- pathRootLess - ; return (Nothing,up) - } - <|> do { return (Nothing,"") - } - --- RFC3986, section 3.1 - -uscheme :: URIParser String -uscheme = - do { s <- oneThenMany alphaChar (satisfy isSchemeChar) - ; char ':' - ; return $ s++":" - } - --- RFC3986, section 3.2 - -uauthority :: URIParser (Maybe URIAuth) -uauthority = - do { uu <- option "" (try userinfo) - ; uh <- host - ; up <- option "" port - ; return $ Just $ URIAuth - { uriUserInfo = uu - , uriRegName = uh - , uriPort = up - } - } - --- RFC3986, section 3.2.1 - -userinfo :: URIParser String -userinfo = - do { uu <- many (uchar ";:&=+$,") - ; char '@' - ; return (concat uu ++"@") - } - --- RFC3986, section 3.2.2 - -host :: URIParser String -host = ipLiteral <|> try ipv4address <|> regName - -ipLiteral :: URIParser String -ipLiteral = - do { char '[' - ; ua <- ( ipv6address <|> ipvFuture ) - ; char ']' - ; return $ "[" ++ ua ++ "]" - } - "IP address literal" - -ipvFuture :: URIParser String -ipvFuture = - do { char 'v' - ; h <- hexDigitChar - ; char '.' - ; a <- many1 (satisfy isIpvFutureChar) - ; return $ 'v':h:'.':a - } - -isIpvFutureChar :: Char -> Bool -isIpvFutureChar c = isUnreserved c || isSubDelims c || (c==';') - -ipv6address :: URIParser String -ipv6address = - try ( do - { a2 <- count 6 h4c - ; a3 <- ls32 - ; return $ concat a2 ++ a3 - } ) - <|> try ( do - { string "::" - ; a2 <- count 5 h4c - ; a3 <- ls32 - ; return $ "::" ++ concat a2 ++ a3 - } ) - <|> try ( do - { a1 <- opt_n_h4c_h4 0 - ; string "::" - ; a2 <- count 4 h4c - ; a3 <- ls32 - ; return $ a1 ++ "::" ++ concat a2 ++ a3 - } ) - <|> try ( do - { a1 <- opt_n_h4c_h4 1 - ; string "::" - ; a2 <- count 3 h4c - ; a3 <- ls32 - ; return $ a1 ++ "::" ++ concat a2 ++ a3 - } ) - <|> try ( do - { a1 <- opt_n_h4c_h4 2 - ; string "::" - ; a2 <- count 2 h4c - ; a3 <- ls32 - ; return $ a1 ++ "::" ++ concat a2 ++ a3 - } ) - <|> try ( do - { a1 <- opt_n_h4c_h4 3 - ; string "::" - ; a2 <- h4c - ; a3 <- ls32 - ; return $ a1 ++ "::" ++ a2 ++ a3 - } ) - <|> try ( do - { a1 <- opt_n_h4c_h4 4 - ; string "::" - ; a3 <- ls32 - ; return $ a1 ++ "::" ++ a3 - } ) - <|> try ( do - { a1 <- opt_n_h4c_h4 5 - ; string "::" - ; a3 <- h4 - ; return $ a1 ++ "::" ++ a3 - } ) - <|> try ( do - { a1 <- opt_n_h4c_h4 6 - ; string "::" - ; return $ a1 ++ "::" - } ) - "IPv6 address" - -opt_n_h4c_h4 :: Int -> URIParser String -opt_n_h4c_h4 n = option "" $ - do { a1 <- countMinMax 0 n h4c - ; a2 <- h4 - ; return $ concat a1 ++ a2 - } - -ls32 :: URIParser String -ls32 = try ( do - { a1 <- h4c - ; a2 <- h4 - ; return (a1++a2) - } ) - <|> ipv4address - -h4c :: URIParser String -h4c = try $ - do { a1 <- h4 - ; char ':' - ; notFollowedBy (char ':') - ; return $ a1 ++ ":" - } - -h4 :: URIParser String -h4 = countMinMax 1 4 hexDigitChar - -ipv4address :: URIParser String -ipv4address = - do { a1 <- decOctet ; char '.' - ; a2 <- decOctet ; char '.' - ; a3 <- decOctet ; char '.' - ; a4 <- decOctet - ; notFollowedBy regName - ; return $ a1++"."++a2++"."++a3++"."++a4 - } - "IPv4 Address" - -decOctet :: URIParser String -decOctet = - do { a1 <- countMinMax 1 3 digitChar - ; if (read a1 :: Integer) > 255 then - fail "Decimal octet value too large" - else - return a1 - } - -regName :: URIParser String -regName = - do { ss <- countMinMax 0 255 ( unreservedChar <|> escaped <|> subDelims ) - ; return $ concat ss - } - "Registered name" - --- RFC3986, section 3.2.3 - -port :: URIParser String -port = - do { char ':' - ; p <- many digitChar - ; return (':':p) - } - --- --- RFC3986, section 3.3 --- --- path = path-abempty ; begins with "/" or is empty --- / path-abs ; begins with "/" but not "//" --- / path-noscheme ; begins with a non-colon segment --- / path-rootless ; begins with a segment --- / path-empty ; zero characters --- --- path-abempty = *( "/" segment ) --- path-abs = "/" [ segment-nz *( "/" segment ) ] --- path-noscheme = segment-nzc *( "/" segment ) --- path-rootless = segment-nz *( "/" segment ) --- path-empty = 0 --- --- segment = *pchar --- segment-nz = 1*pchar --- segment-nzc = 1*( unreserved / pct-encoded / sub-delims / "@" ) --- --- pchar = unreserved / pct-encoded / sub-delims / ":" / "@" - -{- -upath :: URIParser String -upath = pathAbEmpty - <|> pathAbs - <|> pathNoScheme - <|> pathRootLess - <|> pathEmpty --} - -pathAbEmpty :: URIParser String -pathAbEmpty = - do { ss <- many slashSegment - ; return $ concat ss - } - -pathAbs :: URIParser String -pathAbs = - do { char '/' - ; ss <- option "" pathRootLess - ; return $ '/':ss - } - -pathNoScheme :: URIParser String -pathNoScheme = - do { s1 <- segmentNzc - ; ss <- many slashSegment - ; return $ concat (s1:ss) - } - -pathRootLess :: URIParser String -pathRootLess = - do { s1 <- segmentNz - ; ss <- many slashSegment - ; return $ concat (s1:ss) - } - -slashSegment :: URIParser String -slashSegment = - do { char '/' - ; s <- segment - ; return ('/':s) - } - -segment :: URIParser String -segment = - do { ps <- many pchar - ; return $ concat ps - } - -segmentNz :: URIParser String -segmentNz = - do { ps <- many1 pchar - ; return $ concat ps - } - -segmentNzc :: URIParser String -segmentNzc = - do { ps <- many1 (uchar "@") - ; return $ concat ps - } - -pchar :: URIParser String -pchar = uchar ":@" - --- helper function for pchar and friends -uchar :: String -> URIParser String -uchar extras = - unreservedChar - <|> escaped - <|> subDelims - <|> do { c <- oneOf extras ; return [c] } - --- RFC3986, section 3.4 - -uquery :: URIParser String -uquery = - do { ss <- many $ uchar (":@"++"/?") - ; return $ '?':concat ss - } - --- RFC3986, section 3.5 - -ufragment :: URIParser String -ufragment = - do { ss <- many $ uchar (":@"++"/?") - ; return $ '#':concat ss - } - --- Reference, Relative and Absolute URI forms --- --- RFC3986, section 4.1 - -uriReference :: URIParser URI -uriReference = uri <|> relativeRef - --- RFC3986, section 4.2 --- --- relative-URI = relative-part [ "?" query ] [ "#" fragment ] --- --- relative-part = "//" authority path-abempty --- / path-abs --- / path-noscheme --- / path-empty - -relativeRef :: URIParser URI -relativeRef = - do { notMatching uscheme - -- ; ua <- option Nothing ( do { try (string "//") ; uauthority } ) - -- ; up <- upath - ; (ua,up) <- relativePart - ; uq <- option "" ( do { char '?' ; uquery } ) - ; uf <- option "" ( do { char '#' ; ufragment } ) - ; return $ URI - { uriScheme = "" - , uriAuthority = ua - , uriPath = up - , uriQuery = uq - , uriFragment = uf - } - } - -relativePart :: URIParser ((Maybe URIAuth),String) -relativePart = - do { try (string "//") - ; ua <- uauthority - ; up <- pathAbEmpty - ; return (ua,up) - } - <|> do { up <- pathAbs - ; return (Nothing,up) - } - <|> do { up <- pathNoScheme - ; return (Nothing,up) - } - <|> do { return (Nothing,"") - } - --- RFC3986, section 4.3 - -absoluteURI :: URIParser URI -absoluteURI = - do { us <- uscheme - -- ; ua <- option Nothing ( do { try (string "//") ; uauthority } ) - -- ; up <- upath - ; (ua,up) <- hierPart - ; uq <- option "" ( do { char '?' ; uquery } ) - ; return $ URI - { uriScheme = us - , uriAuthority = ua - , uriPath = up - , uriQuery = uq - , uriFragment = "" - } - } - --- Imports from RFC 2234 - - -- NOTE: can't use isAlphaNum etc. because these deal with ISO 8859 - -- (and possibly Unicode!) chars. - -- [[[Above was a comment originally in GHC Network/URI.hs: - -- when IRIs are introduced then most codepoints above 128(?) should - -- be treated as unreserved, and higher codepoints for letters should - -- certainly be allowed. - -- ]]] - -isAlphaChar :: Char -> Bool -isAlphaChar c = (c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z') - -isDigitChar :: Char -> Bool -isDigitChar c = (c >= '0' && c <= '9') - -isAlphaNumChar :: Char -> Bool -isAlphaNumChar c = isAlphaChar c || isDigitChar c - -isHexDigitChar :: Char -> Bool -isHexDigitChar c = isHexDigit c - -isSchemeChar :: Char -> Bool -isSchemeChar c = (isAlphaNumChar c) || (c `elem` "+-.") - -alphaChar :: URIParser Char -alphaChar = satisfy isAlphaChar -- or: Parsec.letter ? - -digitChar :: URIParser Char -digitChar = satisfy isDigitChar -- or: Parsec.digit ? - -alphaNumChar :: URIParser Char -alphaNumChar = satisfy isAlphaNumChar - -hexDigitChar :: URIParser Char -hexDigitChar = satisfy isHexDigitChar -- or: Parsec.hexDigit ? - --- Additional parser combinators for common patterns - -oneThenMany :: GenParser t s a -> GenParser t s a -> GenParser t s [a] -oneThenMany p1 pr = - do { a1 <- p1 - ; ar <- many pr - ; return (a1:ar) - } - -countMinMax :: Int -> Int -> GenParser t s a -> GenParser t s [a] -countMinMax m n p | m > 0 = - do { a1 <- p - ; ar <- countMinMax (m-1) (n-1) p - ; return (a1:ar) - } -countMinMax _ n _ | n <= 0 = return [] -countMinMax _ n p = option [] $ - do { a1 <- p - ; ar <- countMinMax 0 (n-1) p - ; return (a1:ar) - } - -notMatching :: Show a => GenParser tok st a -> GenParser tok st () -notMatching p = do { a <- try p ; unexpected (show a) } <|> return () - ------------------------------------------------------------- --- Reconstruct a URI string ------------------------------------------------------------- --- --- |Turn a 'URI' into a string. --- --- Uses a supplied function to map the userinfo part of the URI. --- --- The Show instance for URI uses a mapping that hides any password --- that may be present in the URI. Use this function with argument @id@ --- to preserve the password in the formatted output. --- -uriToString :: (String->String) -> URI -> ShowS -uriToString userinfomap URI { uriScheme=myscheme - , uriAuthority=myauthority - , uriPath=mypath - , uriQuery=myquery - , uriFragment=myfragment - } = - (myscheme++) . (uriAuthToString userinfomap myauthority) - . (mypath++) . (myquery++) . (myfragment++) - -uriAuthToString :: (String->String) -> (Maybe URIAuth) -> ShowS -uriAuthToString _ Nothing = id -- shows "" -uriAuthToString userinfomap - (Just URIAuth { uriUserInfo = myuinfo - , uriRegName = myregname - , uriPort = myport - } ) = - ("//"++) . (if null myuinfo then id else ((userinfomap myuinfo)++)) - . (myregname++) - . (myport++) - ------------------------------------------------------------- --- Character classes ------------------------------------------------------------- - --- | Returns 'True' if the character is allowed in a URI. --- -isAllowedInURI :: Char -> Bool -isAllowedInURI c = isReserved c || isUnreserved c || c == '%' -- escape char - --- | Returns 'True' if the character is allowed unescaped in a URI. --- -isUnescapedInURI :: Char -> Bool -isUnescapedInURI c = isReserved c || isUnreserved c - --- | Returns 'True' if the character is allowed unescaped in a URI component. --- -isUnescapedInURIComponent :: Char -> Bool -isUnescapedInURIComponent c = not (isReserved c || not (isUnescapedInURI c)) - ------------------------------------------------------------- --- Escape sequence handling ------------------------------------------------------------- - --- |Escape character if supplied predicate is not satisfied, --- otherwise return character as singleton string. --- -escapeURIChar :: (Char->Bool) -> Char -> String -escapeURIChar p c - | p c = [c] - | otherwise = concatMap (\i -> '%' : myShowHex i "") (utf8EncodeChar c) - where - myShowHex :: Int -> ShowS - myShowHex n r = case showIntAtBase 16 (toChrHex) n r of - [] -> "00" - [x] -> ['0',x] - cs -> cs - toChrHex d - | d < 10 = chr (ord '0' + fromIntegral d) - | otherwise = chr (ord 'A' + fromIntegral (d - 10)) - --- From http://hackage.haskell.org/package/utf8-string --- by Eric Mertens, BSD3 --- Returns [Int] for use with showIntAtBase -utf8EncodeChar :: Char -> [Int] -utf8EncodeChar = map fromIntegral . go . ord - where - go oc - | oc <= 0x7f = [oc] - - | oc <= 0x7ff = [ 0xc0 + (oc `shiftR` 6) - , 0x80 + oc .&. 0x3f - ] - - | oc <= 0xffff = [ 0xe0 + (oc `shiftR` 12) - , 0x80 + ((oc `shiftR` 6) .&. 0x3f) - , 0x80 + oc .&. 0x3f - ] - | otherwise = [ 0xf0 + (oc `shiftR` 18) - , 0x80 + ((oc `shiftR` 12) .&. 0x3f) - , 0x80 + ((oc `shiftR` 6) .&. 0x3f) - , 0x80 + oc .&. 0x3f - ] - --- |Can be used to make a string valid for use in a URI. --- -escapeURIString - :: (Char->Bool) -- ^ a predicate which returns 'False' - -- if the character should be escaped - -> String -- ^ the string to process - -> String -- ^ the resulting URI string -escapeURIString p s = concatMap (escapeURIChar p) s - --- |Turns all instances of escaped characters in the string back --- into literal characters. --- -unEscapeString :: String -> String -unEscapeString [] = "" -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 ------------------------------------------------------------- - --- |Returns a new 'URI' which represents the value of the --- first 'URI' interpreted as relative to the second 'URI'. --- For example: --- --- > "foo" `relativeTo` "http://bar.org/" = "http://bar.org/foo" --- > "http:foo" `nonStrictRelativeTo` "http://bar.org/" = "http://bar.org/foo" --- --- Algorithm from RFC3986 [3], section 5.2.2 --- - -nonStrictRelativeTo :: URI -> URI -> URI -nonStrictRelativeTo ref base = relativeTo ref' base - where - ref' = if uriScheme ref == uriScheme base - then ref { uriScheme="" } - else ref - -isDefined :: ( MonadPlus m, Eq (m a) ) => m a -> Bool -isDefined a = a /= mzero - --- | Returns a new 'URI' which represents the value of the first 'URI' --- interpreted as relative to the second 'URI'. --- --- Algorithm from RFC3986 [3], section 5.2 -relativeTo :: URI -> URI -> URI -relativeTo ref base - | isDefined ( uriScheme ref ) = - just_segments ref - | isDefined ( uriAuthority ref ) = - just_segments ref { uriScheme = uriScheme base } - | isDefined ( uriPath ref ) = - if (head (uriPath ref) == '/') then - just_segments ref - { uriScheme = uriScheme base - , uriAuthority = uriAuthority base - } - else - just_segments ref - { uriScheme = uriScheme base - , uriAuthority = uriAuthority base - , uriPath = mergePaths base ref - } - | isDefined ( uriQuery ref ) = - just_segments ref - { uriScheme = uriScheme base - , uriAuthority = uriAuthority base - , uriPath = uriPath base - } - | otherwise = - just_segments ref - { uriScheme = uriScheme base - , uriAuthority = uriAuthority base - , uriPath = uriPath base - , uriQuery = uriQuery base - } - where - just_segments u = - u { uriPath = removeDotSegments (uriPath u) } - mergePaths b r - | isDefined (uriAuthority b) && null pb = '/':pr - | otherwise = dropLast pb ++ pr - where - pb = uriPath b - pr = uriPath r - dropLast = fst . splitLast -- reverse . dropWhile (/='/') . reverse - --- Remove dot segments, but protect leading '/' character -removeDotSegments :: String -> String -removeDotSegments ('/':ps) = '/':elimDots ps [] -removeDotSegments ps = elimDots ps [] - --- Second arg accumulates segments processed so far in reverse order -elimDots :: String -> [String] -> String --- elimDots ps rs | traceVal "\nps " ps $ traceVal "rs " rs $ False = error "" -elimDots [] [] = "" -elimDots [] rs = concat (reverse rs) -elimDots ( '.':'/':ps) rs = elimDots ps rs -elimDots ( '.':[] ) rs = elimDots [] rs -elimDots ( '.':'.':'/':ps) rs = elimDots ps (drop 1 rs) -elimDots ( '.':'.':[] ) rs = elimDots [] (drop 1 rs) -elimDots ps rs = elimDots ps1 (r:rs) - where - (r,ps1) = nextSegment ps - --- Returns the next segment and the rest of the path from a path string. --- Each segment ends with the next '/' or the end of string. --- -nextSegment :: String -> (String,String) -nextSegment ps = - case break (=='/') ps of - (r,'/':ps1) -> (r++"/",ps1) - (r,_) -> (r,[]) - --- Split last (name) segment from path, returning (path,name) -splitLast :: String -> (String,String) -splitLast p = (reverse revpath,reverse revname) - where - (revname,revpath) = break (=='/') $ reverse p - ------------------------------------------------------------- --- Finding a URI relative to a base URI ------------------------------------------------------------- - --- |Returns a new 'URI' which represents the relative location of --- the first 'URI' with respect to the second 'URI'. Thus, the --- values supplied are expected to be absolute URIs, and the result --- returned may be a relative URI. --- --- Example: --- --- > "http://example.com/Root/sub1/name2#frag" --- > `relativeFrom` "http://example.com/Root/sub2/name2#frag" --- > == "../sub1/name2#frag" --- --- There is no single correct implementation of this function, --- but any acceptable implementation must satisfy the following: --- --- > (uabs `relativeFrom` ubase) `relativeTo` ubase == uabs --- --- For any valid absolute URI. --- (cf. --- ) --- -relativeFrom :: URI -> URI -> URI -relativeFrom uabs base - | diff uriScheme uabs base = uabs - | diff uriAuthority uabs base = uabs { uriScheme = "" } - | diff uriPath uabs base = uabs - { uriScheme = "" - , uriAuthority = Nothing - , uriPath = relPathFrom (removeBodyDotSegments $ uriPath uabs) - (removeBodyDotSegments $ uriPath base) - } - | diff uriQuery uabs base = uabs - { uriScheme = "" - , uriAuthority = Nothing - , uriPath = "" - } - | otherwise = uabs -- Always carry fragment from uabs - { uriScheme = "" - , uriAuthority = Nothing - , uriPath = "" - , uriQuery = "" - } - where - diff :: Eq b => (a -> b) -> a -> a -> Bool - diff sel u1 u2 = sel u1 /= sel u2 - -- Remove dot segments except the final segment - removeBodyDotSegments p = removeDotSegments p1 ++ p2 - where - (p1,p2) = splitLast p - -relPathFrom :: String -> String -> String -relPathFrom [] _ = "/" -relPathFrom pabs [] = pabs -relPathFrom pabs base = -- Construct a relative path segments - if sa1 == sb1 -- if the paths share a leading segment - then if (sa1 == "/") -- other than a leading '/' - then if (sa2 == sb2) - then relPathFrom1 ra2 rb2 - else pabs - else relPathFrom1 ra1 rb1 - else pabs - where - (sa1,ra1) = nextSegment pabs - (sb1,rb1) = nextSegment base - (sa2,ra2) = nextSegment ra1 - (sb2,rb2) = nextSegment rb1 - --- relPathFrom1 strips off trailing names from the supplied paths, --- and calls difPathFrom to find the relative path from base to --- target -relPathFrom1 :: String -> String -> String -relPathFrom1 pabs base = relName - where - (sa,na) = splitLast pabs - (sb,nb) = splitLast base - rp = relSegsFrom sa sb - relName = if null rp then - if (na == nb) then "" - else if protect na then "./"++na - else na - else - rp++na - -- Precede name with some path if it is null or contains a ':' - protect s = null s || ':' `elem` s - --- relSegsFrom discards any common leading segments from both paths, --- then invokes difSegsFrom to calculate a relative path from the end --- of the base path to the end of the target path. --- The final name is handled separately, so this deals only with --- "directory" segtments. --- -relSegsFrom :: String -> String -> String -{- -relSegsFrom sabs base - | traceVal "\nrelSegsFrom\nsabs " sabs $ traceVal "base " base $ - False = error "" --} -relSegsFrom [] [] = "" -- paths are identical -relSegsFrom sabs base = - if sa1 == sb1 - then relSegsFrom ra1 rb1 - else difSegsFrom sabs base - where - (sa1,ra1) = nextSegment sabs - (sb1,rb1) = nextSegment base - --- difSegsFrom calculates a path difference from base to target, --- not including the final name at the end of the path --- (i.e. results always ends with '/') --- --- This function operates under the invariant that the supplied --- value of sabs is the desired path relative to the beginning of --- base. Thus, when base is empty, the desired path has been found. --- -difSegsFrom :: String -> String -> String -{- -difSegsFrom sabs base - | traceVal "\ndifSegsFrom\nsabs " sabs $ traceVal "base " base $ - False = error "" --} -difSegsFrom sabs "" = sabs -difSegsFrom sabs base = difSegsFrom ("../"++sabs) (snd $ nextSegment base) - ------------------------------------------------------------- --- Other normalization functions ------------------------------------------------------------- - --- |Case normalization; cf. RFC3986 section 6.2.2.1 --- NOTE: authority case normalization is not performed --- -normalizeCase :: String -> String -normalizeCase uristr = ncScheme uristr - where - ncScheme (':':cs) = ':':ncEscape cs - ncScheme (c:cs) | isSchemeChar c = toLower c:ncScheme cs - ncScheme _ = ncEscape uristr -- no scheme present - ncEscape ('%':h1:h2:cs) = '%':toUpper h1:toUpper h2:ncEscape cs - ncEscape (c:cs) = c:ncEscape cs - ncEscape [] = [] - --- |Encoding normalization; cf. RFC3986 section 6.2.2.2 --- -normalizeEscape :: String -> String -normalizeEscape ('%':h1:h2:cs) - | isHexDigit h1 && isHexDigit h2 && isUnreserved escval = - escval:normalizeEscape cs - where - escval = chr (digitToInt h1*16+digitToInt h2) -normalizeEscape (c:cs) = c:normalizeEscape cs -normalizeEscape [] = [] - --- |Path segment normalization; cf. RFC3986 section 6.2.2.4 --- -normalizePathSegments :: String -> String -normalizePathSegments uristr = normstr juri - where - juri = parseURI uristr - normstr Nothing = uristr - normstr (Just u) = show (normuri u) - normuri u = u { uriPath = removeDotSegments (uriPath u) } - ------------------------------------------------------------- --- Local trace helper functions ------------------------------------------------------------- - -traceShow :: Show a => String -> a -> a -traceShow msg x = trace (msg ++ show x) x - -traceVal :: Show a => String -> a -> b -> b -traceVal msg x y = trace (msg ++ show x) y - ------------------------------------------------------------- --- Deprecated functions ------------------------------------------------------------- - -{-# DEPRECATED parseabsoluteURI "use parseAbsoluteURI" #-} -parseabsoluteURI :: String -> Maybe URI -parseabsoluteURI = parseAbsoluteURI - -{-# DEPRECATED escapeString "use escapeURIString, and note the flipped arguments" #-} -escapeString :: String -> (Char->Bool) -> String -escapeString = flip escapeURIString - -{-# DEPRECATED reserved "use isReserved" #-} -reserved :: Char -> Bool -reserved = isReserved - -{-# DEPRECATED unreserved "use isUnreserved" #-} -unreserved :: Char -> Bool -unreserved = isUnreserved - --- Additional component access functions for backward compatibility - -{-# DEPRECATED scheme "use uriScheme" #-} -scheme :: URI -> String -scheme = orNull init . uriScheme - -{-# DEPRECATED authority "use uriAuthority, and note changed functionality" #-} -authority :: URI -> String -authority = dropss . ($"") . uriAuthToString id . uriAuthority - where - -- Old-style authority component does not include leading '//' - dropss ('/':'/':s) = s - dropss s = s - -{-# DEPRECATED path "use uriPath" #-} -path :: URI -> String -path = uriPath - -{-# DEPRECATED query "use uriQuery, and note changed functionality" #-} -query :: URI -> String -query = orNull tail . uriQuery - -{-# DEPRECATED fragment "use uriFragment, and note changed functionality" #-} -fragment :: URI -> String -fragment = orNull tail . uriFragment - -orNull :: ([a]->[a]) -> [a] -> [a] -orNull _ [] = [] -orNull f as = f as - --------------------------------------------------------------------------------- --- --- 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. --- --------------------------------------------------------------------------------- diff --git a/README b/README deleted file mode 100644 --- a/README +++ /dev/null @@ -1,4 +0,0 @@ -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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,8 @@ +# [`network`](http://hackage.haskell.org/package/network) [![Build Status](https://travis-ci.org/haskell/network.svg?branch=master)](https://travis-ci.org/haskell/network) + +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](http://www.gnu.org/software/autoconf/) tools. There is +no need to run the `configure` script: the `setup configure` step will +do this for you. diff --git a/cbits/ancilData.c b/cbits/ancilData.c --- a/cbits/ancilData.c +++ b/cbits/ancilData.c @@ -84,6 +84,7 @@ #else int* fdBuffer; #endif + int fd; iov[0].iov_base = duffBuf; iov[0].iov_len = sizeof(duffBuf); @@ -109,15 +110,23 @@ #endif if ((rc = recvmsg(sock,&msg,0)) < 0) { +#if HAVE_STRUCT_MSGHDR_MSG_CONTROL + free(cmsg); +#else + free(fdBuffer); +#endif return rc; } #if HAVE_STRUCT_MSGHDR_MSG_CONTROL cptr = (struct cmsghdr*)CMSG_FIRSTHDR(&msg); - return *(int*)CMSG_DATA(cptr); + fd = *(int*)CMSG_DATA(cptr); + free(cmsg); #else - return *(int*)fdBuffer; + fd = *(int*)fdBuffer; + free(fdBuffer); #endif + return fd; } #endif diff --git a/network.cabal b/network.cabal --- a/network.cabal +++ b/network.cabal @@ -1,10 +1,31 @@ name: network -version: 2.5.0.0 +version: 2.6.0.0 license: BSD3 license-file: LICENSE maintainer: Johan Tibell synopsis: Low-level networking interface -description: Low-level networking interface +description: + This package provides a low-level networking interface. + . + In network-2.6 the @Network.URI@ module was split off into its own + package, network-uri-2.6. If you're using the @Network.URI@ module + you can automatically get it from the right package by adding this + to your .cabal file: + . + > flag network-uri + > description: Get Network.URI from the network-uri package + > default: True + > + > library + > -- ... + > if flag(network-uri) + > build-depends: network-uri >= 2.6 + > else + > build-depends: network < 2.6 + . + If you want to use other modules from the network package while + using the @Network.URI@ modules from the network-uri package, add a + @network > 2.6@ clause to the first @build-depends@ line. category: Network build-type: Configure cabal-version: >=1.8 @@ -12,7 +33,7 @@ config.log config.status autom4te.cache network.buildinfo include/HsNetworkConfig.h extra-source-files: - README examples/*.hs tests/*.hs config.guess config.sub install-sh + README.md examples/*.hs tests/*.hs config.guess config.sub install-sh configure.ac configure network.buildinfo.in include/HsNetworkConfig.h.in include/HsNet.h -- C sources only used on some systems @@ -29,7 +50,6 @@ Network.Socket.ByteString Network.Socket.ByteString.Lazy Network.Socket.Internal - Network.URI other-modules: Network.Socket.ByteString.Internal Network.Socket.Types @@ -37,12 +57,15 @@ if !os(windows) other-modules: Network.Socket.ByteString.IOVec + Network.Socket.ByteString.Lazy.Posix Network.Socket.ByteString.MsgHdr + if os(windows) + other-modules: + Network.Socket.ByteString.Lazy.Windows build-depends: base >= 3 && < 5, - bytestring, - parsec >= 3.0 + bytestring < 0.11 if !os(windows) build-depends: @@ -54,8 +77,7 @@ includes: HsNet.h install-includes: HsNet.h HsNetworkConfig.h c-sources: cbits/HsNet.c - if impl(ghc >= 6.8) - ghc-options: -fwarn-tabs + ghc-options: -Wall -fwarn-tabs test-suite simple hs-source-dirs: tests @@ -84,19 +106,6 @@ test-framework-hunit ghc-options: -Wall - -test-suite uri - hs-source-dirs: tests - main-is: uri001.hs - type: exitcode-stdio-1.0 - - build-depends: - base < 5, - HUnit, - network, - test-framework, - test-framework-hunit, - test-framework-quickcheck2 source-repository head type: git diff --git a/tests/uri001.hs b/tests/uri001.hs deleted file mode 100644 --- a/tests/uri001.hs +++ /dev/null @@ -1,1431 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-missing-signatures #-} --------------------------------------------------------------------------------- --- $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. --- --- To run this test without using Cabal to build the package --- (2013-01-05, instructions tested on MacOS): --- 1. Install Haskell platform --- 2. cabal install test-framework --- 3. cabal install test-framework-hunit --- 4. ghc -XDeriveDataTypeable -D"MIN_VERSION_base(x,y,z)=1" ../Network/URI.hs uri001.hs --- 5. ./uri001 --- --- Previous build instructions: --- 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 - , uriIsAbsolute, uriIsRelative - , relativeTo, nonStrictRelativeTo - , relativeFrom - , uriToString - , isUnescapedInURIComponent - , isUnescapedInURI, escapeURIString, unEscapeString - , normalizeCase, normalizeEscape, normalizePathSegments - ) - -import Test.HUnit - -import Data.Maybe (fromJust) -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 --- 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 -> Assertion -testEq lab a1 a2 = assertEqual lab a1 a2 - -testURIRef :: URIType -> String -> Assertion -testURIRef t u = sequence_ - [ 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 -> Assertion -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://" --- URIs prefixed with IPv4 addresses -testURIRef118 = testURIRef AbsId "http://192.168.0.1.example.com/" -testURIRef119 = testURIRef AbsId "http://192.168.0.1.example.com./" --- URI prefixed with 3 octets of an IPv4 address and a subdomain part with a leading digit. -testURIRef120 = testURIRef AbsId "http://192.168.0.1test.example.com/" --- URI with IPv(future) address -testURIRef121 = testURIRef AbsId "http://[v9.123.abc;456.def]/" -testURIRef122 = testEq "v.future authority" - (Just (URIAuth "" "[v9.123.abc;456.def]" ":42")) - ((maybe Nothing uriAuthority) . parseURI $ "http://[v9.123.abc;456.def]:42/") --- URI with non-ASCII characters, fail with Network.HTTP escaping code (see below) --- Currently not supported by Network.URI, but captured here for possible future reference --- when IRI support may be added. -testURIRef123 = testURIRef AbsId "http://example.com/test123/䡥汬漬⁗潲汤/index.html" -testURIRef124 = testURIRef AbsId "http://example.com/test124/Москва/index.html" - --- From report by Alexander Ivanov: --- should return " 䡥汬漬⁗潲汤", but returns "Hello, World" instead --- print $ urlDecode $ urlEncode " 䡥汬漬⁗潲汤" --- should return "Москва" --- print $ urlDecode $ urlEncode "Москва" - -testURIRefSuite = TF.testGroup "Test URIrefs" testURIRefList -testURIRefList = - [ TF.testCase "testURIRef001" testURIRef001 - , TF.testCase "testURIRef002" testURIRef002 - , TF.testCase "testURIRef003" testURIRef003 - , TF.testCase "testURIRef004" testURIRef004 - , TF.testCase "testURIRef005" testURIRef005 - , TF.testCase "testURIRef006" testURIRef006 - , TF.testCase "testURIRef007" testURIRef007 - , TF.testCase "testURIRef008" testURIRef008 - , TF.testCase "testURIRef009" testURIRef009 - , TF.testCase "testURIRef010" testURIRef010 - -- - , TF.testCase "testURIRef011" testURIRef011 - , TF.testCase "testURIRef012" testURIRef012 - , TF.testCase "testURIRef013" testURIRef013 - , TF.testCase "testURIRef014" testURIRef014 - , TF.testCase "testURIRef015" testURIRef015 - , TF.testCase "testURIRef016" testURIRef016 - , TF.testCase "testURIRef017" testURIRef017 - , TF.testCase "testURIRef018" testURIRef018 - -- - , TF.testCase "testURIRef019" testURIRef019 - -- - , TF.testCase "testURIRef021" testURIRef021 - , TF.testCase "testURIRef022" testURIRef022 - , TF.testCase "testURIRef023" testURIRef023 - , TF.testCase "testURIRef024" testURIRef024 - , TF.testCase "testURIRef025" testURIRef025 - , TF.testCase "testURIRef026" testURIRef026 - , TF.testCase "testURIRef027" testURIRef027 - , TF.testCase "testURIRef028" testURIRef028 - , TF.testCase "testURIRef029" testURIRef029 - -- - , TF.testCase "testURIRef031" testURIRef031 - , TF.testCase "testURIRef032" testURIRef032 - , TF.testCase "testURIRef033" testURIRef033 - , TF.testCase "testURIRef034" testURIRef034 - , TF.testCase "testURIRef035" testURIRef035 - , TF.testCase "testURIRef036" testURIRef036 - , TF.testCase "testURIRef037" testURIRef037 - , TF.testCase "testURIRef038" testURIRef038 - , TF.testCase "testURIRef039" testURIRef039 - , TF.testCase "testURIRef040" testURIRef040 - , TF.testCase "testURIRef041" testURIRef041 - , TF.testCase "testURIRef042" testURIRef042 - , TF.testCase "testURIRef043" testURIRef043 - , TF.testCase "testURIRef044" testURIRef044 - , TF.testCase "testURIRef045" testURIRef045 - , TF.testCase "testURIRef046" testURIRef046 - , TF.testCase "testURIRef047" testURIRef047 - , TF.testCase "testURIRef048" testURIRef048 - , TF.testCase "testURIRef049" testURIRef049 - , TF.testCase "testURIRef050" testURIRef050 - , TF.testCase "testURIRef051" testURIRef051 - , TF.testCase "testURIRef052" testURIRef052 - , TF.testCase "testURIRef053" testURIRef053 - , TF.testCase "testURIRef054" testURIRef054 - , TF.testCase "testURIRef055" testURIRef055 - , TF.testCase "testURIRef056" testURIRef056 - , TF.testCase "testURIRef057" testURIRef057 - , TF.testCase "testURIRef058" testURIRef058 - , TF.testCase "testURIRef059" testURIRef059 - , TF.testCase "testURIRef060" testURIRef060 - , TF.testCase "testURIRef061" testURIRef061 - , TF.testCase "testURIRef062" testURIRef062 - , TF.testCase "testURIRef063" testURIRef063 - , TF.testCase "testURIRef064" testURIRef064 - , TF.testCase "testURIRef065" testURIRef065 - , TF.testCase "testURIRef066" testURIRef066 - , TF.testCase "testURIRef067" testURIRef067 - , TF.testCase "testURIRef068" testURIRef068 - , TF.testCase "testURIRef069" testURIRef069 - , TF.testCase "testURIRef070" testURIRef070 - , TF.testCase "testURIRef071" testURIRef071 - , TF.testCase "testURIRef072" testURIRef072 - , TF.testCase "testURIRef073" testURIRef073 - , TF.testCase "testURIRef074" testURIRef074 - , TF.testCase "testURIRef075" testURIRef075 - , TF.testCase "testURIRef076" testURIRef076 - , TF.testCase "testURIRef077" testURIRef077 - -- - , TF.testCase "testURIRef080" testURIRef080 - , TF.testCase "testURIRef081" testURIRef081 - , TF.testCase "testURIRef082" testURIRef082 - , TF.testCase "testURIRef083" testURIRef083 - , TF.testCase "testURIRef084" testURIRef084 - , TF.testCase "testURIRef085" testURIRef085 - , TF.testCase "testURIRef086" testURIRef086 - , TF.testCase "testURIRef087" testURIRef087 - -- testURIRef088, - -- testURIRef089, - , TF.testCase "testURIRef090" testURIRef090 - , TF.testCase "testURIRef091" testURIRef091 - , TF.testCase "testURIRef092" testURIRef092 - , TF.testCase "testURIRef093" testURIRef093 - , TF.testCase "testURIRef094" testURIRef094 - , TF.testCase "testURIRef095" testURIRef095 - , TF.testCase "testURIRef096" testURIRef096 - , TF.testCase "testURIRef097" testURIRef097 - , TF.testCase "testURIRef098" testURIRef098 - -- testURIRef099, - -- - , TF.testCase "testURIRef101" testURIRef101 - , TF.testCase "testURIRef102" testURIRef102 - , TF.testCase "testURIRef103" testURIRef103 - , TF.testCase "testURIRef104" testURIRef104 - , TF.testCase "testURIRef105" testURIRef105 - , TF.testCase "testURIRef106" testURIRef106 - , TF.testCase "testURIRef107" testURIRef107 - , TF.testCase "testURIRef108" testURIRef108 - -- - , TF.testCase "testURIRef111" testURIRef111 - , TF.testCase "testURIRef112" testURIRef112 - , TF.testCase "testURIRef113" testURIRef113 - , TF.testCase "testURIRef114" testURIRef114 - , TF.testCase "testURIRef115" testURIRef115 - , TF.testCase "testURIRef116" testURIRef116 - , TF.testCase "testURIRef117" testURIRef117 - -- - , TF.testCase "testURIRef118" testURIRef118 - , TF.testCase "testURIRef119" testURIRef119 - , TF.testCase "testURIRef120" testURIRef120 - -- - , TF.testCase "testURIRef121" testURIRef121 - , TF.testCase "testURIRef122" testURIRef122 - -- IRI test cases not currently supported - -- , TF.testCase "testURIRef123" testURIRef123 - -- , TF.testCase "testURIRef124" testURIRef124 - ] - --- 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 = TF.testGroup "Test URIrefs" $ - [ TF.testCase "testComponent01" testComponent01 - , TF.testCase "testComponent02" testComponent02 - , TF.testCase "testComponent03" testComponent03 - , TF.testCase "testComponent04" testComponent04 - , TF.testCase "testComponent11" testComponent11 - , TF.testCase "testComponent12" 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 -> Assertion -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 -> Assertion -testRelJoin label base urel uabs = - testEq label uabs (mkabs purel pubas) - where - mkabs (Just u1) (Just u2) = show (u1 `relativeTo` u2) - mkabs Nothing _ = "Invalid URI: "++urel - mkabs _ Nothing = "Invalid URI: "++uabs - purel = parseURIReference urel - pubas = parseURIReference base - -testRelative :: String -> String -> String -> String -> Assertion -testRelative label base uabs urel = sequence_ - [ - (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 = TF.testGroup "Test Relative URIs" testRelativeList -testRelativeList = - [ TF.testCase "testRelative01" testRelative01 - , TF.testCase "testRelative02" testRelative02 - , TF.testCase "testRelative03" testRelative03 - , TF.testCase "testRelative04" testRelative04 - , TF.testCase "testRelative05" testRelative05 - , TF.testCase "testRelative06" testRelative06 - , TF.testCase "testRelative07" testRelative07 - , TF.testCase "testRelative08" testRelative08 - , TF.testCase "testRelative09" testRelative09 - , TF.testCase "testRelative10" testRelative10 - , TF.testCase "testRelative11" testRelative11 - , TF.testCase "testRelative12" testRelative12 - , TF.testCase "testRelative13" testRelative13 - , TF.testCase "testRelative14" testRelative14 - , TF.testCase "testRelative15" testRelative15 - , TF.testCase "testRelative16" testRelative16 - , TF.testCase "testRelative17" testRelative17 - , TF.testCase "testRelative18" testRelative18 - , TF.testCase "testRelative19" testRelative19 - , TF.testCase "testRelative20" testRelative20 - , TF.testCase "testRelative21" testRelative21 - , TF.testCase "testRelative22" testRelative22 - , TF.testCase "testRelative23" testRelative23 - , TF.testCase "testRelative24" testRelative24 - , TF.testCase "testRelative25" testRelative25 - , TF.testCase "testRelative26" testRelative26 - , TF.testCase "testRelative27" testRelative27 - , TF.testCase "testRelative28" testRelative28 - , TF.testCase "testRelative29" testRelative29 - , TF.testCase "testRelative30" testRelative30 - , TF.testCase "testRelative31" testRelative31 - , TF.testCase "testRelative32" testRelative32 - , TF.testCase "testRelative33" testRelative33 - , TF.testCase "testRelative34" testRelative34 - , TF.testCase "testRelative35" testRelative35 - , TF.testCase "testRelative36" testRelative36 - , TF.testCase "testRelative37" testRelative37 - , TF.testCase "testRelative38" testRelative38 - , TF.testCase "testRelative39" testRelative39 - , TF.testCase "testRelative40" testRelative40 - , TF.testCase "testRelative41" testRelative41 - , TF.testCase "testRelative42" testRelative42 - , TF.testCase "testRelative43" testRelative43 - , TF.testCase "testRelative44" testRelative44 - , TF.testCase "testRelative45" testRelative45 - , TF.testCase "testRelative46" testRelative46 - , TF.testCase "testRelative47" testRelative47 - , TF.testCase "testRelative48" testRelative48 - , TF.testCase "testRelative49" testRelative49 - -- - , TF.testCase "testRelative50" testRelative50 - , TF.testCase "testRelative51" testRelative51 - , TF.testCase "testRelative52" testRelative52 - , TF.testCase "testRelative53" testRelative53 - , TF.testCase "testRelative54" testRelative54 - , TF.testCase "testRelative55" testRelative55 - , TF.testCase "testRelative56" testRelative56 - , TF.testCase "testRelative57" testRelative57 - -- - , TF.testCase "testRelative60" testRelative60 - , TF.testCase "testRelative61" testRelative61 - , TF.testCase "testRelative62" testRelative62 - , TF.testCase "testRelative63" testRelative63 - , TF.testCase "testRelative64" testRelative64 - , TF.testCase "testRelative65" testRelative65 - -- - , TF.testCase "testRelative70" testRelative70 - , TF.testCase "testRelative71" testRelative71 - , TF.testCase "testRelative72" testRelative72 - , TF.testCase "testRelative73" testRelative73 - , TF.testCase "testRelative74" testRelative74 - , TF.testCase "testRelative75" testRelative75 - , TF.testCase "testRelative76" testRelative76 - , TF.testCase "testRelative77" testRelative77 - -- Awkward cases: - , TF.testCase "testRelative78" testRelative78 - , TF.testCase "testRelative79" testRelative79 - , TF.testCase "testRelative80" testRelative80 - , TF.testCase "testRelative81" testRelative81 - -- - -- , TF.testCase "testRelative90" testRelative90 - , TF.testCase "testRelative91" testRelative91 - , TF.testCase "testRelative92" testRelative92 - , TF.testCase "testRelative93" testRelative93 - , TF.testCase "testRelative94" testRelative94 - , TF.testCase "testRelative95" testRelative95 - , TF.testCase "testRelative96" testRelative96 - , TF.testCase "testRelative97" testRelative97 - , TF.testCase "testRelative98" testRelative98 - , TF.testCase "testRelative99" 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 = TF.testGroup "Test RFC2396 examples" testRFC2396List -testRFC2396List = - [ TF.testCase "testRFC01" testRFC01 - , TF.testCase "testRFC02" testRFC02 - , TF.testCase "testRFC03" testRFC03 - , TF.testCase "testRFC04" testRFC04 - , TF.testCase "testRFC05" testRFC05 - , TF.testCase "testRFC06" testRFC06 - , TF.testCase "testRFC07" testRFC07 - , TF.testCase "testRFC08" testRFC08 - , TF.testCase "testRFC09" testRFC09 - , TF.testCase "testRFC10" testRFC10 - , TF.testCase "testRFC11" testRFC11 - , TF.testCase "testRFC12" testRFC12 - , TF.testCase "testRFC13" testRFC13 - , TF.testCase "testRFC14" testRFC14 - , TF.testCase "testRFC15" testRFC15 - , TF.testCase "testRFC16" testRFC16 - , TF.testCase "testRFC17" testRFC17 - , TF.testCase "testRFC18" testRFC18 - , TF.testCase "testRFC19" testRFC19 - , TF.testCase "testRFC20" testRFC20 - , TF.testCase "testRFC21" testRFC21 - , TF.testCase "testRFC22" testRFC22 - , TF.testCase "testRFC23" testRFC23 - , TF.testCase "testRFC24" testRFC24 - -- testRFC30, - , TF.testCase "testRFC31" testRFC31 - , TF.testCase "testRFC32" testRFC32 - , TF.testCase "testRFC33" testRFC33 - , TF.testCase "testRFC34" testRFC34 - , TF.testCase "testRFC35" testRFC35 - , TF.testCase "testRFC36" testRFC36 - , TF.testCase "testRFC37" testRFC37 - , TF.testCase "testRFC38" testRFC38 - , TF.testCase "testRFC39" testRFC39 - , TF.testCase "testRFC40" testRFC40 - , TF.testCase "testRFC41" testRFC41 - , TF.testCase "testRFC42" testRFC42 - , TF.testCase "testRFC43" testRFC43 - , TF.testCase "testRFC44" testRFC44 - , TF.testCase "testRFC45" testRFC45 - , TF.testCase "testRFC46" testRFC46 - , TF.testCase "testRFC47" testRFC47 - , TF.testCase "testRFC48" testRFC48 - , TF.testCase "testRFC49" testRFC49 - , TF.testCase "testRFC50" testRFC50 - -- - , TF.testCase "testRFC60" testRFC60 - , TF.testCase "testRFC61" testRFC61 - , TF.testCase "testRFC62" testRFC62 - , TF.testCase "testRFC63" testRFC63 - , TF.testCase "testRFC64" testRFC64 - , TF.testCase "testRFC65" testRFC65 - , TF.testCase "testRFC66" testRFC66 - , TF.testCase "testRFC67" testRFC67 - , TF.testCase "testRFC68" testRFC68 - , TF.testCase "testRFC69" testRFC69 - , TF.testCase "testRFC70" 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 = TF.testGroup "Test oddball examples" testOddballList -testOddballList = - [ TF.testCase "testMail01" testMail01 - , TF.testCase "testMail02" testMail02 - , TF.testCase "testMail03" testMail03 - , TF.testCase "testMail11" testMail11 - , TF.testCase "testMail12" testMail12 - , TF.testCase "testMail13" testMail13 - , TF.testCase "testMail14" testMail14 - , TF.testCase "testMail15" testMail15 - , TF.testCase "testMail16" testMail16 - , TF.testCase "testInfo17" 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 = TF.testGroup "testNormalizeSuite" - [ TF.testCase "testNormalize01" testNormalize01 - , TF.testCase "testNormalize11" testNormalize11 - , TF.testCase "testNormalize12" testNormalize12 - , TF.testCase "testNormalize13" testNormalize13 - , TF.testCase "testNormalize21" testNormalize21 - , TF.testCase "testNormalize22" testNormalize22 - , TF.testCase "testNormalize23" testNormalize23 - , TF.testCase "testNormalize24" testNormalize24 - , TF.testCase "testNormalize25" testNormalize25 - , TF.testCase "testNormalize26" testNormalize26 - , TF.testCase "testNormalize27" testNormalize27 - , TF.testCase "testNormalize28" 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 = TF.testGroup "testShowURI" - [ TF.testCase "testShowURI01" testShowURI01 - , TF.testCase "testShowURI02" testShowURI02 - , TF.testCase "testShowURI03" testShowURI03 - , TF.testCase "testShowURI04" 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) - -testEscapeURIString05 = testEq "testEscapeURIString05" - "http%3A%2F%2Fexample.org%2Faz%2F09-_%2F.~%3A%2F%3F%23%5B%5D%40%21%24%26%27%28%29%2A%2B%2C%3B%3D" - (escapeURIString isUnescapedInURIComponent te01str) - -testEscapeURIString06 = testEq "testEscapeURIString06" - "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 - , TF.testCase "testEscapeURIString03" testEscapeURIString03 - , TF.testCase "testEscapeURIString04" testEscapeURIString04 - , TF.testCase "testEscapeURIString05" testEscapeURIString05 - , TF.testCase "testEscapeURIString06" testEscapeURIString06 - , TF.testProperty "propEscapeUnEscapeLoop" propEscapeUnEscapeLoop - ] - --- 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 = TF.testGroup "testNormalizeURIString" - [ TF.testCase "testNormalizeURIString01" testNormalizeURIString01 - , TF.testCase "testNormalizeURIString02" testNormalizeURIString02 - , TF.testCase "testNormalizeURIString03" testNormalizeURIString03 - , TF.testCase "testNormalizeURIString04" testNormalizeURIString04 - , TF.testCase "testNormalizeURIString05" testNormalizeURIString05 - , TF.testCase "testNormalizeURIString06" testNormalizeURIString06 - , TF.testCase "testNormalizeURIString07" testNormalizeURIString07 - ] - --- Test strict vs non-strict relativeTo logic - -trbase = fromJust $ parseURIReference "http://bar.org/" - -testRelativeTo01 = testEq "testRelativeTo01" - "http://bar.org/foo" - (show $ - (fromJust $ parseURIReference "foo") `relativeTo` trbase) - -testRelativeTo02 = testEq "testRelativeTo02" - "http:foo" - (show $ - (fromJust $ parseURIReference "http:foo") `relativeTo` trbase) - -testRelativeTo03 = testEq "testRelativeTo03" - "http://bar.org/foo" - (show $ - (fromJust $ parseURIReference "http:foo") `nonStrictRelativeTo` trbase) - -testRelativeTo = TF.testGroup "testRelativeTo" - [ TF.testCase "testRelativeTo01" testRelativeTo01 - , TF.testCase "testRelativeTo02" testRelativeTo02 - , TF.testCase "testRelativeTo03" 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 = TF.testGroup "testAltFn" - [ TF.testCase "testAltFn01" testAltFn01 - , TF.testCase "testAltFn02" testAltFn02 - , TF.testCase "testAltFn03" testAltFn03 - , TF.testCase "testAltFn04" testAltFn04 - , TF.testCase "testAltFn05" testAltFn05 - , TF.testCase "testAltFn06" testAltFn06 - , TF.testCase "testAltFn07" testAltFn07 - , TF.testCase "testAltFn08" testAltFn08 - , TF.testCase "testAltFn11" testAltFn11 - , TF.testCase "testAltFn12" testAltFn12 - , TF.testCase "testAltFn13" testAltFn13 - , TF.testCase "testAltFn14" testAltFn14 - , TF.testCase "testAltFn15" testAltFn15 - , TF.testCase "testAltFn16" testAltFn16 - , TF.testCase "testAltFn17" testAltFn17 - ] - -testUriIsAbsolute :: String -> Assertion -testUriIsAbsolute str = - assertBool str (uriIsAbsolute uri) - where - Just uri = parseURIReference str - -testUriIsRelative :: String -> Assertion -testUriIsRelative str = - assertBool str (uriIsRelative uri) - where - Just uri = parseURIReference str - -testIsAbsolute = TF.testGroup "testIsAbsolute" - [ TF.testCase "testIsAbsolute01" $ testUriIsAbsolute "http://google.com" - , TF.testCase "testIsAbsolute02" $ testUriIsAbsolute "ftp://p.x.ca/woo?hai=a" - , TF.testCase "testIsAbsolute03" $ testUriIsAbsolute "mailto:bob@example.com" - ] - -testIsRelative = TF.testGroup "testIsRelative" - [ TF.testCase "testIsRelative01" $ testUriIsRelative "//google.com" - , TF.testCase "testIsRelative02" $ testUriIsRelative "/hello" - , TF.testCase "testIsRelative03" $ testUriIsRelative "this/is/a/path" - , TF.testCase "testIsRelative04" $ testUriIsRelative "?what=that" - ] - --- Full test suite -allTests = - [ testURIRefSuite - , testComponentSuite - , testRelativeSuite - , testRFC2396Suite - , testOddballSuite - , testNormalizeSuite - , testShowURI - , testEscapeURIString - , testNormalizeURIString - , testRelativeTo - , testAltFn - , testIsAbsolute - , testIsRelative - ] - -main = TF.defaultMain 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.81 2012/08/01 aaronfriel --- Added additional test case for the "xip.io" service style URLs and absolute URLs prefixed with ipv4 addresses. --- --- 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. ---