X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FHttpd.hs;h=4d724eb92843f6f9d1fd6c97dc46cef553aaa376;hb=1ead053df6a792edafa9d714c4c038a8a9c3ad16;hp=654e50d43c46b1043f55cf0eeaa49032d6e26046;hpb=73b5fba4907604681d778d3bd54cd65fd84b4454;p=Lucu.git diff --git a/Network/HTTP/Lucu/Httpd.hs b/Network/HTTP/Lucu/Httpd.hs index 654e50d..4d724eb 100644 --- a/Network/HTTP/Lucu/Httpd.hs +++ b/Network/HTTP/Lucu/Httpd.hs @@ -1,34 +1,36 @@ +{-# LANGUAGE + CPP + , UnicodeSyntax + #-} -- |The entry point of Lucu httpd. module Network.HTTP.Lucu.Httpd ( FallbackHandler , runHttpd ) where - -import Control.Concurrent -import Network -import qualified Network.Socket as So -import Network.HTTP.Lucu.Config -import Network.HTTP.Lucu.Interaction -import Network.HTTP.Lucu.RequestReader -import Network.HTTP.Lucu.Resource.Tree -import Network.HTTP.Lucu.ResponseWriter -import qualified OpenSSL.Session as SSL -import System.IO -import System.Posix.Signals +import Control.Concurrent +import Control.Exception +import Control.Monad +import Control.Monad.Unicode +import Data.Maybe +import Network.BSD +import Network.Socket +import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.Interaction +import Network.HTTP.Lucu.RequestReader +import Network.HTTP.Lucu.Resource.Tree +import Network.HTTP.Lucu.ResponseWriter +import Network.HTTP.Lucu.SocketLike as SL +import Prelude.Unicode -- |This is the entry point of Lucu httpd. It listens to a socket and --- waits for clients. Computation of 'runHttpd' never stops by itself --- so the only way to stop it is to raise an exception in the thread --- computing it. --- --- Note that 'runHttpd' automatically makes SIGPIPE be ignored by --- computing @'System.Posix.Signals.installHandler' --- 'System.Posix.Signals.sigPIPE' 'System.Posix.Signals.Ignore' --- 'Prelude.Nothing'@. This can hardly cause a problem but it may do. +-- waits for clients. 'runHttpd' never stops by itself so the only way +-- to stop it is to raise an exception in the thread running it. -- -- Example: -- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > {-# LANGUAGE QuasiQuotes #-} -- > module Main where -- > import Network.HTTP.Lucu -- > @@ -38,58 +40,74 @@ import System.Posix.Signals -- > in -- > runHttpd config resourcees [] -- > --- > helloWorld :: ResourceDef --- > helloWorld = ResourceDef { --- > resUsesNativeThread = False --- > , resIsGreedy = False --- > , resGet --- > = Just $ do setContentType $ read "text/plain" --- > output "Hello, world!" --- > , resHead = Nothing --- > , resPost = Nothing --- > , resPut = Nothing --- > , resDelete = Nothing +-- > helloWorld :: Resource +-- > helloWorld = emptyResource { +-- > resGet +-- > = Just $ do setContentType [mimeType| text/plain |] +-- > putChunk "Hello, world!" -- > } -runHttpd :: Config -> ResTree -> [FallbackHandler] -> IO () +runHttpd ∷ Config → ResTree → [FallbackHandler] → IO () runHttpd cnf tree fbs = withSocketsDo $ - do installHandler sigPIPE Ignore Nothing - - case cnfSSLConfig cnf of - Nothing - -> return () - Just scnf - -> do so <- listenOn (sslServerPort scnf) - _loopTID <- forkIO $ httpsLoop (sslContext scnf) so - return () - - httpLoop =<< listenOn (cnfServerPort cnf) + do let launchers + = catMaybes + [ do addr ← cnfServerV4Addr cnf + return ( launchListener =≪ listenOn AF_INET addr (cnfServerPort cnf) + ) + , do addr ← cnfServerV6Addr cnf + return ( launchListener =≪ listenOn AF_INET6 addr (cnfServerPort cnf) + ) +#if defined(HAVE_SSL) + , do scnf ← cnfSSLConfig cnf + addr ← cnfServerV4Addr cnf + return ( do so ← listenOn AF_INET addr (sslServerPort scnf) + launchListener (sslContext scnf, so) + ) + , do scnf ← cnfSSLConfig cnf + addr ← cnfServerV6Addr cnf + return ( do so ← listenOn AF_INET6 addr (sslServerPort scnf) + launchListener (sslContext scnf, so) + ) +#endif + ] + sequence_ launchers + waitForever where - httpLoop :: Socket -> IO () - httpLoop so - = do (h, addr) <- acceptHTTP so - tQueue <- newInteractionQueue - readerTID <- forkIO $ requestReader cnf tree fbs h addr tQueue - _writerTID <- forkIO $ responseWriter cnf h tQueue readerTID - httpLoop so + launchListener ∷ SocketLike s ⇒ s → IO () + launchListener so + = do p ← SL.socketPort so + -- FIXME: Don't throw away the thread ID as we can't + -- kill it later then. + void ∘ forkIO $ httpLoop p so - httpsLoop :: SSL.SSLContext -> Socket -> IO () - httpsLoop ctx so - = do (ssl, addr) <- acceptHTTPS ctx so - tQueue <- newInteractionQueue - readerTID <- forkIO $ requestReader cnf tree fbs ssl addr tQueue - _writerTID <- forkIO $ responseWriter cnf ssl tQueue readerTID - httpsLoop ctx so + listenOn ∷ Family → HostName → ServiceName → IO Socket + listenOn fam host srv + = do proto ← getProtocolNumber "tcp" + let hints = defaultHints { + addrFlags = [AI_PASSIVE] + , addrFamily = fam + , addrSocketType = Stream + , addrProtocol = proto + } + addrs ← getAddrInfo (Just hints) (Just host) (Just srv) + let addr = head addrs + bracketOnError + (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)) + sClose + (\ sock → + do setSocketOption sock ReuseAddr 1 + bindSocket sock (addrAddress addr) + listen sock maxListenQueue + return sock + ) - acceptHTTP :: Socket -> IO (Handle, So.SockAddr) - acceptHTTP soSelf - = do (soPeer, addr) <- So.accept soSelf - hPeer <- So.socketToHandle soPeer ReadWriteMode - return (hPeer, addr) + httpLoop ∷ SocketLike s ⇒ PortNumber → s → IO () + httpLoop port so + = do (h, addr) ← SL.accept so + tQueue ← mkInteractionQueue + readerTID ← forkIO $ requestReader cnf tree fbs h port addr tQueue + _writerTID ← forkIO $ responseWriter cnf h tQueue readerTID + httpLoop port so - acceptHTTPS :: SSL.SSLContext -> Socket -> IO (SSL.SSL, So.SockAddr) - acceptHTTPS ctx so - = do (so', addr) <- So.accept so - ssl <- SSL.connection ctx so' - SSL.accept ssl - return (ssl, addr) + waitForever ∷ IO () + waitForever = forever (threadDelay 1000000)