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     ( 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.Dispatcher
  19 import Network.HTTP.Lucu.Interaction
  20 import Network.HTTP.Lucu.RequestReader
  21 import Network.HTTP.Lucu.ResponseWriter
  22 import Network.HTTP.Lucu.SocketLike as SL
  23 import Prelude.Unicode
  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
  35 -- > import Network.HTTP.Lucu
  36 -- >
  37 -- > main :: IO ()
  38 -- > main = let config    = defaultConfig
  39 -- >            resources = mkResTree [ ([], helloWorld) ]
  40 -- >        in
  41 -- >          withSocketsDo $ 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 --
  50 -- FIXME: update the above example
  51 runHttpd ∷ Config → SchemeMap → IO ()
  52 runHttpd cnf sm
  53     = do let launchers
  54                  = catMaybes
  55                    [ do addr ← cnfServerV4Addr cnf
  56                         return ( launchListener =≪ listenOn AF_INET addr (cnfServerPort cnf)
  57                                )
  58                    , do addr ← cnfServerV6Addr cnf
  59                         return ( launchListener =≪ listenOn AF_INET6 addr (cnfServerPort cnf)
  60                                )
  61 #if defined(HAVE_SSL)
  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 #endif
  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.
  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)
  97                            (addrSocketType addr)
  98                            (addrProtocol   addr))
  99                    sClose
 100                    (\ sock →
 101                         do setSocketOption sock ReuseAddr 1
 102                            bindSocket sock (addrAddress addr)
 103                            listen sock maxListenQueue
 104                            return sock
 105                    )
 106
 107       httpLoop ∷ SocketLike s ⇒ PortNumber → s → IO ()
 108       httpLoop port so
 109           = do (h, addr)  ← SL.accept so
 110                tQueue     ← mkInteractionQueue
 111                readerTID  ← forkIO $ requestReader cnf sm h port addr tQueue
 112                _writerTID ← forkIO $ responseWriter cnf h tQueue readerTID
 113                httpLoop port so
 114
 115       waitForever ∷ IO ()
 116       waitForever = forever $ threadDelay 1000000