diff --git a/HTTP.cabal b/HTTP.cabal --- a/HTTP.cabal +++ b/HTTP.cabal @@ -1,5 +1,5 @@ Name: HTTP -Version: 4000.3.12 +Version: 4000.3.13 Cabal-Version: >= 1.8 Build-type: Simple License: BSD3 @@ -56,7 +56,7 @@ Extra-Source-Files: CHANGES -tested-with: GHC==8.4.1, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2, GHC==7.2.2, GHC==7.0.4 +tested-with: GHC==8.6.3, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2, GHC==7.2.2, GHC==7.0.4 Source-Repository head type: git @@ -77,7 +77,7 @@ Flag warp-tests description: Test against warp - default: True + default: False manual: True flag network-uri @@ -109,7 +109,7 @@ -- note the test harness constraints should be kept in sync with these -- where dependencies are shared - Build-depends: base >= 4.3.0.0 && < 4.12, parsec >= 2.0 && < 3.2 + Build-depends: base >= 4.3.0.0 && < 4.13, parsec >= 2.0 && < 3.2 Build-depends: array >= 0.3.0.2 && < 0.6, bytestring >= 0.9.1.5 && < 0.11 Build-depends: time >= 1.1.2.3 && < 1.10 @@ -122,15 +122,15 @@ Build-depends: mtl >= 2.0 && < 2.3 if flag(network-uri) - Build-depends: network-uri == 2.6.*, network >= 2.6 && < 2.8 + Build-depends: network-uri == 2.6.*, network >= 2.6 && < 3.1 else - Build-depends: network >= 2.2.1.8 && < 2.6 + Build-depends: network >= 2.4 && < 2.6 if flag(warn-as-error) ghc-options: -Werror if os(windows) - Build-depends: Win32 >= 2.2.0.0 && < 2.8 + Build-depends: Win32 >= 2.2.0.0 && < 2.9 Test-Suite test type: exitcode-stdio-1.0 @@ -151,15 +151,15 @@ bytestring >= 0.9.1.5 && < 0.11, deepseq >= 1.3.0.0 && < 1.5, pureMD5 >= 0.2.4 && < 2.2, - base >= 4.3.0.0 && < 4.12, + base >= 4.3.0.0 && < 4.13, split >= 0.1.3 && < 0.3, test-framework >= 0.2.0 && < 0.9, test-framework-hunit >= 0.3.0 && <0.4 if flag(network-uri) - Build-depends: network-uri == 2.6.*, network >= 2.6 && < 2.8 + Build-depends: network-uri == 2.6.*, network >= 2.6 && < 3.1 else - Build-depends: network >= 2.2.1.5 && < 2.6 + Build-depends: network >= 2.3 && < 2.6 if flag(warp-tests) CPP-Options: -DWARP_TESTS diff --git a/Network/HTTP/Base.hs b/Network/HTTP/Base.hs --- a/Network/HTTP/Base.hs +++ b/Network/HTTP/Base.hs @@ -107,7 +107,7 @@ ) import Control.Monad ( guard ) -import Control.Monad.Error () +import Control.Monad.Error.Class () import Data.Bits ( (.&.), (.|.), shiftL, shiftR ) import Data.Word ( Word8 ) import Data.Char ( digitToInt, intToDigit, toLower, isDigit, diff --git a/Network/HTTP/Proxy.hs b/Network/HTTP/Proxy.hs --- a/Network/HTTP/Proxy.hs +++ b/Network/HTTP/Proxy.hs @@ -47,10 +47,16 @@ #if defined(WIN32) import System.Win32.Types ( DWORD, HKEY ) -import System.Win32.Registry( hKEY_CURRENT_USER, regOpenKey, regCloseKey, regQueryValue, regQueryValueEx ) +import System.Win32.Registry( hKEY_CURRENT_USER, regOpenKey, regCloseKey, regQueryValueEx ) import Control.Exception ( bracket ) import Foreign ( toBool, Storable(peek, sizeOf), castPtr, alloca ) + +#if MIN_VERSION_Win32(2,8,0) +import System.Win32.Registry( regQueryDefaultValue ) +#else +import System.Win32.Registry( regQueryValue ) #endif +#endif -- | HTTP proxies (or not) are represented via 'Proxy', specifying if a -- proxy should be used for the request (see 'Network.Browser.setProxy') @@ -103,7 +109,9 @@ (bracket (uncurry regOpenKey registryProxyLoc) regCloseKey $ \hkey -> do enable <- fmap toBool $ regQueryValueDWORD hkey "ProxyEnable" if enable -#if MIN_VERSION_Win32(2,6,0) +#if MIN_VERSION_Win32(2,8,0) + then fmap Just $ regQueryDefaultValue hkey "ProxyServer" +#elif MIN_VERSION_Win32(2,6,0) then fmap Just $ regQueryValue hkey "ProxyServer" #else then fmap Just $ regQueryValue hkey (Just "ProxyServer") diff --git a/Network/HTTP/Utils.hs b/Network/HTTP/Utils.hs --- a/Network/HTTP/Utils.hs +++ b/Network/HTTP/Utils.hs @@ -27,12 +27,18 @@ , dropWhileTail -- :: (a -> Bool) -> [a] -> [a] , chopAtDelim -- :: Eq a => a -> [a] -> ([a],[a]) + , toUTF8BS + , fromUTF8BS ) where +import Data.Bits import Data.Char import Data.List ( elemIndex ) import Data.Maybe ( fromMaybe ) +import Data.Word ( Word8 ) +import qualified Data.ByteString as BS + -- | @crlf@ is our beloved two-char line terminator. crlf :: String crlf = "\r\n" @@ -109,3 +115,93 @@ case break (==elt) xs of (_,[]) -> (xs,[]) (as,_:bs) -> (as,bs) + +toUTF8BS :: String -> BS.ByteString +toUTF8BS = BS.pack . encodeStringUtf8 + +fromUTF8BS :: BS.ByteString -> String +fromUTF8BS = decodeStringUtf8 . BS.unpack + +-- | Encode 'String' to a list of UTF8-encoded octets +-- +-- Code-points in the @U+D800@-@U+DFFF@ range will be encoded +-- as the replacement character (i.e. @U+FFFD@). +-- +-- The code is extracted from Cabal library, written originally +-- Herbert Valerio Riedel under BSD-3-Clause license +encodeStringUtf8 :: String -> [Word8] +encodeStringUtf8 [] = [] +encodeStringUtf8 (c:cs) + | c <= '\x07F' = w8 + : encodeStringUtf8 cs + | c <= '\x7FF' = (0xC0 .|. w8ShiftR 6 ) + : (0x80 .|. (w8 .&. 0x3F)) + : encodeStringUtf8 cs + | c <= '\xD7FF'= (0xE0 .|. w8ShiftR 12 ) + : (0x80 .|. (w8ShiftR 6 .&. 0x3F)) + : (0x80 .|. (w8 .&. 0x3F)) + : encodeStringUtf8 cs + | c <= '\xDFFF'= 0xEF : 0xBF : 0xBD -- U+FFFD + : encodeStringUtf8 cs + | c <= '\xFFFF'= (0xE0 .|. w8ShiftR 12 ) + : (0x80 .|. (w8ShiftR 6 .&. 0x3F)) + : (0x80 .|. (w8 .&. 0x3F)) + : encodeStringUtf8 cs + | otherwise = (0xf0 .|. w8ShiftR 18 ) + : (0x80 .|. (w8ShiftR 12 .&. 0x3F)) + : (0x80 .|. (w8ShiftR 6 .&. 0x3F)) + : (0x80 .|. (w8 .&. 0x3F)) + : encodeStringUtf8 cs + where + w8 = fromIntegral (ord c) :: Word8 + w8ShiftR :: Int -> Word8 + w8ShiftR = fromIntegral . shiftR (ord c) + +-- | Decode 'String' from UTF8-encoded octets. +-- +-- Invalid data in the UTF8 stream (this includes code-points @U+D800@ +-- through @U+DFFF@) will be decoded as the replacement character (@U+FFFD@). +-- +-- See also 'encodeStringUtf8' +decodeStringUtf8 :: [Word8] -> String +decodeStringUtf8 = go + where + go :: [Word8] -> String + go [] = [] + go (c : cs) + | c <= 0x7F = chr (fromIntegral c) : go cs + | c <= 0xBF = replacementChar : go cs + | c <= 0xDF = twoBytes c cs + | c <= 0xEF = moreBytes 3 0x800 cs (fromIntegral $ c .&. 0xF) + | c <= 0xF7 = moreBytes 4 0x10000 cs (fromIntegral $ c .&. 0x7) + | c <= 0xFB = moreBytes 5 0x200000 cs (fromIntegral $ c .&. 0x3) + | c <= 0xFD = moreBytes 6 0x4000000 cs (fromIntegral $ c .&. 0x1) + | otherwise = replacementChar : go cs + + twoBytes :: Word8 -> [Word8] -> String + twoBytes c0 (c1:cs') + | c1 .&. 0xC0 == 0x80 + = let d = (fromIntegral (c0 .&. 0x1F) `shiftL` 6) + .|. fromIntegral (c1 .&. 0x3F) + in if d >= 0x80 + then chr d : go cs' + else replacementChar : go cs' + twoBytes _ cs' = replacementChar : go cs' + + moreBytes :: Int -> Int -> [Word8] -> Int -> [Char] + moreBytes 1 overlong cs' acc + | overlong <= acc && acc <= 0x10FFFF && (acc < 0xD800 || 0xDFFF < acc) + = chr acc : go cs' + + | otherwise + = replacementChar : go cs' + + moreBytes byteCount overlong (cn:cs') acc + | cn .&. 0xC0 == 0x80 + = moreBytes (byteCount-1) overlong cs' + ((acc `shiftL` 6) .|. fromIntegral cn .&. 0x3F) + + moreBytes _ _ cs' _ + = replacementChar : go cs' + + replacementChar = '\xfffd' diff --git a/Network/StreamSocket.hs b/Network/StreamSocket.hs --- a/Network/StreamSocket.hs +++ b/Network/StreamSocket.hs @@ -29,11 +29,15 @@ ( Stream(..), ConnError(ErrorReset, ErrorMisc), Result ) import Network.Socket - ( Socket, getSocketOption, shutdown, send, recv, sClose + ( Socket, getSocketOption, shutdown , ShutdownCmd(ShutdownBoth), SocketOption(SoError) ) +import Network.Socket.ByteString (send, recv) +import qualified Network.Socket + ( close ) import Network.HTTP.Base ( catchIO ) +import Network.HTTP.Utils ( fromUTF8BS, toUTF8BS ) import Control.Monad (liftM) import Control.Exception as Exception (IOException) import System.IO.Error (isEOFError) @@ -50,7 +54,7 @@ myrecv :: Socket -> Int -> IO String myrecv sock len = let handler e = if isEOFError e then return [] else ioError e - in catchIO (recv sock len) handler + in catchIO (fmap fromUTF8BS (recv sock len)) handler instance Stream Socket where readBlock sk n = readBlockSocket sk n @@ -59,7 +63,7 @@ close sk = do -- This slams closed the connection (which is considered rude for TCP\/IP) shutdown sk ShutdownBoth - sClose sk + Network.Socket.close sk closeOnEnd _sk _ = return () -- can't really deal with this, so do run the risk of leaking sockets here. readBlockSocket :: Socket -> Int -> IO (Result String) @@ -89,5 +93,5 @@ writeBlockSocket sk str = (liftM Right $ fn str) `catchIO` (handleSocketError sk) where fn [] = return () - fn x = send sk x >>= \i -> fn (drop i x) + fn x = send sk (toUTF8BS x) >>= \i -> fn (drop i x) diff --git a/Network/TCP.hs b/Network/TCP.hs --- a/Network/TCP.hs +++ b/Network/TCP.hs @@ -38,11 +38,13 @@ ( Socket, SocketOption(KeepAlive) , SocketType(Stream), connect , shutdown, ShutdownCmd(..) - , sClose, setSocketOption, getPeerName + , setSocketOption, getPeerName , socket, Family(AF_UNSPEC), defaultProtocol, getAddrInfo , defaultHints, addrFamily, withSocketsDo , addrSocketType, addrAddress ) +import qualified Network.Socket + ( close ) import qualified Network.Stream as Stream ( Stream(readBlock, readLine, writeBlock, close, closeOnEnd) ) import Network.Stream @@ -242,7 +244,7 @@ setSocketOption s KeepAlive 1 connect s (addrAddress a) socketConnection_ fixedUri port s stashInput - ) (sClose s) + ) (Network.Socket.close s) -- | @socketConnection@, like @openConnection@ but using a pre-existing 'Socket'. socketConnection :: BufferType ty @@ -295,7 +297,7 @@ suck readL hClose (connHandle conn) shutdown sk ShutdownReceive - sClose sk + Network.Socket.close sk suck :: IO Bool -> IO () suck rd = do