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 -- > module Main where
  33 -- > import Network.HTTP.Lucu
  34 -- >
  35 -- > main :: IO ()
  36 -- > main = let config    = defaultConfig
  37 -- >            resources = mkResTree [ ([], helloWorld) ]
  38 -- >        in
  39 -- >          runHttpd config resourcees []
  40 -- >
  41 -- > helloWorld :: ResourceDef
  42 -- > helloWorld = emptyResource {
  43 -- >                resGet
  44 -- >                  = Just $ do setContentType $ parseMIMEType "text/plain"
  45 -- >                              putChunk "Hello, world!"
  46 -- >              }
  47 runHttpd ∷ Config → ResTree → [FallbackHandler] → IO ()
  48 runHttpd cnf tree fbs
  49     = withSocketsDo $
  50       do let launchers
  51                  = catMaybes
  52                    [ do addr ← cnfServerV4Addr cnf
  53                         return ( launchListener =≪ listenOn AF_INET addr (cnfServerPort cnf)
  54                                )
  55                    , do addr ← cnfServerV6Addr cnf
  56                         return ( launchListener =≪ listenOn AF_INET6 addr (cnfServerPort cnf)
  57                                )
  58 #if defined(HAVE_SSL)
  59                    , do scnf ← cnfSSLConfig    cnf
  60                         addr ← cnfServerV4Addr cnf
  61                         return ( do so ← listenOn AF_INET addr (sslServerPort scnf)
  62                                     launchListener (sslContext scnf, so)
  63                                )
  64                    , do scnf ← cnfSSLConfig    cnf
  65                         addr ← cnfServerV6Addr cnf
  66                         return ( do so ← listenOn AF_INET6 addr (sslServerPort scnf)
  67                                     launchListener (sslContext scnf, so)
  68                                )
  69 #endif
  70                    ]
  71          sequence_ launchers
  72          waitForever
  73     where
  74       launchListener ∷ SocketLike s ⇒ s → IO ()
  75       launchListener so
  76           = do p ← SL.socketPort so
  77                -- FIXME: Don't throw away the thread ID as we can't
  78                -- kill it later then. [1]
  79                void $ forkIO $ httpLoop p so
  80
  81       listenOn ∷ Family → HostName → ServiceName → IO Socket
  82       listenOn fam host srv
  83           = do proto ← getProtocolNumber "tcp"
  84                let hints = defaultHints {
  85                              addrFlags      = [AI_PASSIVE]
  86                            , addrFamily     = fam
  87                            , addrSocketType = Stream
  88                            , addrProtocol   = proto
  89                            }
  90                addrs ← getAddrInfo (Just hints) (Just host) (Just srv)
  91                let addr = head addrs
  92                bracketOnError
  93                    (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr))
  94                    sClose
  95                    (\ sock →
  96                         do setSocketOption sock ReuseAddr 1
  97                            bindSocket sock (addrAddress addr)
  98                            listen sock maxListenQueue
  99                            return sock
 100                    )
 101
 102       httpLoop ∷ SocketLike s ⇒ PortNumber → s → IO ()
 103       httpLoop port so
 104           = do (h, addr)  ← SL.accept so
 105                tQueue     ← mkInteractionQueue
 106                readerTID  ← forkIO $ requestReader cnf tree fbs h port addr tQueue
 107                _writerTID ← forkIO $ responseWriter cnf h tQueue readerTID
 108                httpLoop port so
 109
 110       waitForever ∷ IO ()
 111       waitForever = forever (threadDelay 1000000)