]> gitweb @ CieloNegro.org - Lucu.git/blob - Network/HTTP/Lucu/Httpd.hs
Use Data.Map.foldlWithKey' when possible
[Lucu.git] / Network / HTTP / Lucu / Httpd.hs
1 {-# LANGUAGE
2     CPP
3   , UnicodeSyntax
4   #-}
5 -- |The entry point of Lucu httpd.
6 module Network.HTTP.Lucu.Httpd
7     ( FallbackHandler
8     , runHttpd
9     )
10     where
11 import Control.Concurrent
12 import Control.Exception
13 import Control.Monad
14 import Control.Monad.Unicode
15 import Data.Maybe
16 import Network.BSD
17 import Network.Socket
18 import Network.HTTP.Lucu.Config
19 import Network.HTTP.Lucu.Interaction
20 import Network.HTTP.Lucu.RequestReader
21 import Network.HTTP.Lucu.Resource.Tree
22 import Network.HTTP.Lucu.ResponseWriter
23 import Network.HTTP.Lucu.SocketLike as SL
24
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.
28 --
29 -- Example:
30 --
31 -- > {-# LANGUAGE OverloadedStrings #-}
32 -- > {-# LANGUAGE QuasiQuotes #-}
33 -- > module Main where
34 -- > import Network.HTTP.Lucu
35 -- > 
36 -- > main :: IO ()
37 -- > main = let config    = defaultConfig
38 -- >            resources = mkResTree [ ([], helloWorld) ]
39 -- >        in
40 -- >          runHttpd config resourcees []
41 -- >
42 -- > helloWorld :: ResourceDef
43 -- > helloWorld = emptyResource {
44 -- >                resGet
45 -- >                  = Just $ do setContentType [mimeType| text/plain |]
46 -- >                              putChunk "Hello, world!"
47 -- >              }
48 runHttpd ∷ Config → ResTree → [FallbackHandler] → IO ()
49 runHttpd cnf tree fbs
50     = withSocketsDo $
51       do let launchers
52                  = catMaybes
53                    [ do addr ← cnfServerV4Addr cnf
54                         return ( launchListener =≪ listenOn AF_INET addr (cnfServerPort cnf)
55                                )
56                    , do addr ← cnfServerV6Addr cnf
57                         return ( launchListener =≪ listenOn AF_INET6 addr (cnfServerPort cnf)
58                                )
59 #if defined(HAVE_SSL)
60                    , do scnf ← cnfSSLConfig    cnf
61                         addr ← cnfServerV4Addr cnf
62                         return ( do so ← listenOn AF_INET addr (sslServerPort scnf)
63                                     launchListener (sslContext scnf, so)
64                                )
65                    , do scnf ← cnfSSLConfig    cnf
66                         addr ← cnfServerV6Addr cnf
67                         return ( do so ← listenOn AF_INET6 addr (sslServerPort scnf)
68                                     launchListener (sslContext scnf, so)
69                                )
70 #endif
71                    ]
72          sequence_ launchers
73          waitForever
74     where
75       launchListener ∷ SocketLike s ⇒ s → IO ()
76       launchListener so
77           = do p ← SL.socketPort so
78                -- FIXME: Don't throw away the thread ID as we can't
79                -- kill it later then. [1]
80                void $ forkIO $ httpLoop p so
81
82       listenOn ∷ Family → HostName → ServiceName → IO Socket
83       listenOn fam host srv
84           = do proto ← getProtocolNumber "tcp"
85                let hints = defaultHints {
86                              addrFlags      = [AI_PASSIVE]
87                            , addrFamily     = fam
88                            , addrSocketType = Stream
89                            , addrProtocol   = proto
90                            }
91                addrs ← getAddrInfo (Just hints) (Just host) (Just srv)
92                let addr = head addrs
93                bracketOnError
94                    (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr))
95                    sClose
96                    (\ sock →
97                         do setSocketOption sock ReuseAddr 1
98                            bindSocket sock (addrAddress addr)
99                            listen sock maxListenQueue
100                            return sock
101                    )
102
103       httpLoop ∷ SocketLike s ⇒ PortNumber → s → IO ()
104       httpLoop port so
105           = do (h, addr)  ← SL.accept so
106                tQueue     ← mkInteractionQueue
107                readerTID  ← forkIO $ requestReader cnf tree fbs h port addr tQueue
108                _writerTID ← forkIO $ responseWriter cnf h tQueue readerTID
109                httpLoop port so
110
111       waitForever ∷ IO ()
112       waitForever = forever (threadDelay 1000000)