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 -- FIXME: update the above example
  50 runHttpd ∷ Config → SchemeMap → IO ()
  51 runHttpd cnf sm
  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)
  96                            (addrSocketType addr)
  97                            (addrProtocol   addr))
  98                    sClose
  99                    (\ sock →
 100                         do setSocketOption sock ReuseAddr 1
 101                            bindSocket sock (addrAddress addr)
 102                            listen sock maxListenQueue
 103                            return sock
 104                    )
 105
 106       httpLoop ∷ SocketLike s ⇒ PortNumber → s → IO ()
 107       httpLoop port so
 108           = do (h, addr)  ← SL.accept so
 109                tQueue     ← mkInteractionQueue
 110                readerTID  ← forkIO $ requestReader cnf sm h port addr tQueue
 111                _writerTID ← forkIO $ responseWriter cnf h tQueue readerTID
 112                httpLoop port so
 113
 114       waitForever ∷ IO ()
 115       waitForever = forever $ threadDelay 1000000