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 runHttpd ∷ HostMapper α ⇒ Config → α → IO ()
  54 runHttpd cnf hm
  55     = do let launchers
  56                  = catMaybes
  57                    [ do addr ← cnfServerV4Addr cnf
  58                         return ( launchListener =≪ listenOn AF_INET addr (cnfServerPort cnf)
  59                                )
  60                    , do addr ← cnfServerV6Addr cnf
  61                         return ( launchListener =≪ listenOn AF_INET6 addr (cnfServerPort cnf)
  62                                )
  63 #if defined(HAVE_SSL)
  64                    , do scnf ← cnfSSLConfig    cnf
  65                         addr ← cnfServerV4Addr cnf
  66                         return ( do so ← listenOn AF_INET addr (sslServerPort scnf)
  67                                     launchListener (sslContext scnf, so)
  68                                )
  69                    , do scnf ← cnfSSLConfig    cnf
  70                         addr ← cnfServerV6Addr cnf
  71                         return ( do so ← listenOn AF_INET6 addr (sslServerPort scnf)
  72                                     launchListener (sslContext scnf, so)
  73                                )
  74 #endif
  75                    ]
  76          sequence_ launchers
  77          waitForever
  78     where
  79       launchListener ∷ SocketLike s ⇒ s → IO ()
  80       launchListener so
  81           = do p ← SL.socketPort so
  82                -- FIXME: Don't throw away the thread ID as we can't
  83                -- kill it later then.
  84                void ∘ forkIO $ httpLoop p so
  85
  86       listenOn ∷ Family → HostName → ServiceName → IO Socket
  87       listenOn fam host srv
  88           = do proto ← getProtocolNumber "tcp"
  89                let hints = defaultHints {
  90                              addrFlags      = [AI_PASSIVE]
  91                            , addrFamily     = fam
  92                            , addrSocketType = Stream
  93                            , addrProtocol   = proto
  94                            }
  95                addrs ← getAddrInfo (Just hints) (Just host) (Just srv)
  96                let addr = head addrs
  97                bracketOnError
  98                    (socket (addrFamily     addr)
  99                            (addrSocketType addr)
 100                            (addrProtocol   addr))
 101                    sClose
 102                    (\ sock →
 103                         do setSocketOption sock ReuseAddr 1
 104                            bindSocket sock (addrAddress addr)
 105                            listen sock maxListenQueue
 106                            return sock
 107                    )
 108
 109       httpLoop ∷ SocketLike s ⇒ PortNumber → s → IO ()
 110       httpLoop port so
 111           = do (h, addr)  ← SL.accept so
 112                tQueue     ← mkInteractionQueue
 113                readerTID  ← forkIO $ requestReader cnf hm h port addr tQueue
 114                _writerTID ← forkIO $ responseWriter cnf h tQueue readerTID
 115                httpLoop port so
 116
 117       waitForever ∷ IO ()
 118       waitForever = forever $ threadDelay 1000000