Network/HTTP/Lucu/Httpd.hs

   1 -- |The entry point of Lucu httpd.
   2 module Network.HTTP.Lucu.Httpd
   3     ( FallbackHandler
   4     , runHttpd
   5     )
   6     where
   7
   8 import           Control.Concurrent
   9 import           Control.Exception
  10 import           Control.Monad
  11 import           Network.BSD
  12 import           Network.Socket
  13 import           Network.HTTP.Lucu.Config
  14 import           Network.HTTP.Lucu.Interaction
  15 import           Network.HTTP.Lucu.RequestReader
  16 import           Network.HTTP.Lucu.Resource.Tree
  17 import           Network.HTTP.Lucu.ResponseWriter
  18 import           Network.HTTP.Lucu.SocketLike as SL
  19 import           System.Posix.Signals
  20
  21 -- |This is the entry point of Lucu httpd. It listens to a socket and
  22 -- waits for clients. Computation of 'runHttpd' never stops by itself
  23 -- so the only way to stop it is to raise an exception in the thread
  24 -- computing it.
  25 --
  26 -- Note that 'runHttpd' automatically makes SIGPIPE be ignored by
  27 -- computing @'System.Posix.Signals.installHandler'
  28 -- 'System.Posix.Signals.sigPIPE' 'System.Posix.Signals.Ignore'
  29 -- 'Prelude.Nothing'@. This can hardly cause a problem but it may do.
  30 --
  31 -- Example:
  32 --
  33 -- > module Main where
  34 -- > import Network.HTTP.Lucu
  35 -- >
  36 -- > main :: IO ()
  37 -- > main = let config    = defaultConfig
  38 -- >            resources = mkResTree [ ([], helloWorld) ]
  39 -- >        in
  40 -- >          runHttpd config resourcees []
  41 -- >
  42 -- > helloWorld :: ResourceDef
  43 -- > helloWorld = ResourceDef {
  44 -- >                resUsesNativeThread = False
  45 -- >              , resIsGreedy         = False
  46 -- >              , resGet
  47 -- >                  = Just $ do setContentType $ read "text/plain"
  48 -- >                              output "Hello, world!"
  49 -- >              , resHead   = Nothing
  50 -- >              , resPost   = Nothing
  51 -- >              , resPut    = Nothing
  52 -- >              , resDelete = Nothing
  53 -- >              }
  54 runHttpd :: Config -> ResTree -> [FallbackHandler] -> IO ()
  55 runHttpd cnf tree fbs
  56     = withSocketsDo $
  57       do _ <- installHandler sigPIPE Ignore Nothing
  58
  59          -- FIXME: TERRIBLE CODE. NEED MAJOR REWRITE.
  60          case cnfSSLConfig cnf of
  61            Nothing
  62                -> return ()
  63            Just scnf
  64                -> do case cnfServerV4Addr cnf of
  65                        Nothing
  66                            -> return ()
  67                        Just v4addr
  68                            -> do so <- listenOn AF_INET v4addr (sslServerPort scnf)
  69                                  p  <- socketPort so
  70                                  -- FIXME: Don't throw away the thread
  71                                  -- ID as we can't kill it later
  72                                  -- then. [1]
  73                                  _  <- forkIO $ httpLoop p (sslContext scnf, so)
  74                                  return ()
  75
  76                      case cnfServerV6Addr cnf of
  77                        Nothing
  78                            -> return ()
  79                        Just v6addr
  80                            -> do so <- listenOn AF_INET6 v6addr (sslServerPort scnf)
  81                                  p  <- socketPort so
  82                                  -- FIXME: [1]
  83                                  _  <- forkIO $ httpLoop p (sslContext scnf, so)
  84                                  return ()
  85
  86          case cnfServerV4Addr cnf of
  87            Nothing
  88                -> return ()
  89            Just v4addr
  90                -> do so <- listenOn AF_INET v4addr (cnfServerPort cnf)
  91                      p  <- socketPort so
  92                      -- FIXME: [1]
  93                      _  <- forkIO $ httpLoop p so
  94                      return ()
  95
  96          case cnfServerV6Addr cnf of
  97            Nothing
  98                -> return ()
  99            Just v6addr
 100                -> do so <- listenOn AF_INET6 v6addr (cnfServerPort cnf)
 101                      p  <- socketPort so
 102                      -- FIXME: [1]
 103                      _  <- forkIO $ httpLoop p so
 104                      return ()
 105
 106          waitForever
 107     where
 108       listenOn :: Family -> HostName -> ServiceName -> IO Socket
 109       listenOn fam host srv
 110           = do proto <- getProtocolNumber "tcp"
 111                let hints = defaultHints {
 112                              addrFlags      = [AI_PASSIVE]
 113                            , addrFamily     = fam
 114                            , addrSocketType = Stream
 115                            , addrProtocol   = proto
 116                            }
 117                addrs <- getAddrInfo (Just hints) (Just host) (Just srv)
 118                let addr = head addrs
 119                bracketOnError
 120                    (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr))
 121                    (sClose)
 122                    (\ sock ->
 123                         do setSocketOption sock ReuseAddr 1
 124                            bindSocket sock (addrAddress addr)
 125                            listen sock maxListenQueue
 126                            return sock
 127                    )
 128
 129       httpLoop :: SocketLike s => PortNumber -> s -> IO ()
 130       httpLoop port so
 131           = do (h, addr)  <- SL.accept so
 132                tQueue     <- newInteractionQueue
 133                readerTID  <- forkIO $ requestReader cnf tree fbs h port addr tQueue
 134                _writerTID <- forkIO $ responseWriter cnf h tQueue readerTID
 135                httpLoop port so
 136
 137       waitForever :: IO ()
 138       waitForever = forever (threadDelay 1000000)