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           System.IO
  17 import           System.Posix.Signals
  18
  19 -- |This is the entry point of Lucu httpd. It listens to a socket and
  20 -- waits for clients. Computation of 'runHttpd' never stops by itself
  21 -- so the only way to stop it is to raise an exception in the thread
  22 -- computing it.
  23 --
  24 -- Note that 'runHttpd' automatically makes SIGPIPE be ignored by
  25 -- computing @'System.Posix.Signals.installHandler'
  26 -- 'System.Posix.Signals.sigPIPE' 'System.Posix.Signals.Ignore'
  27 -- 'Prelude.Nothing'@. This can hardly cause a problem but it may do.
  28 --
  29 -- Example:
  30 --
  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 = ResourceDef {
  42 -- >                resUsesNativeThread = False
  43 -- >              , resIsGreedy         = False
  44 -- >              , resGet
  45 -- >                  = Just $ do setContentType $ read "text/plain"
  46 -- >                              output "Hello, world!"
  47 -- >              , resHead   = Nothing
  48 -- >              , resPost   = Nothing
  49 -- >              , resPut    = Nothing
  50 -- >              , resDelete = Nothing
  51 -- >              }
  52 runHttpd :: Config -> ResTree -> [FallbackHandler] -> IO ()
  53 runHttpd cnf tree fbs
  54     = withSocketsDo $
  55       do installHandler sigPIPE Ignore Nothing
  56          so <- listenOn (cnfServerPort cnf)
  57          loop so
  58     where
  59       loop :: Socket -> IO ()
  60       loop so
  61           -- 本當は Network.accept を使ひたいが、このアクションは勝手に
  62           -- リモートのIPを逆引きするので、使へない。
  63           = do (h, addr) <- accept' so
  64                tQueue    <- newInteractionQueue
  65                readerTID <- forkIO $ requestReader cnf tree fbs h addr tQueue
  66                writerTID <- forkIO $ responseWriter cnf h tQueue readerTID
  67                loop so
  68
  69       accept' :: Socket -> IO (Handle, So.SockAddr)
  70       accept' soSelf
  71           = do (soPeer, addr) <- So.accept soSelf
  72                hPeer          <- So.socketToHandle soPeer ReadWriteMode
  73                return (hPeer, addr)