{-# LANGUAGE
    UnicodeSyntax
  #-}
-- |The entry point of Lucu httpd.
module Network.HTTP.Lucu.Httpd
    ( FallbackHandler
    , runHttpd
    )
    where
import Control.Concurrent
import Control.Exception
import Control.Monad
import Control.Monad.Unicode
import Data.Maybe
import Network.BSD
import Network.Socket
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.Interaction
import Network.HTTP.Lucu.RequestReader
import Network.HTTP.Lucu.Resource.Tree
import Network.HTTP.Lucu.ResponseWriter
import Network.HTTP.Lucu.SocketLike as SL
import System.Posix.Signals

-- |This is the entry point of Lucu httpd. It listens to a socket and
-- waits for clients. 'runHttpd' never stops by itself so the only way
-- to stop it is to raise an exception in the thread running it.
--
-- Note that 'runHttpd' automatically makes SIGPIPE be ignored by
-- calling @'installHandler' 'sigPIPE' 'Ignore' 'Nothing'@. This can
-- hardly cause a problem though.
--
-- Example:
--
-- > {-# LANGUAGE OverloadedStrings #-}
-- > module Main where
-- > import Network.HTTP.Lucu
-- > 
-- > main :: IO ()
-- > main = let config    = defaultConfig
-- >            resources = mkResTree [ ([], helloWorld) ]
-- >        in
-- >          runHttpd config resourcees []
-- >
-- > helloWorld :: ResourceDef
-- > helloWorld = emptyResource {
-- >                resGet
-- >                  = Just $ do setContentType $ parseMIMEType "text/plain"
-- >                              putChunk "Hello, world!"
-- >              }
runHttpd ∷ Config → ResTree → [FallbackHandler] → IO ()
runHttpd cnf tree fbs
    = withSocketsDo $
      do void $ installHandler sigPIPE Ignore Nothing
         let launchers
                 = catMaybes
                   [ do scnf ← cnfSSLConfig    cnf
                        addr ← cnfServerV4Addr cnf
                        return ( do so ← listenOn AF_INET addr (sslServerPort scnf)
                                    launchListener (sslContext scnf, so)
                               )
                   , do scnf ← cnfSSLConfig    cnf
                        addr ← cnfServerV6Addr cnf
                        return ( do so ← listenOn AF_INET6 addr (sslServerPort scnf)
                                    launchListener (sslContext scnf, so)
                               )
                   , do addr ← cnfServerV4Addr cnf
                        return ( launchListener =≪ listenOn AF_INET addr (cnfServerPort cnf)
                               )
                   , do addr ← cnfServerV6Addr cnf
                        return ( launchListener =≪ listenOn AF_INET6 addr (cnfServerPort cnf)
                               )
                   ]
         sequence_ launchers
         waitForever
    where
      launchListener ∷ SocketLike s ⇒ s → IO ()
      launchListener so
          = do p ← SL.socketPort so
               -- FIXME: Don't throw away the thread ID as we can't
               -- kill it later then. [1]
               void $ forkIO $ httpLoop p so

      listenOn ∷ Family → HostName → ServiceName → IO Socket
      listenOn fam host srv
          = do proto ← getProtocolNumber "tcp"
               let hints = defaultHints {
                             addrFlags      = [AI_PASSIVE]
                           , addrFamily     = fam
                           , addrSocketType = Stream
                           , addrProtocol   = proto
                           }
               addrs ← getAddrInfo (Just hints) (Just host) (Just srv)
               let addr = head addrs
               bracketOnError
                   (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr))
                   sClose
                   (\ sock →
                        do setSocketOption sock ReuseAddr 1
                           bindSocket sock (addrAddress addr)
                           listen sock maxListenQueue
                           return sock
                   )

      httpLoop ∷ SocketLike s ⇒ PortNumber → s → IO ()
      httpLoop port so
          = do (h, addr)  ← SL.accept so
               tQueue     ← mkInteractionQueue
               readerTID  ← forkIO $ requestReader cnf tree fbs h port addr tQueue
               _writerTID ← forkIO $ responseWriter cnf h tQueue readerTID
               httpLoop port so

      waitForever ∷ IO ()
      waitForever = forever (threadDelay 1000000)