snap-server 1.0.3.3 → 1.1.2.1
raw patch · 17 files changed
Files
- README.md +1/−1
- Setup.hs +0/−2
- pong/Main.hs +1/−1
- snap-server.cabal +124/−99
- src/Control/Concurrent/Extended.hs +13/−1
- src/Snap/Internal/Http/Server/Address.hs +19/−16
- src/Snap/Internal/Http/Server/Config.hs +38/−27
- src/Snap/Internal/Http/Server/Parser.hs +66/−44
- src/Snap/Internal/Http/Server/Socket.hs +28/−7
- src/Snap/Internal/Http/Server/TLS.hs +6/−14
- test/Snap/Internal/Http/Server/Address/Tests.hs +5/−16
- test/Snap/Internal/Http/Server/Parser/Tests.hs +0/−18
- test/Snap/Internal/Http/Server/Session/Tests.hs +1/−0
- test/Snap/Internal/Http/Server/Socket/Tests.hs +10/−3
- test/Snap/Test/Common.hs +15/−9
- test/Test/Blackbox.hs +15/−3
- test/TestSuite.hs +6/−0
README.md view
@@ -1,7 +1,7 @@ Snap Framework HTTP Server Library ---------------------------------- -[](https://travis-ci.org/snapframework/snap-server)+[](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
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
pong/Main.hs view
@@ -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
snap-server.cabal view
@@ -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
src/Control/Concurrent/Extended.hs view
@@ -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-
src/Snap/Internal/Http/Server/Address.hs view
@@ -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 }
src/Snap/Internal/Http/Server/Config.hs view
@@ -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.
src/Snap/Internal/Http/Server/Parser.hs view
@@ -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
src/Snap/Internal/Http/Server/Socket.hs view
@@ -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 =
src/Snap/Internal/Http/Server/TLS.hs view
@@ -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
test/Snap/Internal/Http/Server/Address/Tests.hs view
@@ -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)
test/Snap/Internal/Http/Server/Parser/Tests.hs view
@@ -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
test/Snap/Internal/Http/Server/Session/Tests.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} module Snap.Internal.Http.Server.Session.Tests (tests) where
test/Snap/Internal/Http/Server/Socket/Tests.hs view
@@ -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
test/Snap/Test/Common.hs view
@@ -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 ] } ------------------------------------------------------------------------------
test/Test/Blackbox.hs view
@@ -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
test/TestSuite.hs view
@@ -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 ()