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           Network
  10 import qualified Network.Socket as So
  11 import           Network.HTTP.Lucu.Config
  12 import           Network.HTTP.Lucu.Interaction
  13 import           Network.HTTP.Lucu.RequestReader
  14 import           Network.HTTP.Lucu.Resource.Tree
  15 import           Network.HTTP.Lucu.ResponseWriter
  16 import qualified OpenSSL.Session as SSL
  17 import           System.IO
  18 import           System.Posix.Signals
  19
  20 -- |This is the entry point of Lucu httpd. It listens to a socket and
  21 -- waits for clients. Computation of 'runHttpd' never stops by itself
  22 -- so the only way to stop it is to raise an exception in the thread
  23 -- computing it.
  24 --
  25 -- Note that 'runHttpd' automatically makes SIGPIPE be ignored by
  26 -- computing @'System.Posix.Signals.installHandler'
  27 -- 'System.Posix.Signals.sigPIPE' 'System.Posix.Signals.Ignore'
  28 -- 'Prelude.Nothing'@. This can hardly cause a problem but it may do.
  29 --
  30 -- Example:
  31 --
  32 -- > module Main where
  33 -- > import Network.HTTP.Lucu
  34 -- >
  35 -- > main :: IO ()
  36 -- > main = let config    = defaultConfig
  37 -- >            resources = mkResTree [ ([], helloWorld) ]
  38 -- >        in
  39 -- >          runHttpd config resourcees []
  40 -- >
  41 -- > helloWorld :: ResourceDef
  42 -- > helloWorld = ResourceDef {
  43 -- >                resUsesNativeThread = False
  44 -- >              , resIsGreedy         = False
  45 -- >              , resGet
  46 -- >                  = Just $ do setContentType $ read "text/plain"
  47 -- >                              output "Hello, world!"
  48 -- >              , resHead   = Nothing
  49 -- >              , resPost   = Nothing
  50 -- >              , resPut    = Nothing
  51 -- >              , resDelete = Nothing
  52 -- >              }
  53 runHttpd :: Config -> ResTree -> [FallbackHandler] -> IO ()
  54 runHttpd cnf tree fbs
  55     = withSocketsDo $
  56       do _ <- installHandler sigPIPE Ignore Nothing
  57
  58          case cnfSSLConfig cnf of
  59            Nothing
  60                -> return ()
  61            Just scnf
  62                -> do so       <- listenOn (sslServerPort scnf)
  63                      _loopTID <- forkIO $ httpsLoop (sslContext scnf) so
  64                      return ()
  65
  66          httpLoop =<< listenOn (cnfServerPort cnf)
  67     where
  68       httpLoop :: Socket -> IO ()
  69       httpLoop so
  70           = do (h, addr)  <- acceptHTTP so
  71                tQueue     <- newInteractionQueue
  72                readerTID  <- forkIO $ requestReader cnf tree fbs h addr tQueue
  73                _writerTID <- forkIO $ responseWriter cnf h tQueue readerTID
  74                httpLoop so
  75
  76       httpsLoop :: SSL.SSLContext -> Socket -> IO ()
  77       httpsLoop ctx so
  78           = do (ssl, addr) <- acceptHTTPS ctx so
  79                tQueue      <- newInteractionQueue
  80                readerTID   <- forkIO $ requestReader cnf tree fbs ssl addr tQueue
  81                _writerTID  <- forkIO $ responseWriter cnf ssl tQueue readerTID
  82                httpsLoop ctx so
  83
  84       acceptHTTP :: Socket -> IO (Handle, So.SockAddr)
  85       acceptHTTP soSelf
  86           = do (soPeer, addr) <- So.accept soSelf
  87                hPeer          <- So.socketToHandle soPeer ReadWriteMode
  88                return (hPeer, addr)
  89
  90       acceptHTTPS :: SSL.SSLContext -> Socket -> IO (SSL.SSL, So.SockAddr)
  91       acceptHTTPS ctx so
  92           = do (so', addr) <- So.accept so
  93                ssl         <- SSL.connection ctx so'
  94                SSL.accept ssl
  95                return (ssl, addr)