snap-server 1.1.0.0 → 1.1.1.0
raw patch · 9 files changed
+107/−64 lines, 9 filesdep ~basedep ~criteriondep ~network
Dependency ranges changed: base, criterion, network
Files
- snap-server.cabal +9/−8
- src/Snap/Internal/Http/Server/Address.hs +19/−16
- src/Snap/Internal/Http/Server/Config.hs +4/−2
- src/Snap/Internal/Http/Server/Socket.hs +24/−7
- test/Snap/Internal/Http/Server/Address/Tests.hs +5/−16
- 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
snap-server.cabal view
@@ -1,5 +1,5 @@ name: snap-server-version: 1.1.0.0+version: 1.1.1.0 synopsis: A web server for the Snap Framework description: Snap is a simple and fast web development framework and server written in@@ -38,8 +38,9 @@ GHC==7.8.4, GHC==7.10.3, GHC==8.0.2,- GHC==8.2.1,- GHC==8.4.1+ GHC==8.2.2,+ GHC==8.4.4,+ GHC==8.6.3 Flag portable Description: Compile in cross-platform mode. No platform-specific code or@@ -95,23 +96,23 @@ build-depends: attoparsec >= 0.12 && < 0.14,- base >= 4.6 && < 4.12,+ base >= 4.6 && < 4.13, 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,+ 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,+ network >= 2.3 && < 3.1, old-locale >= 1.0 && < 1.1, snap-core >= 1.0 && < 1.1, text >= 0.11 && < 1.3,- time >= 1.0 && < 1.9,+ time >= 1.0 && < 1.10, unix-compat >= 0.2 && < 0.6, vector >= 0.7 && < 0.13 @@ -325,7 +326,7 @@ blaze-builder, bytestring, bytestring-builder,- criterion >= 0.6 && < 1.5,+ criterion >= 0.6 && < 1.6, io-streams, io-streams-haproxy, snap-core,
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
@@ -102,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)@@ -768,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/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,17 @@ #ifdef HAS_SENDFILE sendFileFunc sock !_ builder fPath offset nbytes = bracket acquire closeFd go where- sockFd = Fd (fdSocket sock) acquire = openFd fPath ReadOnly Nothing defaultFileFlags- go fileFd = do sendHeaders builder sockFd+#if MIN_VERSION_network(3,0,0)+ go fileFd = do sockFd <- Fd <$> fdSocket sock+ sendHeaders builder sockFd sendFile sockFd fileFd offset nbytes-+#else+ acquire = openFd fPath ReadOnly Nothing defaultFileFlags+ 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 =
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/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 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 ()