]> gitweb @ CieloNegro.org - Lucu.git/blob - Network/HTTP/Lucu/Httpd.hs
Small fixes
[Lucu.git] / Network / HTTP / Lucu / Httpd.hs
1 -- |The entry point of Lucu httpd.
2 module Network.HTTP.Lucu.Httpd
3     ( FallbackHandler
4     , runHttpd
5     )
6     where
7
8 import           Control.Concurrent
9 import           Network
10 import qualified Network.Socket as So
11 import           Network.HTTP.Lucu.Config
12 import           Network.HTTP.Lucu.Interaction
13 import           Network.HTTP.Lucu.RequestReader
14 import           Network.HTTP.Lucu.Resource.Tree
15 import           Network.HTTP.Lucu.ResponseWriter
16 import           System.IO
17 import           System.Posix.Signals
18
19 -- |This is the entry point of Lucu httpd. It listens to a socket and
20 -- waits for clients. Computation of 'runHttpd' never stops by itself
21 -- so the only way to stop it is to raise an exception in the thread
22 -- computing it.
23 --
24 -- Note that 'runHttpd' automatically makes SIGPIPE be ignored by
25 -- computing @'System.Posix.Signals.installHandler'
26 -- 'System.Posix.Signals.sigPIPE' 'System.Posix.Signals.Ignore'
27 -- 'Prelude.Nothing'@. This can hardly cause a problem but it may do.
28 --
29 -- Example:
30 --
31 -- > module Main where
32 -- > import Network.HTTP.Lucu
33 -- > 
34 -- > main :: IO ()
35 -- > main = let config    = defaultConfig
36 -- >            resources = mkResTree [ ([], helloWorld) ]
37 -- >        in
38 -- >          runHttpd config resourcees []
39 -- >
40 -- > helloWorld :: ResourceDef
41 -- > helloWorld = ResourceDef {
42 -- >                resUsesNativeThread = False
43 -- >              , resIsGreedy         = False
44 -- >              , resGet
45 -- >                  = Just $ do setContentType $ read "text/plain"
46 -- >                              output "Hello, world!"
47 -- >              , resHead   = Nothing
48 -- >              , resPost   = Nothing
49 -- >              , resPut    = Nothing
50 -- >              , resDelete = Nothing
51 -- >              }
52 runHttpd :: Config -> ResTree -> [FallbackHandler] -> IO ()
53 runHttpd cnf tree fbs
54     = withSocketsDo $
55       do installHandler sigPIPE Ignore Nothing
56          so <- listenOn (cnfServerPort cnf)
57          loop so
58     where
59       loop :: Socket -> IO ()
60       loop so
61           -- 本當は Network.accept を使ひたいが、このアクションは勝手に
62           -- リモートのIPを逆引きするので、使へない。
63           = do (h, addr)  <- accept' so
64                tQueue     <- newInteractionQueue
65                readerTID  <- forkIO $ requestReader cnf tree fbs h addr tQueue
66                _writerTID <- forkIO $ responseWriter cnf h tQueue readerTID
67                loop so
68
69       accept' :: Socket -> IO (Handle, So.SockAddr)
70       accept' soSelf
71           = do (soPeer, addr) <- So.accept soSelf
72                hPeer          <- So.socketToHandle soPeer ReadWriteMode
73                return (hPeer, addr)