X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FHttpd.hs;h=2dca5120d8c6e0e21f40b88a03959d4017c848d4;hb=0aa4f6d;hp=bab8d72ff5639362d1aee310ef7e189c5fc4bf84;hpb=9ac730212cb361eb10e5fe4ad0eec6758e2b200a;p=Lucu.git diff --git a/Network/HTTP/Lucu/Httpd.hs b/Network/HTTP/Lucu/Httpd.hs index bab8d72..2dca512 100644 --- a/Network/HTTP/Lucu/Httpd.hs +++ b/Network/HTTP/Lucu/Httpd.hs @@ -1,34 +1,38 @@ +{-# LANGUAGE + 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 System.Posix.Signals -- |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. +-- 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. -- -- 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. +-- calling @'installHandler' 'sigPIPE' 'Ignore' 'Nothing'@. This can +-- hardly cause a problem though. -- -- Example: -- +-- > {-# LANGUAGE OverloadedStrings #-} -- > module Main where -- > import Network.HTTP.Lucu -- > @@ -39,57 +43,72 @@ import System.Posix.Signals -- > 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 = emptyResource { +-- > resGet +-- > = Just $ do setContentType $ mkMIMEType "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 void $ installHandler sigPIPE Ignore Nothing + let launchers + = catMaybes + [ 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) + ) + , do addr ← cnfServerV4Addr cnf + return ( launchListener =≪ listenOn AF_INET addr (cnfServerPort cnf) + ) + , do addr ← cnfServerV6Addr cnf + return ( launchListener =≪ listenOn AF_INET6 addr (cnfServerPort cnf) + ) + ] + 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. [1] + 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 ← newInteractionQueue + 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)