4 -- |The entry point of Lucu httpd.
5 module Network.HTTP.Lucu.Httpd
10 import Control.Concurrent
11 import Control.Exception
13 import Control.Monad.Unicode
17 import Network.HTTP.Lucu.Config
18 import Network.HTTP.Lucu.Interaction
19 import Network.HTTP.Lucu.RequestReader
20 import Network.HTTP.Lucu.Resource.Tree
21 import Network.HTTP.Lucu.ResponseWriter
22 import Network.HTTP.Lucu.SocketLike as SL
23 import System.Posix.Signals
25 -- |This is the entry point of Lucu httpd. It listens to a socket and
26 -- waits for clients. 'runHttpd' never stops by itself so the only way
27 -- to stop it is to raise an exception in the thread running it.
29 -- Note that 'runHttpd' automatically makes SIGPIPE be ignored by
30 -- calling @'installHandler' 'sigPIPE' 'Ignore' 'Nothing'@. This can
31 -- hardly cause a problem though.
35 -- > {-# LANGUAGE OverloadedStrings #-}
36 -- > module Main where
37 -- > import Network.HTTP.Lucu
40 -- > main = let config = defaultConfig
41 -- > resources = mkResTree [ ([], helloWorld) ]
43 -- > runHttpd config resourcees []
45 -- > helloWorld :: ResourceDef
46 -- > helloWorld = emptyResource {
48 -- > = Just $ do setContentType $ parseMIMEType "text/plain"
49 -- > putChunk "Hello, world!"
51 runHttpd ∷ Config → ResTree → [FallbackHandler] → IO ()
54 do void $ installHandler sigPIPE Ignore Nothing
57 [ do scnf ← cnfSSLConfig cnf
58 addr ← cnfServerV4Addr cnf
59 return ( do so ← listenOn AF_INET addr (sslServerPort scnf)
60 launchListener (sslContext scnf, so)
62 , do scnf ← cnfSSLConfig cnf
63 addr ← cnfServerV6Addr cnf
64 return ( do so ← listenOn AF_INET6 addr (sslServerPort scnf)
65 launchListener (sslContext scnf, so)
67 , do addr ← cnfServerV4Addr cnf
68 return ( launchListener =≪ listenOn AF_INET addr (cnfServerPort cnf)
70 , do addr ← cnfServerV6Addr cnf
71 return ( launchListener =≪ listenOn AF_INET6 addr (cnfServerPort cnf)
77 launchListener ∷ SocketLike s ⇒ s → IO ()
79 = do p ← SL.socketPort so
80 -- FIXME: Don't throw away the thread ID as we can't
81 -- kill it later then. [1]
82 void $ forkIO $ httpLoop p so
84 listenOn ∷ Family → HostName → ServiceName → IO Socket
86 = do proto ← getProtocolNumber "tcp"
87 let hints = defaultHints {
88 addrFlags = [AI_PASSIVE]
90 , addrSocketType = Stream
91 , addrProtocol = proto
93 addrs ← getAddrInfo (Just hints) (Just host) (Just srv)
96 (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr))
99 do setSocketOption sock ReuseAddr 1
100 bindSocket sock (addrAddress addr)
101 listen sock maxListenQueue
105 httpLoop ∷ SocketLike s ⇒ PortNumber → s → IO ()
107 = do (h, addr) ← SL.accept so
108 tQueue ← mkInteractionQueue
109 readerTID ← forkIO $ requestReader cnf tree fbs h port addr tQueue
110 _writerTID ← forkIO $ responseWriter cnf h tQueue readerTID
114 waitForever = forever (threadDelay 1000000)