X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FHttpd.hs;h=2dca5120d8c6e0e21f40b88a03959d4017c848d4;hb=0aa4f6d758fc12fba468f7cd399bbcc48f693d1e;hp=d9f28f110e5f1c668a3fc9f539b9f2c4981e3959;hpb=0214f070b80791323430e21b53bcbe8a77b71b23;p=Lucu.git diff --git a/Network/HTTP/Lucu/Httpd.hs b/Network/HTTP/Lucu/Httpd.hs index d9f28f1..2dca512 100644 --- a/Network/HTTP/Lucu/Httpd.hs +++ b/Network/HTTP/Lucu/Httpd.hs @@ -1,35 +1,38 @@ +{-# LANGUAGE + 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 +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 -- > @@ -40,99 +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 - - -- 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 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 - 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 ← newInteractionQueue + 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)