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           Control.Exception
  10 import           Control.Monad
  11 import           Data.Maybe
  12 import           Network.BSD
  13 import           Network.Socket
  14 import           Network.HTTP.Lucu.Config
  15 import           Network.HTTP.Lucu.Interaction
  16 import           Network.HTTP.Lucu.RequestReader
  17 import           Network.HTTP.Lucu.Resource.Tree
  18 import           Network.HTTP.Lucu.ResponseWriter
  19 import           Network.HTTP.Lucu.SocketLike as SL
  20 import           System.Posix.Signals
  21
  22 -- |This is the entry point of Lucu httpd. It listens to a socket and
  23 -- waits for clients. Computation of 'runHttpd' never stops by itself
  24 -- so the only way to stop it is to raise an exception in the thread
  25 -- computing it.
  26 --
  27 -- Note that 'runHttpd' automatically makes SIGPIPE be ignored by
  28 -- computing @'System.Posix.Signals.installHandler'
  29 -- 'System.Posix.Signals.sigPIPE' 'System.Posix.Signals.Ignore'
  30 -- 'Prelude.Nothing'@. This can hardly cause a problem but it may do.
  31 --
  32 -- Example:
  33 --
  34 -- > module Main where
  35 -- > import Network.HTTP.Lucu
  36 -- >
  37 -- > main :: IO ()
  38 -- > main = let config    = defaultConfig
  39 -- >            resources = mkResTree [ ([], helloWorld) ]
  40 -- >        in
  41 -- >          runHttpd config resourcees []
  42 -- >
  43 -- > helloWorld :: ResourceDef
  44 -- > helloWorld = ResourceDef {
  45 -- >                resUsesNativeThread = False
  46 -- >              , resIsGreedy         = False
  47 -- >              , resGet
  48 -- >                  = Just $ do setContentType $ read "text/plain"
  49 -- >                              output "Hello, world!"
  50 -- >              , resHead   = Nothing
  51 -- >              , resPost   = Nothing
  52 -- >              , resPut    = Nothing
  53 -- >              , resDelete = Nothing
  54 -- >              }
  55 runHttpd :: Config -> ResTree -> [FallbackHandler] -> IO ()
  56 runHttpd cnf tree fbs
  57     = withSocketsDo $
  58       do _ <- installHandler sigPIPE Ignore Nothing
  59
  60          let launchers
  61                  = catMaybes
  62                    [ do scnf <- cnfSSLConfig    cnf
  63                         addr <- cnfServerV4Addr cnf
  64                         return ( do so <- listenOn AF_INET addr (sslServerPort scnf)
  65                                     launchListener (sslContext scnf, so)
  66                                )
  67                    , do scnf <- cnfSSLConfig    cnf
  68                         addr <- cnfServerV6Addr cnf
  69                         return ( do so <- listenOn AF_INET6 addr (sslServerPort scnf)
  70                                     launchListener (sslContext scnf, so)
  71                                )
  72                    , do addr <- cnfServerV4Addr cnf
  73                         return ( launchListener =<< listenOn AF_INET addr (cnfServerPort cnf)
  74                                )
  75                    , do addr <- cnfServerV6Addr cnf
  76                         return ( launchListener =<< listenOn AF_INET6 addr (cnfServerPort cnf)
  77                                )
  78                    ]
  79
  80          sequence_ launchers
  81          waitForever
  82     where
  83       launchListener :: SocketLike s => s -> IO ()
  84       launchListener so
  85           = do p <- SL.socketPort so
  86                -- FIXME: Don't throw away the thread ID as we can't
  87                -- kill it later then. [1]
  88                _ <- forkIO $ httpLoop p so
  89                return ()
  90
  91       listenOn :: Family -> HostName -> ServiceName -> IO Socket
  92       listenOn fam host srv
  93           = do proto <- getProtocolNumber "tcp"
  94                let hints = defaultHints {
  95                              addrFlags      = [AI_PASSIVE]
  96                            , addrFamily     = fam
  97                            , addrSocketType = Stream
  98                            , addrProtocol   = proto
  99                            }
 100                addrs <- getAddrInfo (Just hints) (Just host) (Just srv)
 101                let addr = head addrs
 102                bracketOnError
 103                    (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr))
 104                    (sClose)
 105                    (\ sock ->
 106                         do setSocketOption sock ReuseAddr 1
 107                            bindSocket sock (addrAddress addr)
 108                            listen sock maxListenQueue
 109                            return sock
 110                    )
 111
 112       httpLoop :: SocketLike s => PortNumber -> s -> IO ()
 113       httpLoop port so
 114           = do (h, addr)  <- SL.accept so
 115                tQueue     <- newInteractionQueue
 116                readerTID  <- forkIO $ requestReader cnf tree fbs h port addr tQueue
 117                _writerTID <- forkIO $ responseWriter cnf h tQueue readerTID
 118                httpLoop port so
 119
 120       waitForever :: IO ()
 121       waitForever = forever (threadDelay 1000000)