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