direct-http 0.5.1 → 0.5.2
raw patch · 2 files changed
+63/−51 lines, 2 filesdep ~direct-daemonizePVP ok
version bump matches the API change (PVP)
Dependency ranges changed: direct-daemonize
API changes (from Hackage documentation)
Files
- Network/HTTP.hs +57/−49
- direct-http.cabal +6/−2
Network/HTTP.hs view
@@ -399,42 +399,6 @@ -> IO () -- ^ Never actually returns. acceptLoop parameters handler = do- (listenSockets, accessLogMaybeHandle, errorLogMaybeHandle)- <- catch- (do- listenSockets <-- mapM createListenSocket (serverParametersListenSockets parameters)- accessLogMaybeHandle- <- case serverParametersAccessLogPath parameters of- Nothing -> return Nothing- Just path -> openBinaryFile path AppendMode- >>= return . Just- errorLogMaybeHandle- <- case serverParametersErrorLogPath parameters of- Nothing -> if serverParametersDaemonize parameters- then return Nothing- else return $ Just stdout- Just path -> openBinaryFile path AppendMode- >>= return . Just- return (listenSockets, accessLogMaybeHandle, errorLogMaybeHandle))- (\e -> do- hPutStrLn stderr- $ "Failed to start: "- ++ (show (e :: SomeException))- exitFailure)- accessLogMaybeHandleMVar <- newMVar accessLogMaybeHandle- errorLogMaybeHandleMVar <- newMVar errorLogMaybeHandle- let forkPrimitive = serverParametersForkPrimitive parameters- threadSetMVar <- newMVar Set.empty- threadTerminationMSem <- MSem.new 0- let state = HTTPState {- httpStateAccessLogMaybeHandleMVar = accessLogMaybeHandleMVar,- httpStateErrorLogMaybeHandleMVar = errorLogMaybeHandleMVar,- httpStateForkPrimitive = forkPrimitive,- httpStateThreadSetMVar = threadSetMVar,- httpStateThreadTerminationMSem = threadTerminationMSem,- httpStateMaybeConnection = Nothing- } if serverParametersDaemonize parameters then daemonize (defaultDaemonOptions { daemonUserToChangeTo =@@ -442,20 +406,64 @@ daemonGroupToChangeTo = serverParametersGroupToChangeTo parameters })- $ acceptLoop' state listenSockets- else acceptLoop' state listenSockets- where acceptLoop' state listenSockets = do- let acceptLoop'' :: Network.Socket -> HTTP ()- acceptLoop'' listenSocket = do- (socket, peer) <- liftBase $ Network.accept listenSocket- httpFork $ requestLoop socket peer handler- acceptLoop'' listenSocket+ (initialize)+ (\bootstrap -> acceptLoop' bootstrap)+ else do+ bootstrap <- initialize+ acceptLoop' bootstrap+ where initialize = do+ accessLogMaybeHandle+ <- case serverParametersAccessLogPath parameters of+ Nothing -> return Nothing+ Just path -> liftBase $ openBinaryFile path AppendMode+ >>= return . Just+ errorLogMaybeHandle+ <- case serverParametersErrorLogPath parameters of+ Nothing -> if serverParametersDaemonize parameters+ then return Nothing+ else return $ Just stdout+ Just path -> liftBase $ openBinaryFile path AppendMode+ >>= return . Just+ listenSockets <-+ catch (mapM createListenSocket+ (serverParametersListenSockets parameters))+ (\e -> do+ case errorLogMaybeHandle of+ Nothing -> return ()+ Just errorLogHandle -> do+ hPutStrLn errorLogHandle $+ "Failed to start: " ++ (show (e :: SomeException))+ liftBase $ exitFailure)+ return (listenSockets, accessLogMaybeHandle, errorLogMaybeHandle)+ acceptLoop' (listenSockets,+ accessLogMaybeHandle,+ errorLogMaybeHandle) = do+ accessLogMaybeHandleMVar <- newMVar accessLogMaybeHandle+ errorLogMaybeHandleMVar <- newMVar errorLogMaybeHandle+ let forkPrimitive = serverParametersForkPrimitive parameters+ threadSetMVar <- newMVar Set.empty+ threadTerminationMSem <- MSem.new 0+ let state = HTTPState {+ httpStateAccessLogMaybeHandleMVar =+ accessLogMaybeHandleMVar,+ httpStateErrorLogMaybeHandleMVar =+ errorLogMaybeHandleMVar,+ httpStateForkPrimitive = forkPrimitive,+ httpStateThreadSetMVar = threadSetMVar,+ httpStateThreadTerminationMSem = threadTerminationMSem,+ httpStateMaybeConnection = Nothing+ } flip runReaderT state $ do httpLog $ "Server started." threadIDs <- mapM (\listenSocket -> httpFork $ acceptLoop'' listenSocket) listenSockets threadWaitLoop+ acceptLoop'' :: Network.Socket -> HTTP ()+ acceptLoop'' listenSocket = do+ (socket, peer) <- liftBase $ Network.accept listenSocket+ httpFork $ requestLoop socket peer handler+ acceptLoop'' listenSocket threadWaitLoop = do state <- getHTTPState let mvar = httpStateThreadSetMVar state@@ -477,11 +485,11 @@ Network.SockAddrInet _ _ -> Network.AF_INET Network.SockAddrInet6 _ _ _ _ -> Network.AF_INET6 Network.SockAddrUnix _ -> Network.AF_UNIX- listenSocket <- Network.socket addressFamily- Network.Stream- Network.defaultProtocol- Network.bindSocket listenSocket address- Network.listen listenSocket 1024+ listenSocket <- liftBase $ Network.socket addressFamily+ Network.Stream+ Network.defaultProtocol+ liftBase $ Network.bind listenSocket address+ liftBase $ Network.listen listenSocket 1024 return listenSocket
direct-http.cabal view
@@ -1,5 +1,5 @@ name: direct-http-version: 0.5.1+version: 0.5.2 cabal-version: >= 1.10 build-type: Simple license: BSD3@@ -22,6 +22,10 @@ to it, and makes several design decisions differently. The biggest is the use of MonadControlBase for exceptions. .+ Version 0.5.2: Actually works with daemonization, by using a feature of+ direct-daemon added for this purpose to open the socket after forking but+ before dropping privileges.+ . Version 0.5.1: Uses SafeSemaphore, which is the future, rather than QSem from base, which is deprecated. .@@ -42,7 +46,7 @@ time >= 1.4 && < 2, old-locale >= 1.0.0.4 && < 2, unix >= 2.5.1.0 && < 3,- direct-daemonize >= 3.0 && < 4,+ direct-daemonize >= 3.1 && < 4, transformers-base >= 0.4.1 && < 1, lifted-base >= 0.1.1 && < 2, monad-control >= 0.3.1.3 && < 1,