summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGaneshSittampalam <>2019-03-17 11:47:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2019-03-17 11:47:00 (GMT)
commit088efc4bc1a0dcea3001313ba247d8a04b29a04a (patch)
tree59b4c3856dc5d9ec4e038c89fa5cc601e443e333
parent4a4c264713f0070f9a3708538ddc0a335bbc5576 (diff)
version 4000.3.134000.3.13
-rw-r--r--HTTP.cabal20
-rw-r--r--Network/HTTP/Base.hs2
-rw-r--r--Network/HTTP/Proxy.hs12
-rw-r--r--Network/HTTP/Utils.hs96
-rw-r--r--Network/StreamSocket.hs12
-rw-r--r--Network/TCP.hs8
6 files changed, 130 insertions, 20 deletions
diff --git a/HTTP.cabal b/HTTP.cabal
index e156d97..4a2c50d 100644
--- 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 @@ Description:
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 conduit10
Flag warp-tests
description: Test against warp
- default: True
+ default: False
manual: True
flag network-uri
@@ -109,7 +109,7 @@ Library
-- 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 @@ Library
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 @@ Test-Suite test
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
index 72939de..3a4a0d2 100644
--- a/Network/HTTP/Base.hs
+++ b/Network/HTTP/Base.hs
@@ -107,7 +107,7 @@ import Network.URI
)
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
index af82751..e7a5f6a 100644
--- a/Network/HTTP/Proxy.hs
+++ b/Network/HTTP/Proxy.hs
@@ -47,9 +47,15 @@ import System.Environment
#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
@@ -103,7 +109,9 @@ registryProxyString = catchIO
(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
index 3cf00ad..7a5dcce 100644
--- a/Network/HTTP/Utils.hs
+++ b/Network/HTTP/Utils.hs
@@ -27,11 +27,17 @@ module Network.HTTP.Utils
, 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
@@ -109,3 +115,93 @@ chopAtDelim elt xs =
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
index f619e4d..42bdaf5 100644
--- a/Network/StreamSocket.hs
+++ b/Network/StreamSocket.hs
@@ -29,11 +29,15 @@ import Network.Stream
( 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 @@ handleSocketError sk e =
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 @@ instance Stream Socket where
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 :: Socket -> String -> IO (Result ())
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
index 8d8a0e3..6f20319 100644
--- a/Network/TCP.hs
+++ b/Network/TCP.hs
@@ -38,11 +38,13 @@ import Network.Socket
( 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 @@ openTCPConnection_ uri port stashInput = do
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 @@ closeConnection ref readL = do
suck readL
hClose (connHandle conn)
shutdown sk ShutdownReceive
- sClose sk
+ Network.Socket.close sk
suck :: IO Bool -> IO ()
suck rd = do