{-# LANGUAGE OverloadedStrings #-}

module Main where

import Config
import Control.Applicative
import Control.Concurrent
import Control.Exception
import Control.Monad
import qualified Data.ByteString.Char8 as BS
import Data.Conduit.Network
import FileCGIApp
import FileCache
import Network
import qualified Network.HTTP.Conduit as H
import Network.Wai.Application.Classic hiding ((</>), (+++))
import Network.Wai.Handler.Warp
import Network.Wai.Logger
import Network.Wai.Logger.Prefork
import Process
import Report
import Route
import Signal
import State
import System.Directory
import System.Environment
import System.Exit
import System.FilePath
import System.IO
import System.IO.Error (ioeGetErrorString)
import System.Posix
import Types
import Utils

----------------------------------------------------------------

main :: IO ()
main = do
    (opt,route) <- getOptRoute
    if opt_debug_mode opt then
        server opt route
      else do
        let port = opt_port opt
        putStrLn $ "Serving on port " ++ show port ++ " and detaching this terminal..."
        putStrLn $ "(If errors occur, they will be written in \"" ++ reportFile ++ "\".)"
        hFlush stdout
        daemonize $ server opt route
  where
    getOptRoute = getArgs >>= eachCase
    eachCase args
      | n == 0 = do
          root <- amIrootUser
          let opt | root      = defaultOption { opt_port = 80 }
                  | otherwise = defaultOption
          dir <- getCurrentDirectory
          let dst = fromString . addTrailingPathSeparator $ dir
              route = [Block ["*"] [RouteFile "/" dst]]
          return (opt, route)
      | n == 2 = do
          let config_file = args !! 0
          routing_file <- getAbsoluteFile (args !! 1)
          opt   <- parseOption config_file
          route <- parseRoute  routing_file
          let opt' = opt {opt_routing_file = Just routing_file}
          return (opt',route)
      | otherwise = do
          hPutStrLn stderr "Usage: mighty"
          hPutStrLn stderr "       mighty config_file routing_file"
          exitFailure
      where
        n = length args
    getAbsoluteFile file
        | isAbsolute file = return file
        | otherwise       = do
            dir <- getCurrentDirectory
            return $ dir </> normalise file

----------------------------------------------------------------

server :: Option -> RouteDB -> IO ()
server opt route = safeDo $ do
    s <- sOpen
    if debug then do
        putStrLn $ "Serving on port " ++ show port ++ "."
        hFlush stdout
      else
        writePidFile
    logCheck logtype
    sref <- initState
    myid <- getProcessID
    if workers == 1 then do
        void . forkIO $ single opt route s logtype sref -- killed by signal
        void . forkIO $ logController logtype [myid]
        slaveMainLoop sref
      else do
        cids <- multi opt route s logtype sref
        void . forkIO $ logController logtype cids
        masterMainLoop myid
  where
    debug = opt_debug_mode opt
    port = opt_port opt
    sOpen = listenOn (PortNumber . fromIntegral $ port)
    pidfile = opt_pid_file opt
    workers = opt_worker_processes opt
    writePidFile = do
        pid <- getProcessID
        writeFile pidfile $ show pid ++ "\n"
        setFileMode pidfile 0o644
    logspec = FileLogSpec {
        log_file          = opt_log_file opt
      , log_file_size     = fromIntegral $ opt_log_file_size opt
      , log_backup_number = opt_log_backup_number opt
      }
    logtype
      | not (opt_logging opt) = LogNone
      | debug                 = LogStdout
      | otherwise             = LogFile logspec

----------------------------------------------------------------

masterMainLoop :: ProcessID -> IO ()
masterMainLoop myid = do
    threadDelay 10000000
    cs <- findChildren myid
    if null cs then -- FIXME serverStatus st == Retiring
        report "Master Mighty retired"
      else
        masterMainLoop myid

slaveMainLoop :: StateRef -> IO ()
slaveMainLoop sref = do
    threadDelay 1000000
    st <- getState sref
    if serverStatus st == Retiring && connectionCounter st == 0 then
        report "Worker Mighty retired"
      else
        slaveMainLoop sref

----------------------------------------------------------------

safeDo :: IO () -> IO ()
safeDo act = act `catches` [Handler asynHandler, Handler someHandler]

asynHandler :: AsyncException -> IO ()
asynHandler e
  | e == ThreadKilled = return ()
  | otherwise         = report $ bshow e

someHandler :: SomeException -> IO ()
someHandler e = report $ bshow e

----------------------------------------------------------------

single :: Option -> RouteDB -> Socket -> LogType -> StateRef -> IO ()
single opt route s logtype sref = safeDo $ do
    setGroupUser opt -- don't change the user of the master process
    ignoreSigChild
    lgr <- logInit FromSocket logtype
    getInfo <- fileCacheInit
    mgr <- H.newManager H.def {
            -- FIXME
            H.managerConnCount = 1024
          }
    setHandler sigStop   stopHandler
    setHandler sigRetire retireHandler
    setHandler sigReload (reloadHandler lgr getInfo mgr)
    setHandler sigInfo   infoHandler
    report "Worker Mighty started"
    single' opt route s sref lgr getInfo mgr
  where
    stopHandler = Catch $ do
        report "Worker Mighty finished"
        sClose s
        exitImmediately ExitSuccess
    retireHandler = Catch $
        warpThreadId <$> getState sref >>>= \tid -> do
            report "Worker Mighty retiring"
            killThread tid
            sClose s
            retireStatus sref
    reloadHandler lgr getInfo mgr = Catch $
        warpThreadId <$> getState sref >>>= \tid ->
        ifRouteFileIsValid opt $ \newroute -> do
            report "Worker Mighty reloaded"
            killThread tid
            void . forkIO $ single' opt newroute s sref lgr getInfo mgr
    infoHandler = Catch $ do
        st <- getState sref
        let i =  bshow $ connectionCounter st
            status = bshow $ serverStatus st
        report $ status +++ ": # of connections = " +++ i

single' :: Option -> RouteDB -> Socket
        -> StateRef -> ApacheLogger -> (Path -> IO FileInfo) -> H.Manager
        -> IO ()
single' opt route s sref lgr getInfo mgr = safeDo $ do
    myThreadId >>= setWarpThreadId sref
    runSettingsSocket setting s $ \req ->
        fileCgiApp cspec filespec cgispec revproxyspec route req
  where
    debug = opt_debug_mode opt
    setting = defaultSettings {
        settingsPort        = opt_port opt
      , settingsOnException = if debug then printStdout else ignore
      , settingsOnOpen      = increment sref
      , settingsOnClose     = decrement sref
      , settingsTimeout     = opt_connection_timeout opt
      , settingsHost        = HostAny
      }
    serverName = BS.pack $ opt_server_name opt
    cspec = ClassicAppSpec {
        softwareName = serverName
      , logger = lgr
      , statusFileDir = fromString $ opt_status_file_dir opt
      }
    filespec = FileAppSpec {
        indexFile = fromString $ opt_index_file opt
      , isHTML = \x -> ".html" `isSuffixOf` x || ".htm" `isSuffixOf` x
      , getFileInfo = getInfo
      }
    cgispec = CgiAppSpec {
        indexCgi = "index.cgi"
      }
    revproxyspec = RevProxyAppSpec {
        revProxyManager = mgr
      }

----------------------------------------------------------------

multi :: Option -> RouteDB -> Socket -> LogType -> StateRef -> IO [ProcessID]
multi opt route s logtype sref = do
    report "Master Mighty started"
    ignoreSigChild
    cids <- replicateM workers $ forkProcess $ do
        void . forkIO $ single opt route s logtype sref -- killed by signal
        slaveMainLoop sref
    sClose s
    setHandler sigStop   $ stopHandler cids
    setHandler sigINT    $ stopHandler cids -- C-c from keyboard when debugging
    setHandler sigRetire $ retireHandler cids
    setHandler sigReload $ reloadHandler cids
    setHandler sigInfo   $ infoHandler cids
    return cids
  where
    workers = opt_worker_processes opt
    stopHandler cids   = Catch $ do
        report "Master Mighty finished"
        mapM_ (sendSignal sigStop) cids
        exitImmediately ExitSuccess
    retireHandler cids = Catch $ do
        report "Master Mighty retiring"
        retireStatus sref
        mapM_ (sendSignal sigRetire) cids
    reloadHandler cids = Catch $ ifRouteFileIsValid opt $ \_ -> do
        report "Master Mighty reloaded"
        mapM_ (sendSignal sigReload) cids
    infoHandler cids   = Catch $ mapM_ (sendSignal sigInfo) cids

----------------------------------------------------------------

ifRouteFileIsValid :: Option -> (RouteDB -> IO ()) -> IO ()
ifRouteFileIsValid opt act =
    return (opt_routing_file opt) >>>= \rfile ->
    try (parseRoute rfile) >>= either reportError act
  where
    reportError = report . BS.pack . ioeGetErrorString

----------------------------------------------------------------

amIrootUser :: IO Bool
amIrootUser = (== 0) <$> getRealUserID

setGroupUser :: Option -> IO ()
setGroupUser opt = do
    root <- amIrootUser
    when root $ do
        getGroupEntryForName (opt_group opt) >>= setGroupID . groupID
        getUserEntryForName (opt_user opt) >>= setUserID . userID

----------------------------------------------------------------

daemonize :: IO () -> IO ()
daemonize program = ensureDetachTerminalCanWork $ do
    detachTerminal
    ensureNeverAttachTerminal $ do
        changeWorkingDirectory "/"
        void $ setFileCreationMask 0
        mapM_ closeFd [stdInput, stdOutput, stdError]
        program
  where
    ensureDetachTerminalCanWork p = do
        void $ forkProcess p
        exitImmediately ExitSuccess
    ensureNeverAttachTerminal p = do
        void $ forkProcess p
        exitImmediately ExitSuccess
    detachTerminal = void createSession