snap-server 0.5.3.1 → 0.5.4
raw patch · 13 files changed
+252/−186 lines, 13 filesdep ~snap-coredep ~unix-compatdep ~vector
Dependency ranges changed: snap-core, unix-compat, vector, vector-algorithms
Files
- snap-server.cabal +7/−7
- src/Data/Concurrent/HashMap.hs +18/−24
- src/Data/Concurrent/HashMap/Internal.hs +0/−16
- src/Snap/Http/Server/Config.hs +29/−14
- src/Snap/Internal/Http/Server.hs +76/−26
- src/Snap/Internal/Http/Server/Address.hs +65/−0
- src/Snap/Internal/Http/Server/HttpPort.hs +3/−14
- src/Snap/Internal/Http/Server/LibevBackend.hs +3/−13
- src/Snap/Internal/Http/Server/SimpleBackend.hs +3/−26
- src/Snap/Internal/Http/Server/TLS.hs +4/−14
- src/System/FastLogger.hs +21/−9
- test/snap-server-testsuite.cabal +21/−22
- test/suite/Test/Blackbox.hs +2/−1
snap-server.cabal view
@@ -1,5 +1,5 @@ name: snap-server-version: 0.5.3.1+version: 0.5.4 synopsis: A fast, iteratee-based, epoll-enabled web server for the Snap Framework description: Snap is a simple and fast web development framework and server written in@@ -86,9 +86,9 @@ other-modules: Paths_snap_server, Data.Concurrent.HashMap,- Data.Concurrent.HashMap.Internal, Snap.Internal.Http.Parser, Snap.Internal.Http.Server,+ Snap.Internal.Http.Server.Address, Snap.Internal.Http.Server.Date, Snap.Internal.Http.Server.Backend, Snap.Internal.Http.Server.ListenHelpers,@@ -118,14 +118,14 @@ murmur-hash >= 0.1 && < 0.2, network >= 2.3 && <2.4, old-locale,- snap-core >= 0.5.3 && <0.6,+ snap-core >= 0.5.4 && <0.6, template-haskell, text >= 0.11 && <0.12, time >= 1.0 && < 1.4, transformers,- unix-compat == 0.2.*,- vector >= 0.7 && <0.8,- vector-algorithms >= 0.4 && <0.5,+ unix-compat >= 0.2 && <0.4,+ vector >= 0.7 && <0.10,+ vector-algorithms >= 0.4 && <0.6, PSQueue >= 1.1 && <1.2 if flag(portable) || os(windows)@@ -169,4 +169,4 @@ source-repository head type: git- location: http://git.snapframework.com/snap-server.git+ location: git://github.com/snapframework/snap-server.git
src/Data/Concurrent/HashMap.hs view
@@ -2,7 +2,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TemplateHaskell #-} module Data.Concurrent.HashMap ( HashMap@@ -43,38 +42,33 @@ import Data.Word #endif -import Data.Concurrent.HashMap.Internal-- hashString :: String -> Word-hashString = $(whichHash [| Murmur.asWord32 . Murmur.hash32 |]- [| Murmur.asWord64 . Murmur.hash64 |])+hashString = if bitSize (undefined :: Word) == 32+ then fromIntegral . Murmur.asWord32 . Murmur.hash32+ else fromIntegral . Murmur.asWord64 . Murmur.hash64 {-# INLINE hashString #-} hashInt :: Int -> Word-hashInt = $(whichHash [| Murmur.asWord32 . Murmur.hash32 |]- [| Murmur.asWord64 . Murmur.hash64 |])+hashInt = if bitSize (undefined :: Word) == 32+ then fromIntegral . Murmur.asWord32 . Murmur.hash32+ else fromIntegral . Murmur.asWord64 . Murmur.hash64 {-# INLINE hashInt #-} hashBS :: B.ByteString -> Word-hashBS =- $(let h32 = [| \s -> s `seq`- Murmur.asWord32 $- B.foldl' (\h c -> h `seq` c `seq`- Murmur.hash32AddInt (fromEnum c) h)- (Murmur.hash32 ([] :: [Int]))- s- |]- h64 = [| \s -> s `seq`- Murmur.asWord64 $- B.foldl' (\h c -> h `seq` c `seq`- Murmur.hash64AddInt (fromEnum c) h)- (Murmur.hash64 ([] :: [Int]))- s- |]- in whichHash h32 h64)+hashBS = if bitSize (undefined :: Word) == 32 then h32 else h64+ where+ h32 s = fromIntegral $ Murmur.asWord32 $+ B.foldl' (\h c -> h `seq` c `seq`+ Murmur.hash32AddInt (fromEnum c) h)+ (Murmur.hash32 ([] :: [Int]))+ s+ h64 s = fromIntegral $ Murmur.asWord64 $+ B.foldl' (\h c -> h `seq` c `seq`+ Murmur.hash64AddInt (fromEnum c) h)+ (Murmur.hash64 ([] :: [Int]))+ s {-# INLINE hashBS #-}
− src/Data/Concurrent/HashMap/Internal.hs
@@ -1,16 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE TemplateHaskell #-}--module Data.Concurrent.HashMap.Internal where--import Data.Bits-import Data.Word-import Language.Haskell.TH---whichHash :: ExpQ -> ExpQ -> Q Exp-whichHash as32 as64 = if bitSize (undefined :: Word) == 32- then [| \x -> fromIntegral $ $as32 x |]- else [| \x -> fromIntegral $ $as64 x |]
src/Snap/Http/Server/Config.hs view
@@ -54,6 +54,7 @@ import Blaze.ByteString.Builder+import Blaze.ByteString.Builder.Char8 import Control.Exception (SomeException) import Control.Monad import qualified Data.ByteString.Char8 as B@@ -77,7 +78,10 @@ import System.Exit import System.IO +------------------------------------------------------------------------------+import Snap.Internal.Http.Server (requestErrorMessage) + ------------------------------------------------------------------------------ -- | This datatype allows you to override which backend (either simple or -- libev) to use. Most users will not want to set this, preferring to rely on@@ -356,27 +360,32 @@ -------------------------------------------------------------------------------fromString :: String -> ByteString-fromString = T.encodeUtf8 . T.pack+bsFromString :: String -> ByteString+bsFromString = T.encodeUtf8 . T.pack ------------------------------------------------------------------------------+toString :: ByteString -> String+toString = T.unpack . T.decodeUtf8+++------------------------------------------------------------------------------ options :: MonadSnap m => Config m a -> [OptDescr (Maybe (Config m a))] options defaults = [ Option [] ["hostname"]- (ReqArg (Just . setConfig setHostname . fromString) "NAME")+ (ReqArg (Just . setConfig setHostname . bsFromString) "NAME") $ "local hostname" ++ defaultC getHostname , Option ['b'] ["address"]- (ReqArg (\s -> Just $ mempty { bind = Just $ fromString s })+ (ReqArg (\s -> Just $ mempty { bind = Just $ bsFromString s }) "ADDRESS") $ "address to bind to" ++ defaultO bind , Option ['p'] ["port"] (ReqArg (\s -> Just $ mempty { port = Just $ read s}) "PORT") $ "port to listen on" ++ defaultO port , Option [] ["ssl-address"]- (ReqArg (\s -> Just $ mempty { sslbind = Just $ fromString s })+ (ReqArg (\s -> Just $ mempty { sslbind = Just $ bsFromString s }) "ADDRESS") $ "ssl address to bind to" ++ defaultO sslbind , Option [] ["ssl-port"]@@ -395,10 +404,10 @@ (ReqArg (Just . setConfig setErrorLog . Just) "PATH") $ "error log" ++ (defaultC $ join . getErrorLog) , Option [] ["no-access-log"]- (NoArg $ Just $ setConfig setErrorLog Nothing)+ (NoArg $ Just $ setConfig setAccessLog Nothing) $ "don't have an access log" , Option [] ["no-error-log"]- (NoArg $ Just $ setConfig setAccessLog Nothing)+ (NoArg $ Just $ setConfig setErrorLog Nothing) $ "don't have an error log" , Option ['c'] ["compression"] (NoArg $ Just $ setConfig setCompression True)@@ -428,14 +437,15 @@ defaultO f = maybe ", default off" ((", default " ++) . show) $ f conf -- ------------------------------------------------------------------------------ defaultErrorHandler :: MonadSnap m => SomeException -> m () defaultErrorHandler e = do- debug "Snap.Http.Server.Config errorHandler: got exception:"- debug $ show e- logError msg+ debug "Snap.Http.Server.Config errorHandler:"+ req <- getRequest+ let sm = smsg req+ debug $ toString sm+ logError sm+ finishWith $ setContentType "text/plain; charset=utf-8" . setContentLength (fromIntegral $ B.length msg) . setResponseStatus 500 "Internal Server Error"@@ -443,8 +453,13 @@ (>==> enumBuilder (fromByteString msg)) $ emptyResponse where- err = fromString $ show e- msg = mappend "A web handler threw an exception. Details:\n" err+ smsg req = toByteString $ requestErrorMessage req e++ msg = toByteString msgB+ msgB = mconcat [+ fromByteString "A web handler threw an exception. Details:\n"+ , fromShow e+ ]
src/Snap/Internal/Http/Server.hs view
@@ -13,8 +13,13 @@ import Blaze.ByteString.Builder.Enumerator import Blaze.ByteString.Builder.HTTP import Control.Arrow (first, second)+import Control.Monad.CatchIO hiding ( bracket+ , catches+ , finally+ , Handler+ ) import Control.Monad.State.Strict-import Control.Exception+import Control.Exception hiding (catch, throw) import Data.Char import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI@@ -35,6 +40,7 @@ import Data.Typeable import Data.Version import GHC.Conc+import Prelude hiding (catch) import System.PosixCompat.Files hiding (setFileSize) import System.Posix.Types (FileOffset) import System.Locale@@ -105,6 +111,12 @@ instance Exception TerminatedBeforeHandlerException +-- We throw this if we get an exception that escaped from the user handler.+data ExceptionAlreadyCaught = ExceptionAlreadyCaught+ deriving (Show, Typeable)+instance Exception ExceptionAlreadyCaught++ ------------------------------------------------------------------------------ defaultEvType :: EventLoopType #ifdef LIBEV@@ -270,15 +282,22 @@ tickle = go `catches` [ Handler $ \(_ :: TerminatedBeforeHandlerException) -> do return ()+ , Handler $ \(_ :: ExceptionAlreadyCaught) -> do+ return () , Handler $ \(_ :: HttpParseException) -> do return () , Handler $ \(e :: AsyncException) -> do throwIO e , Handler $ \(e :: SomeException) ->- logE elog $ S.concat [ logPrefix , bshow e ] ]+ logE elog $ toByteString $ lmsg e+ ] where- logPrefix = S.concat [ "[", remoteAddress sinfo, "]: error: " ]+ lmsg e = mconcat [ fromByteString "["+ , fromShow $ remoteAddress sinfo+ , fromByteString "]: "+ , fromByteString "an exception escaped to toplevel:\n"+ , fromShow e ] go = do buf <- allocBuffer 16384@@ -297,6 +316,24 @@ ------------------------------------------------------------------------------+requestErrorMessage :: Request -> SomeException -> Builder+requestErrorMessage req e =+ mconcat [ fromByteString "During processing of request from "+ , fromByteString $ rqRemoteAddr req+ , fromByteString ":"+ , fromShow $ rqRemotePort req+ , fromByteString "\nrequest:\n"+ , fromShow $ show req+ , fromByteString "\n"+ , msgB ]+ where+ msgB = mconcat [+ fromByteString "A web handler threw an exception. Details:\n"+ , fromShow e+ ]+++------------------------------------------------------------------------------ sERVER_HEADER :: [ByteString] sERVER_HEADER = [S.concat ["Snap/", snapServerVersion]] @@ -330,28 +367,29 @@ let writeEnd = iterateeDebugWrapper "writeEnd" writeEnd' - liftIO $ debug "Server.httpSession: entered"+ debug "Server.httpSession: entered" mreq <- receiveRequest writeEnd- liftIO $ debug "Server.httpSession: receiveRequest finished"+ debug "Server.httpSession: receiveRequest finished" -- successfully got a request, so restart timer liftIO $ tickle defaultTimeout case mreq of (Just req) -> do- liftIO $ debug $ "Server.httpSession: got request: " ++- show (rqMethod req) ++- " " ++ SC.unpack (rqURI req) ++- " " ++ show (rqVersion req)+ debug $ "Server.httpSession: got request: " +++ show (rqMethod req) +++ " " ++ SC.unpack (rqURI req) +++ " " ++ show (rqVersion req) -- check for Expect: 100-continue checkExpect100Continue req writeEnd logerr <- gets _logError - (req',rspOrig) <- lift $ handler logerr tickle req+ (req',rspOrig) <- (lift $ handler logerr tickle req) `catch`+ errCatch "user hander" req - liftIO $ debug $ "Server.httpSession: finished running user handler"+ debug $ "Server.httpSession: finished running user handler" let rspTmp = rspOrig { rspHttpVersion = rqVersion req } checkConnectionClose (rspHttpVersion rspTmp) (rspHeaders rspTmp)@@ -361,21 +399,23 @@ then (setHeader "Connection" "close" rspTmp) else rspTmp - liftIO $ debug "Server.httpSession: handled, skipping request body"+ debug "Server.httpSession: handled, skipping request body" if rspTransformingRqBody rsp- then liftIO $ debug $+ then debug $ "Server.httpSession: not skipping " ++ "request body, transforming." else do srqEnum <- liftIO $ readIORef $ rqBody req' let (SomeEnumerator rqEnum) = srqEnum - skipStep <- liftIO $ runIteratee $ iterateeDebugWrapper- "httpSession/skipToEof" skipToEof- lift $ rqEnum skipStep+ skipStep <- (liftIO $ runIteratee $ iterateeDebugWrapper+ "httpSession/skipToEof" skipToEof)+ `catch` errCatch "skipping request body" req+ (lift $ rqEnum skipStep) `catch`+ errCatch "skipping request body" req - liftIO $ debug $ "Server.httpSession: request body skipped, " +++ debug $ "Server.httpSession: request body skipped, " ++ "sending response" date <- liftIO getDateString@@ -383,9 +423,10 @@ Map.insert "Server" sERVER_HEADER let rsp' = updateHeaders ins rsp (bytesSent,_) <- sendResponse req rsp' buffer writeEnd onSendFile+ `catch` errCatch "sending response" req - liftIO . debug $ "Server.httpSession: sent " ++- (show bytesSent) ++ " bytes"+ debug $ "Server.httpSession: sent " +++ (show bytesSent) ++ " bytes" maybe (logAccess req rsp') (\_ -> logAccess req $ setContentLength bytesSent rsp')@@ -399,11 +440,20 @@ tickle handler Nothing -> do- liftIO $ debug $ "Server.httpSession: parser did not produce a " +++ debug $ "Server.httpSession: parser did not produce a " ++ "request, ending session" return () + where+ errCatch phase req e = do+ logError $ toByteString $+ mconcat [ fromByteString "httpSession caught an exception during "+ , fromByteString phase+ , fromByteString " phase:\n"+ , requestErrorMessage req e ]+ throw ExceptionAlreadyCaught + ------------------------------------------------------------------------------ checkExpect100Continue :: Request -> Iteratee ByteString IO ()@@ -483,7 +533,7 @@ setEnumerator req = {-# SCC "receiveRequest/setEnumerator" #-} do if isChunked then do- liftIO $ debug $ "receiveRequest/setEnumerator: " +++ debug $ "receiveRequest/setEnumerator: " ++ "input in chunked encoding" let e = joinI . readChunkedTransferEncoding liftIO $ writeIORef (rqBody req)@@ -497,10 +547,10 @@ hasContentLength :: Int64 -> ServerMonad () hasContentLength len = do- liftIO $ debug $ "receiveRequest/setEnumerator: " +++ debug $ "receiveRequest/setEnumerator: " ++ "request had content-length " ++ show len liftIO $ writeIORef (rqBody req) (SomeEnumerator e)- liftIO $ debug "receiveRequest/setEnumerator: body enumerator set"+ debug "receiveRequest/setEnumerator: body enumerator set" where e :: Enumerator ByteString IO a e st = do@@ -546,8 +596,8 @@ getIt :: ServerMonad Request getIt = {-# SCC "receiveRequest/parseForm/getIt" #-} do- liftIO $ debug "parseForm: got application/x-www-form-urlencoded"- liftIO $ debug "parseForm: reading POST body"+ debug "parseForm: got application/x-www-form-urlencoded"+ debug "parseForm: reading POST body" senum <- liftIO $ readIORef $ rqBody req let (SomeEnumerator enum) = senum consumeStep <- liftIO $ runIteratee consume@@ -557,7 +607,7 @@ body <- liftM S.concat $ lift $ enum step let newParams = parseUrlEncoded body - liftIO $ debug "parseForm: stuffing 'enumBS body' into request"+ debug "parseForm: stuffing 'enumBS body' into request" let e = enumBS body >==> I.joinI . I.take 0
+ src/Snap/Internal/Http/Server/Address.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable #-}++module Snap.Internal.Http.Server.Address+ ( getHostAddr+ , getSockAddr+ , getAddress+ ) where++-------------------------------------------------------------------------------+import Network.Socket+import Data.Maybe+import Control.Monad+import Control.Exception+import Data.Typeable+import Data.ByteString (ByteString)+import qualified Data.ByteString as S+import Data.ByteString.Char8 ()+import Data.ByteString.Internal (c2w, w2c)++-------------------------------------------------------------------------------+data AddressNotSupportedException = AddressNotSupportedException String+ deriving (Typeable)++instance Show AddressNotSupportedException where+ show (AddressNotSupportedException x) = "Address not supported: " ++ x++instance Exception AddressNotSupportedException++-------------------------------------------------------------------------------+getHostAddr :: SockAddr -> IO String+getHostAddr addr =+ (fromMaybe "" . fst) `liftM` getNameInfo [NI_NUMERICHOST] True False addr++-------------------------------------------------------------------------------+getAddress :: SockAddr -> IO (Int, ByteString)+getAddress addr = do+ port <- case addr of+ SockAddrInet p _ -> return p+ SockAddrInet6 p _ _ _ -> return p+ x -> throwIO $ AddressNotSupportedException $ show x+ host <- getHostAddr addr+ return (fromIntegral port, S.pack $ map c2w host)++-------------------------------------------------------------------------------+getSockAddr :: Int+ -> ByteString+ -> IO (Family, SockAddr)+getSockAddr p s | s == "*" = ipV4Addr p iNADDR_ANY+getSockAddr p s | s == "::" = ipV6Addr p iN6ADDR_ANY+getSockAddr p s = do+ let hints = defaultHints { addrFlags = [AI_NUMERICHOST] }+ ai <- getAddrInfo (Just hints) (Just $ map w2c $ S.unpack s) Nothing+ if ai == [] then throwIO $ AddressNotSupportedException $ show s+ else do+ case addrAddress $ head ai of+ SockAddrInet _ h -> ipV4Addr p h+ SockAddrInet6 _ _ h _ -> ipV6Addr p h+ x -> throwIO $ AddressNotSupportedException $ show x++ipV4Addr :: Int -> HostAddress -> IO (Family, SockAddr)+ipV4Addr p h = return (AF_INET, SockAddrInet (fromIntegral p) h)++ipV6Addr :: Int -> HostAddress6 -> IO (Family, SockAddr)+ipV6Addr p h = return (AF_INET6, SockAddrInet6 (fromIntegral p) 0 h 0)
src/Snap/Internal/Http/Server/HttpPort.hs view
@@ -29,30 +29,19 @@ import Snap.Internal.Debug import Snap.Internal.Http.Server.Backend+import Snap.Internal.Http.Server.Address ------------------------------------------------------------------------------ bindHttp :: ByteString -> Int -> IO ListenSocket bindHttp bindAddr bindPort = do- sock <- socket AF_INET Stream 0- addr <- getHostAddr bindPort bindAddr+ (family, addr) <- getSockAddr bindPort bindAddr+ sock <- socket family Stream 0 debug $ "bindHttp: binding port " ++ show addr setSocketOption sock ReuseAddr 1 bindSocket sock addr listen sock 150 debug $ "bindHttp: bound socket " ++ show sock return $ ListenHttp sock----------------------------------------------------------------------------------getHostAddr :: Int- -> ByteString- -> IO SockAddr-getHostAddr p s = do- h <- if s == "*"- then return iNADDR_ANY- else inet_addr (map w2c . B.unpack $ s)-- return $ SockAddrInet (fromIntegral p) h ------------------------------------------------------------------------------
src/Snap/Internal/Http/Server/LibevBackend.hs view
@@ -57,6 +57,7 @@ import Snap.Internal.Debug import Snap.Internal.Http.Server.Date import Snap.Internal.Http.Server.Backend+import Snap.Internal.Http.Server.Address import qualified Snap.Internal.Http.Server.ListenHelpers as Listen #if defined(HAS_SENDFILE)@@ -289,17 +290,6 @@ -------------------------------------------------------------------------------getAddr :: SockAddr -> IO (ByteString, Int)-getAddr addr =- case addr of- SockAddrInet p ha -> do- s <- liftM (S.pack . map c2w) (inet_ntoa ha)- return (s, fromIntegral p)-- a -> throwIO $ AddressNotSupportedException (show a)--------------------------------------------------------------------------------- -- | Throws a timeout exception to the handling thread. The thread will clean -- up everything. timerCallback :: EvLoopPtr -- ^ loop obj@@ -451,8 +441,8 @@ -- set_linger fd c_setnonblocking fd - (raddr, rport) <- getAddr peerName- (laddr, lport) <- getAddr sockName+ (rport, raddr) <- getAddress peerName+ (lport, laddr) <- getAddress sockName let lp = _evLoop backend
src/Snap/Internal/Http/Server/SimpleBackend.hs view
@@ -22,7 +22,6 @@ import qualified Data.ByteString as S import Data.ByteString.Internal (c2w) import Data.Maybe-import Data.Typeable import Foreign hiding (new) import Foreign.C import GHC.Conc (labelThread, forkOnIO)@@ -34,6 +33,7 @@ import qualified Snap.Internal.Http.Server.TimeoutManager as TM import Snap.Internal.Http.Server.TimeoutManager (TimeoutManager) import Snap.Internal.Http.Server.Backend+import Snap.Internal.Http.Server.Address import qualified Snap.Internal.Http.Server.ListenHelpers as Listen import Snap.Iteratee hiding (map) @@ -126,16 +126,6 @@ -------------------------------------------------------------------------------data AddressNotSupportedException = AddressNotSupportedException String- deriving (Typeable)--instance Show AddressNotSupportedException where- show (AddressNotSupportedException x) = "Address not supported: " ++ x--instance Exception AddressNotSupportedException--------------------------------------------------------------------------------- runSession :: Int -> SessionHandler -> TimeoutManager@@ -149,21 +139,8 @@ debug $ "Backend.withConnection: running session: " ++ show addr labelThread curId $ "connHndl " ++ show fd - (rport,rhost) <-- case addr of- SockAddrInet p h -> do- h' <- inet_ntoa h- return (fromIntegral p, S.pack $ map c2w h')- x -> throwIO $ AddressNotSupportedException $ show x-- laddr <- getSocketName sock-- (lport,lhost) <-- case laddr of- SockAddrInet p h -> do- h' <- inet_ntoa h- return (fromIntegral p, S.pack $ map c2w h')- x -> throwIO $ AddressNotSupportedException $ show x+ (rport,rhost) <- getAddress addr+ (lport,lhost) <- getSocketName sock >>= getAddress let sinfo = SessionInfo lhost lport rhost rport $ Listen.isSecure lsock
src/Snap/Internal/Http/Server/TLS.hs view
@@ -42,6 +42,8 @@ import OpenSSL.Session import qualified OpenSSL.Session as SSL import Unsafe.Coerce++import Snap.Internal.Http.Server.Address #endif @@ -90,8 +92,8 @@ -> FilePath -> IO ListenSocket bindHttps bindAddress bindPort cert key = do- sock <- Socket.socket Socket.AF_INET Socket.Stream 0- addr <- getHostAddr bindPort bindAddress+ (family, addr) <- getSockAddr bindPort bindAddress+ sock <- Socket.socket family Socket.Stream 0 Socket.setSocketOption sock Socket.ReuseAddr 1 Socket.bindSocket sock addr Socket.listen sock 150@@ -154,18 +156,6 @@ if S.null b then return Nothing else return $ Just b where ssl = unsafeCoerce aSSL----------------------------------------------------------------------------------getHostAddr :: Int- -> ByteString- -> IO Socket.SockAddr-getHostAddr p s = do- h <- if s == "*"- then return Socket.iNADDR_ANY- else Socket.inet_addr (S.unpack $ s)-- return $ Socket.SockAddrInet (fromIntegral p) h #endif
src/System/FastLogger.hs view
@@ -23,6 +23,7 @@ import Data.Int import Data.IORef import Data.Monoid+import Prelude hiding (catch) import System.IO import Snap.Internal.Http.Server.Date@@ -136,13 +137,19 @@ initialize >>= go where- openIt = if filePath == "-"- then return stdout- else if filePath == "stderr"- then return stderr- else openFile filePath AppendMode+ openIt =+ if filePath == "-"+ then return stdout+ else if filePath == "stderr"+ then return stderr+ else openFile filePath AppendMode `catch`+ \(e::SomeException) -> do+ hPutStrLn stderr $ "can't open log file " ++ filePath+ hPutStrLn stderr $ "exception: " ++ show e+ hPutStrLn stderr $ "logging to stderr instead."+ return stderr - closeIt h = if filePath == "-" || filePath == "stderr"+ closeIt h = if h == stdout || h == stderr then return () else hClose h @@ -175,11 +182,16 @@ let !msgs = toLazyByteString dl h <- readIORef href- L.hPut h msgs- hFlush h+ (do L.hPut h msgs+ hFlush h) `catch` \(e::SomeException) -> do+ hPutStrLn stderr $ "got exception writing to log " +++ filePath ++ ": " ++ show e+ hPutStrLn stderr $ "writing log entries to stderr."+ L.hPut stderr msgs+ hFlush stderr -- close the file every 15 minutes (for log rotation)- t <- getCurrentDateTime+ t <- getCurrentDateTime old <- readIORef lastOpened if t-old > 900
test/snap-server-testsuite.cabal view
@@ -37,25 +37,25 @@ directory-tree, enumerator >= 0.4.13.1 && <0.5, filepath,- http-enumerator >= 0.6.5.4 && <0.7,+ http-enumerator >= 0.7 && <0.8, HUnit >= 1.2 && < 2,- monads-fd >= 0.1.0.4 && <0.2,+ mtl >= 2 && <3, murmur-hash >= 0.1 && < 0.2, network == 2.3.*, old-locale, parallel > 2, process,- snap-core >= 0.5.3 && <0.6,+ snap-core >= 0.5.4 && <0.6, template-haskell,- test-framework >= 0.3.1 && <0.4,+ test-framework >= 0.3.1 && <0.5, test-framework-hunit >= 0.2.5 && < 0.3, test-framework-quickcheck2 >= 0.2.6 && < 0.3, text >= 0.11 && <0.12, time, tls >= 0.7.1 && <0.8, transformers,- vector >= 0.7 && <0.8,- vector-algorithms >= 0.4 && <0.5,+ vector >= 0.7 && <0.10,+ vector-algorithms >= 0.4 && <0.6, PSQueue >= 1.1 && <1.2 if !os(windows)@@ -75,7 +75,7 @@ ghc-prof-options: -prof -auto-all ghc-options: -O2 -Wall -fhpc -fwarn-tabs -funbox-strict-fields -threaded- -fno-warn-unused-do-bind+ -fno-warn-unused-do-bind -rtsopts Executable pongserver@@ -99,20 +99,20 @@ enumerator >= 0.4.7 && <0.5, filepath, HUnit >= 1.2 && < 2,- monads-fd >= 0.1.0.4 && <0.2,+ mtl >= 2 && <3, murmur-hash >= 0.1 && < 0.2, old-locale, parallel > 2, MonadCatchIO-transformers >= 0.2.1 && < 0.3, network == 2.3.*,- snap-core >= 0.5.3 && <0.6,+ snap-core >= 0.5.4 && <0.6, template-haskell, time, transformers,- unix-compat == 0.2.*,+ unix-compat >= 0.2 && <0.4, utf8-string >= 0.3.6 && <0.4,- vector >= 0.7 && <0.8,- vector-algorithms >= 0.4 && <0.5,+ vector >= 0.7 && <0.10,+ vector-algorithms >= 0.4 && <0.6, PSQueue >= 1.1 && <1.2 if flag(portable) || os(windows)@@ -150,7 +150,7 @@ cpp-options: -DPORTABLE ghc-options: -Wall -O2 -fwarn-tabs -funbox-strict-fields -threaded- -fno-warn-unused-do-bind+ -fno-warn-unused-do-bind -rtsopts ghc-prof-options: -prof -auto-all @@ -176,21 +176,20 @@ filepath, HUnit >= 1.2 && < 2, MonadCatchIO-transformers >= 0.2.1 && < 0.3,- monads-fd >= 0.1.0.4 && <0.2,+ mtl >= 2 && <3, murmur-hash >= 0.1 && < 0.2, network == 2.3.*, old-locale, parallel > 2,- snap-core >= 0.5.3 && <0.6,+ snap-core >= 0.5.4 && <0.6, template-haskell,- test-framework >= 0.3.1 && <0.4,+ test-framework >= 0.3.1 && <0.5, test-framework-hunit >= 0.2.5 && < 0.3, test-framework-quickcheck2 >= 0.2.6 && < 0.3, text >= 0.11 && <0.12, time,- transformers,- vector >= 0.7 && <0.8,- vector-algorithms >= 0.4 && <0.5,+ vector >= 0.7 && <0.10,+ vector-algorithms >= 0.4 && <0.6, PSQueue >= 1.1 && <1.2 if !os(windows)@@ -209,7 +208,7 @@ ghc-options: -O2 -Wall -fwarn-tabs -funbox-strict-fields -threaded- -fno-warn-unused-do-bind+ -fno-warn-unused-do-bind -rtsopts ghc-prof-options: -prof -auto-all @@ -219,13 +218,13 @@ ghc-options: -O2 -Wall -fwarn-tabs -funbox-strict-fields -threaded- -fno-warn-unused-do-bind+ -fno-warn-unused-do-bind -rtsopts ghc-prof-options: -prof -auto-all build-depends: base >= 4.3 && < 5, network == 2.3.*,- http-enumerator >= 0.6.5.4 && <0.7,+ http-enumerator >= 0.7 && <0.8, tls >= 0.7.1 && <0.8, criterion >= 0.5 && <0.6
test/suite/Test/Blackbox.hs view
@@ -374,7 +374,8 @@ parseURL :: String -> IO (HTTP.Request IO) parseURL url = do req <- HTTP.parseUrl url- return $ req { HTTP.checkCerts = const $ return CertificateUsageAccept }+ return $ req { HTTP.checkCerts = const $ const $+ return CertificateUsageAccept } ------------------------------------------------------------------------------