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 import Prelude.Unicode
  25
  26 -- |This is the entry point of Lucu httpd. It listens to a socket and
  27 -- waits for clients. 'runHttpd' never stops by itself so the only way
  28 -- to stop it is to raise an exception in the thread running it.
  29 --
  30 -- Example:
  31 --
  32 -- > {-# LANGUAGE OverloadedStrings #-}
  33 -- > {-# LANGUAGE QuasiQuotes #-}
  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 :: Resource
  44 -- > helloWorld = emptyResource {
  45 -- >                resGet
  46 -- >                  = Just $ do setContentType [mimeType| text/plain |]
  47 -- >                              putChunk "Hello, world!"
  48 -- >              }
  49 runHttpd ∷ Config → ResTree → [FallbackHandler] → IO ()
  50 runHttpd cnf tree fbs
  51     = withSocketsDo $
  52       do let launchers
  53                  = catMaybes
  54                    [ do addr ← cnfServerV4Addr cnf
  55                         return ( launchListener =≪ listenOn AF_INET addr (cnfServerPort cnf)
  56                                )
  57                    , do addr ← cnfServerV6Addr cnf
  58                         return ( launchListener =≪ listenOn AF_INET6 addr (cnfServerPort cnf)
  59                                )
  60 #if defined(HAVE_SSL)
  61                    , do scnf ← cnfSSLConfig    cnf
  62                         addr ← cnfServerV4Addr cnf
  63                         return ( do so ← listenOn AF_INET addr (sslServerPort scnf)
  64                                     launchListener (sslContext scnf, so)
  65                                )
  66                    , do scnf ← cnfSSLConfig    cnf
  67                         addr ← cnfServerV6Addr cnf
  68                         return ( do so ← listenOn AF_INET6 addr (sslServerPort scnf)
  69                                     launchListener (sslContext scnf, so)
  70                                )
  71 #endif
  72                    ]
  73          sequence_ launchers
  74          waitForever
  75     where
  76       launchListener ∷ SocketLike s ⇒ s → IO ()
  77       launchListener so
  78           = do p ← SL.socketPort so
  79                -- FIXME: Don't throw away the thread ID as we can't
  80                -- kill it later then.
  81                void ∘ forkIO $ httpLoop p so
  82
  83       listenOn ∷ Family → HostName → ServiceName → IO Socket
  84       listenOn fam host srv
  85           = do proto ← getProtocolNumber "tcp"
  86                let hints = defaultHints {
  87                              addrFlags      = [AI_PASSIVE]
  88                            , addrFamily     = fam
  89                            , addrSocketType = Stream
  90                            , addrProtocol   = proto
  91                            }
  92                addrs ← getAddrInfo (Just hints) (Just host) (Just srv)
  93                let addr = head addrs
  94                bracketOnError
  95                    (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr))
  96                    sClose
  97                    (\ sock →
  98                         do setSocketOption sock ReuseAddr 1
  99                            bindSocket sock (addrAddress addr)
 100                            listen sock maxListenQueue
 101                            return sock
 102                    )
 103
 104       httpLoop ∷ SocketLike s ⇒ PortNumber → s → IO ()
 105       httpLoop port so
 106           = do (h, addr)  ← SL.accept so
 107                tQueue     ← mkInteractionQueue
 108                readerTID  ← forkIO $ requestReader cnf tree fbs h port addr tQueue
 109                _writerTID ← forkIO $ responseWriter cnf h tQueue readerTID
 110                httpLoop port so
 111
 112       waitForever ∷ IO ()
 113       waitForever = forever (threadDelay 1000000)