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