X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FHttpd.hs;h=3f2d7330796d7acea4cebf8a39680a24a44fa0b9;hb=8a7649cdf5d96d511dd6e2dfa4e2b741ffac4f9a;hp=d9f28f110e5f1c668a3fc9f539b9f2c4981e3959;hpb=0214f070b80791323430e21b53bcbe8a77b71b23;p=Lucu.git diff --git a/Network/HTTP/Lucu/Httpd.hs b/Network/HTTP/Lucu/Httpd.hs index d9f28f1..3f2d733 100644 --- a/Network/HTTP/Lucu/Httpd.hs +++ b/Network/HTTP/Lucu/Httpd.hs @@ -1,35 +1,35 @@ +{-# LANGUAGE + CPP + , UnicodeSyntax + #-} -- |The entry point of Lucu httpd. module Network.HTTP.Lucu.Httpd ( FallbackHandler , runHttpd ) where - -import Control.Concurrent -import Control.Exception -import Control.Monad -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 +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 -- |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 -- > @@ -40,99 +40,73 @@ 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 [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 - - -- FIXME: TERRIBLE CODE. NEED MAJOR REWRITE. - case cnfSSLConfig cnf of - Nothing - -> return () - Just scnf - -> do case cnfServerV4Addr cnf of - Nothing - -> return () - Just v4addr - -> do so <- listenOn AF_INET v4addr (sslServerPort scnf) - p <- socketPort so - -- FIXME: Don't throw away the thread - -- ID as we can't kill it later - -- then. [1] - _ <- forkIO $ httpLoop p (sslContext scnf, so) - return () - - case cnfServerV6Addr cnf of - Nothing - -> return () - Just v6addr - -> do so <- listenOn AF_INET6 v6addr (sslServerPort scnf) - p <- socketPort so - -- FIXME: [1] - _ <- forkIO $ httpLoop p (sslContext scnf, so) - return () - - case cnfServerV4Addr cnf of - Nothing - -> return () - Just v4addr - -> do so <- listenOn AF_INET v4addr (cnfServerPort cnf) - p <- socketPort so - -- FIXME: [1] - _ <- forkIO $ httpLoop p so - return () - - case cnfServerV6Addr cnf of - Nothing - -> return () - Just v6addr - -> do so <- listenOn AF_INET6 v6addr (cnfServerPort cnf) - p <- socketPort so - -- FIXME: [1] - _ <- forkIO $ httpLoop p so - return () - + 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 - listenOn :: Family -> HostName -> ServiceName -> IO Socket + 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 + + listenOn ∷ Family → HostName → ServiceName → IO Socket listenOn fam host srv - = do proto <- getProtocolNumber "tcp" + = do proto ← getProtocolNumber "tcp" let hints = defaultHints { addrFlags = [AI_PASSIVE] , addrFamily = fam , addrSocketType = Stream , addrProtocol = proto } - addrs <- getAddrInfo (Just hints) (Just host) (Just srv) + addrs ← getAddrInfo (Just hints) (Just host) (Just srv) let addr = head addrs bracketOnError (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)) - (sClose) - (\ sock -> + sClose + (\ sock → do setSocketOption sock ReuseAddr 1 bindSocket sock (addrAddress addr) listen sock maxListenQueue return sock ) - httpLoop :: SocketLike s => PortNumber -> s -> IO () + 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 + = 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 - waitForever :: IO () + waitForever ∷ IO () waitForever = forever (threadDelay 1000000)