Network/HTTP/Lucu/Httpd.hs

   1 {-# LANGUAGE
   2     UnicodeSyntax
   3   #-}
   4 -- |The entry point of Lucu httpd.
   5 module Network.HTTP.Lucu.Httpd
   6     ( FallbackHandler
   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.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
  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 -- Note that 'runHttpd' automatically makes SIGPIPE be ignored by
  30 -- calling @'installHandler' 'sigPIPE' 'Ignore' 'Nothing'@. This can
  31 -- hardly cause a problem though.
  32 --
  33 -- Example:
  34 --
  35 -- > {-# LANGUAGE OverloadedStrings #-}
  36 -- > module Main where
  37 -- > import Network.HTTP.Lucu
  38 -- >
  39 -- > main :: IO ()
  40 -- > main = let config    = defaultConfig
  41 -- >            resources = mkResTree [ ([], helloWorld) ]
  42 -- >        in
  43 -- >          runHttpd config resourcees []
  44 -- >
  45 -- > helloWorld :: ResourceDef
  46 -- > helloWorld = emptyResource {
  47 -- >                resGet
  48 -- >                  = Just $ do setContentType $ mkMIMEType "text" "plain"
  49 -- >                              putChunk "Hello, world!"
  50 -- >              }
  51 runHttpd ∷ Config → ResTree → [FallbackHandler] → IO ()
  52 runHttpd cnf tree fbs
  53     = withSocketsDo $
  54       do void $ installHandler sigPIPE Ignore Nothing
  55          let launchers
  56                  = catMaybes
  57                    [ do scnf ← cnfSSLConfig    cnf
  58                         addr ← cnfServerV4Addr cnf
  59                         return ( do so ← listenOn AF_INET addr (sslServerPort scnf)
  60                                     launchListener (sslContext scnf, so)
  61                                )
  62                    , do scnf ← cnfSSLConfig    cnf
  63                         addr ← cnfServerV6Addr cnf
  64                         return ( do so ← listenOn AF_INET6 addr (sslServerPort scnf)
  65                                     launchListener (sslContext scnf, so)
  66                                )
  67                    , do addr ← cnfServerV4Addr cnf
  68                         return ( launchListener =≪ listenOn AF_INET addr (cnfServerPort cnf)
  69                                )
  70                    , do addr ← cnfServerV6Addr cnf
  71                         return ( launchListener =≪ listenOn AF_INET6 addr (cnfServerPort cnf)
  72                                )
  73                    ]
  74          sequence_ launchers
  75          waitForever
  76     where
  77       launchListener ∷ SocketLike s ⇒ s → IO ()
  78       launchListener so
  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
  83
  84       listenOn ∷ Family → HostName → ServiceName → IO Socket
  85       listenOn fam host srv
  86           = do proto ← getProtocolNumber "tcp"
  87                let hints = defaultHints {
  88                              addrFlags      = [AI_PASSIVE]
  89                            , addrFamily     = fam
  90                            , addrSocketType = Stream
  91                            , addrProtocol   = proto
  92                            }
  93                addrs ← getAddrInfo (Just hints) (Just host) (Just srv)
  94                let addr = head addrs
  95                bracketOnError
  96                    (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr))
  97                    sClose
  98                    (\ sock →
  99                         do setSocketOption sock ReuseAddr 1
 100                            bindSocket sock (addrAddress addr)
 101                            listen sock maxListenQueue
 102                            return sock
 103                    )
 104
 105       httpLoop ∷ SocketLike s ⇒ PortNumber → s → IO ()
 106       httpLoop port so
 107           = do (h, addr)  ← SL.accept so
 108                tQueue     ← newInteractionQueue
 109                readerTID  ← forkIO $ requestReader cnf tree fbs h port addr tQueue
 110                _writerTID ← forkIO $ responseWriter cnf h tQueue readerTID
 111                httpLoop port so
 112
 113       waitForever ∷ IO ()
 114       waitForever = forever (threadDelay 1000000)