Network/HTTP/Lucu/Httpd.hs

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