{-# LANGUAGE
    CPP
  , UnicodeSyntax
  #-}
-- |The entry point of Lucu httpd.
module Network.HTTP.Lucu.Httpd
    ( 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.Dispatcher
import Network.HTTP.Lucu.Interaction
import Network.HTTP.Lucu.RequestReader
import Network.HTTP.Lucu.ResponseWriter
import Network.HTTP.Lucu.SocketLike as SL
import Prelude.Unicode

-- |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.
--
-- Example:
--
-- @
--   {-\# LANGUAGE OverloadedStrings \#-}
--   {-\# LANGUAGE QuasiQuotes \#-}
--   module Main where
--   import qualified "Data.Collections" as C
--   import "Network"
--   import "Network.HTTP.Lucu"
--
--   main :: 'IO' ()
--   main = let config = 'defaultConfig'
--              tree   :: 'ResourceTree'
--              tree   = C.fromList [ ([], 'nonGreedy' helloWorld) ]
--          in
--            'Network.withSocketsDo' '.' 'runHttpd' config '$' 'resourceMap' tree
--
--   helloWorld :: 'Network.HTTP.Lucu.Resource'
--   helloWorld = C.fromList
--                [ ( 'Network.HTTP.Lucu.GET'
--                  , do 'Network.HTTP.Lucu.setContentType' ['Network.HTTP.Lucu.mimeType'| text/plain |]
--                       'Network.HTTP.Lucu.putChunk' \"Hello, world!\"
--                }
-- @
-- FIXME: use monad-parallel's MonadFork instead of IO.
runHttpd ∷ HostMapper α ⇒ Config → α → IO ()
runHttpd cnf hm
    = do let launchers
                 = catMaybes
                   [ do addr ← cnfServerV4Addr cnf
                        return ( launchListener =≪ listenOn AF_INET addr (cnfServerPort cnf)
                               )
                   , do addr ← cnfServerV6Addr cnf
                        return ( launchListener =≪ listenOn AF_INET6 addr (cnfServerPort cnf)
                               )
#if defined(HAVE_SSL)
                   , 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)
                               )
#endif
                   ]
         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.
               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 hm h port addr tQueue
               _writerTID ← forkIO $ responseWriter cnf h tQueue readerTID
               httpLoop port so

      waitForever ∷ IO ()
      waitForever = forever $ threadDelay 1000000