diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,7 +1,7 @@ Snap Framework HTTP Server Library ---------------------------------- -[![Build Status](https://travis-ci.org/snapframework/snap-server.svg?branch=master)](https://travis-ci.org/snapframework/snap-server) +[![Build status](https://github.com/snapframework/snap-server/actions/workflows/ci.yml/badge.svg)](https://github.com/snapframework/snap-server/actions/workflows/ci.yml) This is the Snap Framework HTTP Server library. For more information about Snap, read the `README.SNAP.md` or visit the Snap project website at diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/pong/Main.hs b/pong/Main.hs --- a/pong/Main.hs +++ b/pong/Main.hs @@ -77,4 +77,4 @@ killThread tid where - output os = Streams.write (Just $ fromByteString "pong") os >> return os + output os = Streams.write (Just "pong") os >> return os diff --git a/snap-server.cabal b/snap-server.cabal --- a/snap-server.cabal +++ b/snap-server.cabal @@ -1,5 +1,5 @@ name: snap-server -version: 1.0.3.3 +version: 1.1.2.1 synopsis: A web server for the Snap Framework description: Snap is a simple and fast web development framework and server written in @@ -18,10 +18,9 @@ build-type: Simple cabal-version: >= 1.10 homepage: http://snapframework.com/ +bug-reports: https://github.com/snapframework/snap-server/issues category: Web, Snap, IO-Streams -tested-with: GHC==8.2.1, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 - extra-source-files: CONTRIBUTORS, LICENSE, @@ -34,12 +33,15 @@ testserver/static/hello.txt tested-with: - GHC==7.4.2 GHC==7.6.3, GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, - GHC==8.2.1 + GHC==8.2.2, + GHC==8.4.4, + GHC==8.6.5, + GHC==8.8.3, + GHC==8.10.1 Flag portable Description: Compile in cross-platform mode. No platform-specific code or @@ -94,26 +96,26 @@ Snap.Internal.Http.Server.TLS build-depends: - attoparsec >= 0.12 && < 0.14, - base >= 4 && < 5, + attoparsec >= 0.12 && < 0.15, + base >= 4.6 && < 5, blaze-builder >= 0.4 && < 0.5, - bytestring >= 0.9.1 && < 0.11, - bytestring-builder >= 0.10.4 && < 0.11, + bytestring >= 0.9.1 && < 0.12, case-insensitive >= 1.1 && < 1.3, - clock >= 0.7.1 && < 0.8, - containers >= 0.3 && < 0.6, + clock >= 0.7.1 && < 0.9, + containers >= 0.3 && < 0.7, filepath >= 1.1 && < 2.0, io-streams >= 1.3 && < 1.6, io-streams-haproxy >= 1.0 && < 1.1, lifted-base >= 0.1 && < 0.3, - mtl >= 2.0 && < 2.3, - network >= 2.3 && < 2.7, + mtl >= 2.0 && < 2.4, + network >= 2.3 && < 3.2, old-locale >= 1.0 && < 1.1, snap-core >= 1.0 && < 1.1, - text >= 0.11 && < 1.3, - time >= 1.0 && < 1.9, - unix-compat >= 0.2 && < 0.5, - vector >= 0.7 && < 0.13 + text >= 0.11 && < 2.1, + time >= 1.0 && < 1.13, + transformers >= 0.3 && < 0.7, + unix-compat >= 0.2 && < 0.7, + vector >= 0.7 && < 0.14 other-extensions: BangPatterns, @@ -129,10 +131,16 @@ EmptyDataDecls, GeneralizedNewtypeDeriving + if !impl(ghc >= 8.0) + build-depends: semigroups >= 0.16 && < 0.19 + + if !impl(ghc >= 7.8) + build-depends: bytestring-builder >= 0.10.4 && < 0.11 + if flag(portable) || os(windows) cpp-options: -DPORTABLE else - build-depends: unix < 2.8 + build-depends: unix < 2.9 if flag(openssl) cpp-options: -DOPENSSL @@ -176,6 +184,7 @@ Default-language: Haskell2010 other-modules: + Control.Concurrent.Extended, Paths_snap_server, Snap.Http.Server, Snap.Http.Server.Config, @@ -205,32 +214,31 @@ Test.Common.TestHandler build-depends: - attoparsec >= 0.12 && < 0.14, - base >= 4 && < 5, - base16-bytestring >= 0.1 && < 0.2, - blaze-builder >= 0.4 && < 0.5, - bytestring-builder >= 0.10.4 && < 0.11, - bytestring >= 0.9.1 && < 0.11, - case-insensitive >= 1.1 && < 1.3, - clock >= 0.7.1 && < 0.8, - containers >= 0.3 && < 0.6, - directory >= 1.0 && < 1.4, - filepath >= 1.1 && < 2.0, + attoparsec, + base, + base16-bytestring >= 0.1 && < 1.1, + blaze-builder, + bytestring, + case-insensitive, + clock, + containers, + directory >= 1.1 && < 1.4, + filepath, io-streams, - io-streams-haproxy >= 1.0 && < 1.1, - lifted-base >= 0.1 && < 0.3, + io-streams-haproxy, + lifted-base, monad-control >= 1.0 && < 1.1, - mtl >= 2.0 && < 2.3, - network >= 2.3 && < 2.7, - old-locale >= 1.0 && < 1.1, - random >= 1.0 && < 1.2, - snap-core >= 1.0 && < 1.1, - text >= 0.11 && < 1.3, + mtl, + network, + old-locale, + random >= 1.0 && < 1.3, + snap-core, + text, threads >= 0.5 && < 0.6, - time >= 1.0 && < 1.9, - transformers >= 0.3 && < 0.6, - unix-compat >= 0.2 && < 0.5, - vector >= 0.7 && < 0.13, + time, + transformers, + unix-compat, + vector, HUnit >= 1.2 && < 2, QuickCheck >= 2.3.0.2 && < 3, @@ -256,18 +264,24 @@ EmptyDataDecls, GeneralizedNewtypeDeriving + if !impl(ghc >= 8.0) + build-depends: semigroups + + if !impl(ghc >= 7.8) + build-depends: bytestring-builder + if flag(portable) || os(windows) cpp-options: -DPORTABLE else - build-depends: unix < 2.8 + build-depends: unix -- always label threads in testsuite cpp-options: -DLABEL_THREADS if flag(openssl) cpp-options: -DOPENSSL - build-depends: HsOpenSSL >= 0.10.4 && < 0.12, - openssl-streams >= 1.1 && < 1.3 + build-depends: HsOpenSSL, + openssl-streams if os(linux) && !flag(portable) cpp-options: -DLINUX -DHAS_SENDFILE -DHAS_UNIX_SOCKETS @@ -313,16 +327,17 @@ Snap.Internal.Http.Server.Parser build-depends: - attoparsec >= 0.12 && < 0.14, - base >= 4 && < 5, - blaze-builder >= 0.4 && < 0.5, - bytestring >= 0.9 && < 0.11, - bytestring-builder >= 0.10.4 && < 0.11, - criterion >= 0.6 && < 1.3, + attoparsec, + base, + blaze-builder, + bytestring, + bytestring-builder, + criterion >= 0.6 && < 1.7, io-streams, - io-streams-haproxy >= 1.0 && < 1.1, - snap-core >= 1.0 && < 1.1, - vector >= 0.7 && < 0.13 + io-streams-haproxy, + snap-core, + transformers, + vector ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-unused-do-bind -rtsopts @@ -351,6 +366,7 @@ default-language: Haskell2010 other-modules: + Control.Concurrent.Extended Paths_snap_server, Snap.Internal.Http.Server.Address, Snap.Internal.Http.Server.Clock, @@ -368,7 +384,7 @@ if flag(portable) || os(windows) cpp-options: -DPORTABLE else - build-depends: unix < 2.8 + build-depends: unix if os(linux) && !flag(portable) cpp-options: -DLINUX -DHAS_SENDFILE -DHAS_UNIX_SOCKETS @@ -392,29 +408,30 @@ if flag(openssl) cpp-options: -DOPENSSL - build-depends: HsOpenSSL >= 0.10.4 && < 0.12, - openssl-streams >= 1.1 && < 1.3 + build-depends: HsOpenSSL, + openssl-streams build-depends: - attoparsec >= 0.12 && < 0.14, - base >= 4 && < 5, - blaze-builder >= 0.4 && < 0.5, - bytestring >= 0.9.1 && < 0.11, - bytestring-builder >= 0.10.4 && < 0.11, - case-insensitive >= 1.1 && < 1.3, - clock >= 0.7.1 && < 0.8, - containers >= 0.3 && < 0.6, + attoparsec, + base, + blaze-builder, + bytestring, + bytestring-builder, + case-insensitive, + clock, + containers, + filepath, io-streams, - io-streams-haproxy >= 1.0 && < 1.1, - lifted-base >= 0.1 && < 0.3, - mtl >= 2.0 && < 2.3, - network >= 2.3 && < 2.7, - old-locale >= 1.0 && < 1.1, - snap-core >= 1.0 && < 1.1, - text >= 0.11 && < 1.3, - time >= 1.0 && < 1.9, - unix-compat >= 0.2 && < 0.5, - vector >= 0.7 && < 0.13 + io-streams-haproxy, + lifted-base, + mtl, + network, + old-locale, + snap-core, + text, + time, + unix-compat, + vector ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-unused-do-bind -threaded -rtsopts @@ -443,13 +460,17 @@ if flag(openssl) cpp-options: -DOPENSSL - build-depends: HsOpenSSL >= 0.10.4 && < 0.12, - openssl-streams >= 1.1 && < 1.3 + build-depends: HsOpenSSL, + openssl-streams default-language: Haskell2010 other-modules: + Control.Concurrent.Extended, Paths_snap_server, + Snap.Http.Server, + Snap.Http.Server.Config, + Snap.Http.Server.Types, Snap.Internal.Http.Server.Address, Snap.Internal.Http.Server.Clock, Snap.Internal.Http.Server.Common, @@ -458,15 +479,18 @@ Snap.Internal.Http.Server.Parser, Snap.Internal.Http.Server.Session, Snap.Internal.Http.Server.Socket, + Snap.Internal.Http.Server.TLS, Snap.Internal.Http.Server.Thread, Snap.Internal.Http.Server.TimeoutManager, - Snap.Internal.Http.Server.TLS, - Snap.Internal.Http.Server.Types + Snap.Internal.Http.Server.Types, + System.FastLogger, + Test.Common.Rot13, + Test.Common.TestHandler if flag(portable) || os(windows) cpp-options: -DPORTABLE else - build-depends: unix < 2.8 + build-depends: unix if os(linux) && !flag(portable) cpp-options: -DLINUX -DHAS_SENDFILE -DHAS_UNIX_SOCKETS @@ -489,27 +513,28 @@ System.SendFile.FreeBSD build-depends: - attoparsec >= 0.12 && < 0.14, - base >= 4 && < 5, - blaze-builder >= 0.4 && < 0.5, - bytestring >= 0.9.1 && < 0.11, - bytestring-builder >= 0.10.4 && < 0.11, - case-insensitive >= 1.1 && < 1.3, - clock >= 0.7.1 && < 0.8, - containers >= 0.3 && < 0.6, - directory >= 1.1 && < 1.4, + attoparsec, + base, + blaze-builder, + bytestring, + bytestring-builder, + case-insensitive, + clock, + containers, + directory, + filepath, io-streams, - io-streams-haproxy >= 1.0 && < 1.1, - lifted-base >= 0.1 && < 0.3, - mtl >= 2.0 && < 2.3, - network >= 2.3 && < 2.7, - old-locale >= 1.0 && < 1.1, - snap-core >= 1.0 && < 1.1, - text >= 0.11 && < 1.3, - time >= 1.0 && < 1.9, - transformers >= 0.3 && < 0.6, - unix-compat >= 0.2 && < 0.5, - vector >= 0.7 && < 0.13 + io-streams-haproxy, + lifted-base, + mtl, + network, + old-locale, + snap-core, + text, + time, + transformers, + unix-compat, + vector ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-unused-do-bind -threaded -rtsopts diff --git a/src/Control/Concurrent/Extended.hs b/src/Control/Concurrent/Extended.hs --- a/src/Control/Concurrent/Extended.hs +++ b/src/Control/Concurrent/Extended.hs @@ -19,7 +19,12 @@ #ifdef LABEL_THREADS import Control.Concurrent (forkIOWithUnmask, forkOnWithUnmask, myThreadId) +#if MIN_VERSION_base(4,18,0) +import qualified Data.ByteString.Char8 as C8 +import GHC.Conc (labelThread) +#else import GHC.Base (labelThread#) +#endif import Foreign.C.String (CString) import GHC.IO (IO (..)) import GHC.Ptr (Ptr (..)) @@ -77,6 +82,12 @@ -- | Like 'labelThread' but uses a Latin-1 encoded 'ByteString' instead of a -- 'String'. labelThreadBs :: ThreadId -> B.ByteString -> IO () +#if MIN_VERSION_base(4,18,0) +labelThreadBs tid = + -- The 'labelThread#' signature changed: it now requires a UTF-8 encoded + -- ByteArray#. + labelThread tid . C8.unpack +#else labelThreadBs tid bs = B.useAsCString bs $ labelThreadCString tid @@ -86,9 +97,10 @@ labelThreadCString (ThreadId t) (Ptr p) = IO $ \s -> case labelThread# t p s of s1 -> (# s1, () #) +#endif + #elif defined(TESTSUITE) labelMe !_ = return $! () #else labelMe _label = return $! () #endif - diff --git a/src/Snap/Internal/Http/Server/Address.hs b/src/Snap/Internal/Http/Server/Address.hs --- a/src/Snap/Internal/Http/Server/Address.hs +++ b/src/Snap/Internal/Http/Server/Address.hs @@ -25,7 +25,7 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Typeable (Typeable) -import Network.Socket (AddrInfo (addrAddress, addrFamily, addrSocketType, addrFlags), AddrInfoFlag (AI_NUMERICSERV), Family (AF_INET, AF_INET6), HostName, NameInfoFlag (NI_NUMERICHOST), ServiceName, SockAddr (SockAddrInet, SockAddrInet6, SockAddrUnix), SocketType (Stream), defaultHints, getAddrInfo, getNameInfo, iN6ADDR_ANY, iNADDR_ANY) +import Network.Socket (AddrInfo (addrAddress, addrFamily, addrFlags, addrSocketType), AddrInfoFlag (AI_NUMERICSERV, AI_PASSIVE), Family (AF_INET, AF_INET6), HostName, NameInfoFlag (NI_NUMERICHOST), ServiceName, SockAddr (SockAddrInet, SockAddrInet6, SockAddrUnix), SocketType (Stream), defaultHints, getAddrInfo, getNameInfo) ------------------------------------------------------------------------------ @@ -87,22 +87,25 @@ -> Int -> ByteString -> IO (Family, SockAddr) getSockAddrImpl !_getAddrInfo p s = case () of - !_ | s == "*" -> return $! ( AF_INET - , SockAddrInet (fromIntegral p) iNADDR_ANY - ) - | s == "::" -> return $! ( AF_INET6 - , SockAddrInet6 (fromIntegral p) 0 iN6ADDR_ANY 0 - ) - | otherwise -> do ais <- _getAddrInfo (Just hints) (Just $ S.unpack s) - (Just $ show p) - if null ais - then throwIO $ AddressNotSupportedException $ show s - else do - let ai = head ais - let fm = addrFamily ai - let sa = addrAddress ai - return (fm, sa) + !_ | s == "*" -> getAddrs isIPv4 (Just wildhints) Nothing (Just $ show p) + | s == "::" -> getAddrs isIPv6 (Just wildhints) Nothing (Just $ show p) + | otherwise -> getAddrs (const True) (Just hints) (Just $ S.unpack s) (Just $ show p) + where + isIPv4 ai = addrFamily ai == AF_INET + isIPv6 ai = addrFamily ai == AF_INET6 + + getAddrs flt a b c = do + ais <- filter flt <$> _getAddrInfo a b c + if null ais + then throwIO $ AddressNotSupportedException $ show s + else do + let ai = head ais + let fm = addrFamily ai + let sa = addrAddress ai + return (fm, sa) + + wildhints = hints { addrFlags = [AI_NUMERICSERV, AI_PASSIVE] } hints = defaultHints { addrFlags = [AI_NUMERICSERV] , addrSocketType = Stream } diff --git a/src/Snap/Internal/Http/Server/Config.hs b/src/Snap/Internal/Http/Server/Config.hs --- a/src/Snap/Internal/Http/Server/Config.hs +++ b/src/Snap/Internal/Http/Server/Config.hs @@ -92,6 +92,9 @@ import Data.Monoid (Monoid (..)) #endif import Data.Monoid (Last (Last, getLast)) +#if !MIN_VERSION_base(4,11,0) +import Data.Semigroup (Semigroup (..)) +#endif import qualified Data.Text as T import qualified Data.Text.Encoding as T #if MIN_VERSION_base(4,7,0) @@ -99,7 +102,7 @@ #else import Data.Typeable (TyCon, Typeable, Typeable1 (..), mkTyCon3, mkTyConApp) #endif -import Network (Socket) +import Network.Socket (Socket) import Numeric (readOct, showOct) #if !MIN_VERSION_base(4,6,0) import Prelude hiding (catch) @@ -286,31 +289,8 @@ ------------------------------------------------------------------------------ -instance Monoid (Config m a) where - mempty = Config - { hostname = Nothing - , accessLog = Nothing - , errorLog = Nothing - , locale = Nothing - , port = Nothing - , bind = Nothing - , sslport = Nothing - , sslbind = Nothing - , sslcert = Nothing - , sslchaincert = Nothing - , sslkey = Nothing - , unixsocket = Nothing - , unixaccessmode = Nothing - , compression = Nothing - , verbose = Nothing - , errorHandler = Nothing - , defaultTimeout = Nothing - , other = Nothing - , proxyType = Nothing - , startupHook = Nothing - } - - a `mappend` b = Config +instance Semigroup (Config m a) where + a <> b = Config { hostname = ov hostname , accessLog = ov accessLog , errorLog = ov errorLog @@ -337,6 +317,35 @@ ov f = getLast $! (mappend `on` (Last . f)) a b +instance Monoid (Config m a) where + mempty = Config + { hostname = Nothing + , accessLog = Nothing + , errorLog = Nothing + , locale = Nothing + , port = Nothing + , bind = Nothing + , sslport = Nothing + , sslbind = Nothing + , sslcert = Nothing + , sslchaincert = Nothing + , sslkey = Nothing + , unixsocket = Nothing + , unixaccessmode = Nothing + , compression = Nothing + , verbose = Nothing + , errorHandler = Nothing + , defaultTimeout = Nothing + , other = Nothing + , proxyType = Nothing + , startupHook = Nothing + } + +#if !MIN_VERSION_base(4,11,0) + mappend = (<>) +#endif + + ------------------------------------------------------------------------------ -- | These are the default values for the options defaultConfig :: MonadSnap m => Config m a @@ -759,7 +768,9 @@ extendedCommandLineConfig :: MonadSnap m => [OptDescr (Maybe (Config m a))] - -- ^ User options. + -- ^ Full list of command line options (combine + -- yours with 'optDescrs' to extend Snap's default + -- set of options) -> (a -> a -> a) -- ^ State for multiple invoked user command-line -- options will be combined using this function. diff --git a/src/Snap/Internal/Http/Server/Parser.hs b/src/Snap/Internal/Http/Server/Parser.hs --- a/src/Snap/Internal/Http/Server/Parser.hs +++ b/src/Snap/Internal/Http/Server/Parser.hs @@ -29,9 +29,9 @@ import Control.Applicative ((<$>)) #endif import Control.Exception (Exception, throwIO) -import qualified Control.Exception as E import Control.Monad (void, when) -import Data.Attoparsec.ByteString.Char8 (Parser, hexadecimal, skipWhile, take) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.Attoparsec.ByteString.Char8 (Parser, hexadecimal, takeTill) import qualified Data.ByteString.Char8 as S import Data.ByteString.Internal (ByteString (..), c2w, memchr, w2c) #if MIN_VERSION_bytestring(0, 10, 6) @@ -40,9 +40,6 @@ import Data.ByteString.Internal (inlinePerformIO) #endif import qualified Data.ByteString.Unsafe as S -#if !MIN_VERSION_io_streams(1,2,0) -import Data.IORef (newIORef, readIORef, writeIORef) -#endif import Data.List (sort) import Data.Typeable (Typeable) import qualified Data.Vector as V @@ -53,12 +50,12 @@ ------------------------------------------------------------------------------ import Blaze.ByteString.Builder.HTTP (chunkedTransferEncoding, chunkedTransferTerminator) import Data.ByteString.Builder (Builder) -import System.IO.Streams (InputStream, OutputStream) +import System.IO.Streams (InputStream, OutputStream, Generator) import qualified System.IO.Streams as Streams import System.IO.Streams.Attoparsec (parseFromStream) ------------------------------------------------------------------------------ import Snap.Internal.Http.Types (Method (..)) -import Snap.Internal.Parsing (crlf, parseCookie, parseUrlEncoded, unsafeFromNat, ()) +import Snap.Internal.Parsing (crlf, parseCookie, parseUrlEncoded, unsafeFromNat) import Snap.Types.Headers (Headers) import qualified Snap.Types.Headers as H @@ -351,13 +348,11 @@ readChunkedTransferEncoding :: InputStream ByteString -> IO (InputStream ByteString) readChunkedTransferEncoding input = - Streams.makeInputStream $ parseFromStream pGetTransferChunk input - + Streams.fromGenerator (consumeChunks input) ------------------------------------------------------------------------------ writeChunkedTransferEncoding :: OutputStream Builder -> IO (OutputStream Builder) -#if MIN_VERSION_io_streams(1,2,0) writeChunkedTransferEncoding os = Streams.makeOutputStream f where f Nothing = do @@ -365,50 +360,77 @@ Streams.write Nothing os f x = Streams.write (chunkedTransferEncoding `fmap` x) os -#else -writeChunkedTransferEncoding os = do - -- make sure we only send the terminator once. - eof <- newIORef True - Streams.makeOutputStream $ f eof - where - f eof Nothing = readIORef eof >>= flip when (do - writeIORef eof True - Streams.write (Just chunkedTransferTerminator) os - Streams.write Nothing os) - f _ x = Streams.write (chunkedTransferEncoding `fmap` x) os -#endif - --------------------- -- parse functions -- --------------------- ------------------------------------------------------------------------------ --- We treat chunks larger than this from clients as a denial-of-service attack. --- 256kB should be enough buffer. -mAX_CHUNK_SIZE :: Int -mAX_CHUNK_SIZE = (2::Int)^(18::Int) +{- + For a response body in chunked transfer encoding, iterate over + the individual chunks, reading the size parameter, then + looping over that chunk in bites of at most bUFSIZ, + yielding them to the receiveResponse InputStream accordingly. +-} +consumeChunks :: InputStream ByteString -> Generator ByteString () +consumeChunks i1 = do + !n <- parseSize + if n > 0 + then do + -- read one or more bytes, then loop to next chunk + go n + skipCRLF + consumeChunks i1 + else do + -- NB: snap-server doesn't yet support chunked trailer parts + -- (see RFC7230#sec4.1.2) + -- consume final CRLF + skipCRLF ------------------------------------------------------------------------------- -pGetTransferChunk :: Parser (Maybe ByteString) -pGetTransferChunk = parser "pGetTransferChunk" where - parser = do - !hex <- hexadecimal "hexadecimal" - skipWhile (/= '\r') "skipToEOL" - void crlf "linefeed" - if hex >= mAX_CHUNK_SIZE - then return $! E.throw $! HttpParseException $! - "pGetTransferChunk: chunk of size " ++ show hex ++ " too long." - else if hex <= 0 - then (crlf >> return Nothing) "terminal crlf after 0 length" - else do - -- now safe to take this many bytes. - !x <- take hex "reading data chunk" - void crlf "linefeed after data chunk" - return $! Just x + go 0 = return () + go !n = do + (!x',!r) <- liftIO $ readN n i1 + Streams.yield x' + go r + parseSize = do + liftIO $ parseFromStream transferChunkSize i1 + + skipCRLF = do + liftIO $ void (parseFromStream crlf i1) + + transferChunkSize :: Parser (Int) + transferChunkSize = do + !n <- hexadecimal + -- skip over any chunk extensions (see RFC7230#sec4.1.1) + void (takeTill (== '\r')) + void crlf + return n + + {- + The chunk size coming down from the client is somewhat arbitrary; + it's really just an indication of how many bytes need to be read + before the next size marker or end marker - neither of which has + anything to do with streaming on our side. Instead, we'll feed + bytes into our InputStream at an appropriate intermediate size. + -} + bUFSIZ :: Int + bUFSIZ = 32752 + + {- + Read the specified number of bytes up to a maximum of bUFSIZ, + returning a resultant ByteString and the number of bytes remaining. + -} + readN :: Int -> InputStream ByteString -> IO (ByteString, Int) + readN n input = do + !x' <- Streams.readExactly p input + return (x', r) + where + !d = n - bUFSIZ + !p = if d > 0 then bUFSIZ else n + !r = if d > 0 then d else 0 ------------------------------------------------------------------------------ toLower :: ByteString -> ByteString diff --git a/src/Snap/Internal/Http/Server/Socket.hs b/src/Snap/Internal/Http/Server/Socket.hs --- a/src/Snap/Internal/Http/Server/Socket.hs +++ b/src/Snap/Internal/Http/Server/Socket.hs @@ -18,7 +18,7 @@ import Control.Monad (when) import Data.Bits (complement, (.&.)) import Data.ByteString.Char8 (ByteString) -import Network.Socket (Socket, SocketOption (NoDelay, ReuseAddr), accept, close, getSocketName, listen, setSocketOption, socket) +import Network.Socket (Socket, SocketOption (NoDelay, ReuseAddr), accept, close, getSocketName, setSocketOption, socket) import qualified Network.Socket as N #ifdef HAS_SENDFILE import Network.Socket (fdSocket) @@ -48,7 +48,13 @@ ------------------------------------------------------------------------------ bindSocket :: ByteString -> Int -> IO Socket -bindSocket = bindSocketImpl setSocketOption N.bindSocket listen +bindSocket = bindSocketImpl setSocketOption bind N.listen + where +#if MIN_VERSION_network(2,7,0) + bind = N.bind +#else + bind = N.bindSocket +#endif {-# INLINE bindSocket #-} @@ -79,13 +85,18 @@ bracketOnError (socket N.AF_UNIX N.Stream 0) N.close $ \sock -> do E.catch (removeLink path) $ \e -> when (not $ isDoesNotExistError e) $ throwIO e case mode of - Nothing -> N.bindSocket sock (N.SockAddrUnix path) + Nothing -> bind sock (N.SockAddrUnix path) Just mode' -> bracket (setFileCreationMask $ modeToMask mode') setFileCreationMask - (const $ N.bindSocket sock (N.SockAddrUnix path)) + (const $ bind sock (N.SockAddrUnix path)) N.listen sock 150 return $! sock where +#if MIN_VERSION_network(2,7,0) + bind = N.bind +#else + bind = N.bindSocket +#endif modeToMask p = accessModes .&. complement (fromIntegral p) #else bindUnixSocket _ path = throwIO (AddressNotSupportedException $ "unix:" ++ path) @@ -162,11 +173,21 @@ #ifdef HAS_SENDFILE sendFileFunc sock !_ builder fPath offset nbytes = bracket acquire closeFd go where - sockFd = Fd (fdSocket sock) +#if MIN_VERSION_unix(2,8,0) + acquire = openFd fPath ReadOnly defaultFileFlags +#else acquire = openFd fPath ReadOnly Nothing defaultFileFlags - go fileFd = do sendHeaders builder sockFd - sendFile sockFd fileFd offset nbytes +#endif +#if MIN_VERSION_network(3,0,0) + go fileFd = do sockFd <- Fd `fmap` fdSocket sock + sendHeaders builder sockFd + sendFile sockFd fileFd offset nbytes +#else + go fileFd = do let sockFd = Fd $ fdSocket sock + sendHeaders builder sockFd + sendFile sockFd fileFd offset nbytes +#endif #else sendFileFunc sock buffer builder fPath offset nbytes = diff --git a/src/Snap/Internal/Http/Server/TLS.hs b/src/Snap/Internal/Http/Server/TLS.hs --- a/src/Snap/Internal/Http/Server/TLS.hs +++ b/src/Snap/Internal/Http/Server/TLS.hs @@ -25,9 +25,9 @@ import OpenSSL (withOpenSSL) import OpenSSL.Session (SSL, SSLContext) import qualified OpenSSL.Session as SSL -import Prelude (Bool, FilePath, IO, Int, Maybe (..), Monad (..), Show, flip, fromIntegral, fst, not, ($), ($!), (.)) -import Snap.Internal.Http.Server.Address (getAddress, getSockAddr) -import Snap.Internal.Http.Server.Socket (acceptAndInitialize) +import Prelude (Bool, FilePath, IO, Int, Maybe (..), Monad (..), Show, flip, fromIntegral, not, ($), ($!)) +import Snap.Internal.Http.Server.Address (getAddress) +import Snap.Internal.Http.Server.Socket (acceptAndInitialize, bindSocket) import qualified System.IO.Streams as Streams import qualified System.IO.Streams.SSL as SStreams @@ -98,22 +98,14 @@ bindHttps bindAddress bindPort cert chainCert key = withTLS $ bracketOnError - (do (family, addr) <- getSockAddr bindPort bindAddress - sock <- Socket.socket family Socket.Stream 0 - return (sock, addr) - ) - (Socket.close . fst) - $ \(sock, addr) -> do - Socket.setSocketOption sock Socket.ReuseAddr 1 - Socket.bindSocket sock addr - Socket.listen sock 150 - + (bindSocket bindAddress bindPort) + Socket.close + $ \sock -> do ctx <- SSL.context SSL.contextSetPrivateKeyFile ctx key if chainCert then SSL.contextSetCertificateChainFile ctx cert else SSL.contextSetCertificateFile ctx cert - certOK <- SSL.contextCheckPrivateKey ctx when (not certOK) $ do throwIO $ TLSException certificateError diff --git a/test/Snap/Internal/Http/Server/Address/Tests.hs b/test/Snap/Internal/Http/Server/Address/Tests.hs --- a/test/Snap/Internal/Http/Server/Address/Tests.hs +++ b/test/Snap/Internal/Http/Server/Address/Tests.hs @@ -5,10 +5,7 @@ module Snap.Internal.Http.Server.Address.Tests (tests) where ------------------------------------------------------------------------------ -import Network.Socket (Family (AF_INET, AF_INET6), SockAddr (SockAddrInet, SockAddrInet6, SockAddrUnix), iN6ADDR_ANY, iNADDR_ANY) -#if MIN_VERSION_network(2,6,0) -import Network.Socket (SockAddr (SockAddrCan)) -#endif +import Network.Socket (Family (AF_INET, AF_INET6), SockAddr (SockAddrInet, SockAddrInet6, SockAddrUnix)) ------------------------------------------------------------------------------ import Test.Framework (Test) import Test.Framework.Providers.HUnit (testCase) @@ -22,7 +19,6 @@ tests :: [Test] tests = [ testGetNameInfoFails , testGetAddressUnix - , testGetAddressCan , testGetAddressIPv6 , testGetSockAddr , testTrivials @@ -45,18 +41,9 @@ ------------------------------------------------------------------------------ -testGetAddressCan :: Test -testGetAddressCan = testCase "address/getAddress-can" $ do -#if MIN_VERSION_network(2,6,0) - expectException $ getAddress $ SockAddrCan 0 -#else - return () -#endif - ------------------------------------------------------------------------------- testGetAddressIPv6 :: Test testGetAddressIPv6 = testCase "address/getAddress-IPv6" $ do - let x = SockAddrInet6 10 undefined undefined undefined + let x = SockAddrInet6 10 0 (0,0,0,0) 0 (y, _) <- getAddressImpl (const $ return "") x assertEqual "ipv6 port" 10 y @@ -73,7 +60,9 @@ assertEqual "" a2 $ SockAddrInet6 10 0 iN6ADDR_ANY 0 expectException $ getSockAddrImpl (\_ _ _ -> return []) 10 "foo" - + where + iNADDR_ANY = 0 + iN6ADDR_ANY = (0,0,0,0) diff --git a/test/Snap/Internal/Http/Server/Parser/Tests.hs b/test/Snap/Internal/Http/Server/Parser/Tests.hs --- a/test/Snap/Internal/Http/Server/Parser/Tests.hs +++ b/test/Snap/Internal/Http/Server/Parser/Tests.hs @@ -9,7 +9,6 @@ import Control.Parallel.Strategies (rdeepseq, using) import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L -import Data.Int (Int64) import Data.List (sort) import qualified Data.Map as Map import Data.Monoid (mconcat) @@ -37,7 +36,6 @@ tests = [ testShow , testCookie , testChunked - , testChunkDoS , testNull , testPartial , testParseError @@ -125,22 +123,6 @@ Streams.write Nothing os' s <- liftM (toLazyByteString . mconcat) getList assertEqual "chunked" "002\r\nok\r\n0\r\n\r\n" s - - ------------------------------------------------------------------------------- --- | ensure that running 'readChunkedTransferEncoding' against --- 'transferEncodingChunked' returns the original string -testChunkDoS :: Test -testChunkDoS = testCase "parser/chunkedTransferEncoding/DoS" $ do - let n = ((2::Int64)^(18 :: Int64) + 10) :: Int64 - let s = S.concat $ L.toChunks $ L.take n $ L.fromChunks $ - cycle ["OKOKOKOKOKOKOKOK"] - let ch = transferEncodingChunked $ L.fromChunks [s] - - expectException (Streams.fromList (L.toChunks ch) >>= - readChunkedTransferEncoding >>= - Streams.toList) - ------------------------------------------------------------------------------ testCookie :: Test diff --git a/test/Snap/Internal/Http/Server/Session/Tests.hs b/test/Snap/Internal/Http/Server/Session/Tests.hs --- a/test/Snap/Internal/Http/Server/Session/Tests.hs +++ b/test/Snap/Internal/Http/Server/Session/Tests.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} module Snap.Internal.Http.Server.Session.Tests (tests) where diff --git a/test/Snap/Internal/Http/Server/Socket/Tests.hs b/test/Snap/Internal/Http/Server/Socket/Tests.hs --- a/test/Snap/Internal/Http/Server/Socket/Tests.hs +++ b/test/Snap/Internal/Http/Server/Socket/Tests.hs @@ -62,12 +62,17 @@ ------------------------------------------------------------------------------ tests :: [Test] -tests = [ testSockClosedOnListenException +tests = [ + testUnixSocketBind +#if !MIN_VERSION_network(3,0,0) , testAcceptFailure - , testUnixSocketBind + , testSockClosedOnListenException +#endif ] ------------------------------------------------------------------------------ +-- TODO: fix these tests which rely on deprecated socket apis +#if !MIN_VERSION_network(3,0,0) testSockClosedOnListenException :: Test testSockClosedOnListenException = testCase "socket/closedOnListenException" $ do ref <- newIORef Nothing @@ -84,7 +89,6 @@ bs _ _ = fail "bindsocket" ls _ _ = fail "listen" - ------------------------------------------------------------------------------ testAcceptFailure :: Test testAcceptFailure = testCase "socket/acceptAndInitialize" $ do @@ -113,13 +117,16 @@ fail "error" client port = withSock port (const $ return ()) +#endif testUnixSocketBind :: Test #ifdef HAS_UNIX_SOCKETS testUnixSocketBind = testCase "socket/unixSocketBind" $ withSocketPath $ \path -> do +#if !MIN_VERSION_network(3,0,0) E.bracket (Sock.bindUnixSocket Nothing path) N.close $ \sock -> do N.isListening sock >>= assertEqual "listening" True +#endif expectException $ E.bracket (Sock.bindUnixSocket Nothing "a/relative/path") N.close doNothing diff --git a/test/Snap/Test/Common.hs b/test/Snap/Test/Common.hs --- a/test/Snap/Test/Common.hs +++ b/test/Snap/Test/Common.hs @@ -21,7 +21,8 @@ import qualified Data.ByteString.Lazy as L import Data.Monoid (Monoid (mappend, mempty)) import Data.Typeable (Typeable, typeOf) -import Network.Socket (AddrInfo (addrAddress, addrFlags), AddrInfoFlag (AI_NUMERICHOST), Family (AF_INET), Socket, SocketType (Stream), connect, defaultHints, defaultProtocol, getAddrInfo, sClose, socket) +import Network.Socket (Socket) +import qualified Network.Socket as N hiding (recv) import System.Timeout (timeout) import Test.HUnit (assertFailure) import Test.QuickCheck (Arbitrary (arbitrary), choose) @@ -71,18 +72,23 @@ ------------------------------------------------------------------------------ withSock :: Int -> (Socket -> IO a) -> IO a withSock port go = do - addr <- liftM (addrAddress . Prelude.head) $ - getAddrInfo (Just myHints) - (Just "127.0.0.1") - (Just $ show port) + addr <- liftM (N.addrAddress . Prelude.head) $ + N.getAddrInfo (Just myHints) + (Just "127.0.0.1") + (Just $ show port) - sock <- socket AF_INET Stream defaultProtocol - connect sock addr + sock <- N.socket N.AF_INET N.Stream N.defaultProtocol + N.connect sock addr - go sock `finally` sClose sock + go sock `finally` close sock where - myHints = defaultHints { addrFlags = [ AI_NUMERICHOST ] } +#if MIN_VERSION_network(2,7,0) + close = N.close +#else + close = N.sClose +#endif + myHints = N.defaultHints { N.addrFlags = [ N.AI_NUMERICHOST ] } ------------------------------------------------------------------------------ diff --git a/test/Test/Blackbox.hs b/test/Test/Blackbox.hs --- a/test/Test/Blackbox.hs +++ b/test/Test/Blackbox.hs @@ -127,9 +127,15 @@ SSLTest -> startServer emptyServerConfig bindSSL fst (uncurry TLS.httpsAcceptFunc) where +#if MIN_VERSION_network(2,7,0) + anyport = N.defaultPort +#else + anyport = N.aNY_PORT +#endif + bindSSL = do sockCtx <- TLS.bindHttps "127.0.0.1" - (fromIntegral N.aNY_PORT) + (fromIntegral anyport) "test/cert.pem" False "test/key.pem" @@ -141,7 +147,7 @@ #endif return sockCtx - bindSock = Sock.bindSocket "127.0.0.1" (fromIntegral N.aNY_PORT) + bindSock = Sock.bindSocket "127.0.0.1" (fromIntegral anyport) logAccess !_ !_ !_ = return () logError !_ = return () @@ -485,6 +491,12 @@ testHaProxyLocal port = testCase "blackbox/haProxyLocal" runIt where +#if MIN_VERSION_network(2,7,0) + anyport = N.defaultPort +#else + anyport = N.aNY_PORT +#endif + remoteAddrServer :: N.Socket -> MVar (Maybe String) -> (forall a . IO a -> IO a) @@ -503,7 +515,7 @@ determineSourceInterfaceAddr = timeoutIn 10 $ bracket - (Sock.bindSocket "127.0.0.1" (fromIntegral N.aNY_PORT)) + (Sock.bindSocket "127.0.0.1" (fromIntegral anyport)) (eatException . N.close) (\ssock -> do mv <- newEmptyMVar diff --git a/test/TestSuite.hs b/test/TestSuite.hs --- a/test/TestSuite.hs +++ b/test/TestSuite.hs @@ -7,7 +7,9 @@ import qualified Control.Exception as E import Control.Monad (liftM) import Data.Maybe (maybeToList) +#if !MIN_VERSION_network(2,7,0) import Network (withSocketsDo) +#endif import System.Environment import Test.Framework (defaultMain, testGroup) ------------------------------------------------------------------------------ @@ -24,6 +26,10 @@ #endif import qualified Test.Blackbox +#if MIN_VERSION_network(2,7,0) +withSocketsDo :: IO a -> IO a +withSocketsDo = id +#endif ------------------------------------------------------------------------------ main :: IO ()