X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FHttpd.hs;h=2dca5120d8c6e0e21f40b88a03959d4017c848d4;hp=d180202759a903fe8a478eae1ecaf28d5b50c1e1;hb=0aa4f6d;hpb=8225cc52ffe4c3d900ae1f79573089be230b80bd diff --git a/Network/HTTP/Lucu/Httpd.hs b/Network/HTTP/Lucu/Httpd.hs index d180202..2dca512 100644 --- a/Network/HTTP/Lucu/Httpd.hs +++ b/Network/HTTP/Lucu/Httpd.hs @@ -1,36 +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 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 +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 -- > @@ -41,81 +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 - + 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) + [ 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) + , 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 ← cnfServerV4Addr cnf + return ( launchListener =≪ listenOn AF_INET addr (cnfServerPort cnf) ) - , do addr <- cnfServerV6Addr cnf - return ( launchListener =<< listenOn AF_INET6 addr (cnfServerPort cnf) + , do addr ← cnfServerV6Addr cnf + return ( launchListener =≪ listenOn AF_INET6 addr (cnfServerPort cnf) ) ] - sequence_ launchers waitForever where - launchListener :: SocketLike s => s -> IO () + launchListener ∷ SocketLike s ⇒ s → IO () launchListener so - = do p <- SL.socketPort so + = do p ← SL.socketPort so -- FIXME: Don't throw away the thread ID as we can't -- kill it later then. [1] - _ <- forkIO $ httpLoop p so - return () + void $ forkIO $ httpLoop p so - listenOn :: Family -> HostName -> ServiceName -> IO Socket + 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 -> + (\ 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)