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