{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}

module Server (server, defaultDomain, defaultPort) where

import Control.Concurrent (runInUnboundThread)
import Control.Exception (try)
import Control.Monad (unless)
import qualified Data.ByteString.Char8 as BS
import Data.Either (fromRight)
import Data.Streaming.Network (bindPortTCP, bindPortUDP)
#if __GLASGOW_HASKELL__ >= 906
import GHC.Conc.Sync
import Data.List (sort)
import Data.Maybe (fromMaybe)
#endif
import qualified Network.HTTP.Client as H
import Network.Socket (Socket, close)
import Network.Wai
import Network.Wai.Application.Classic hiding ((</>))
import Network.Wai.Handler.Warp
import Network.Wai.Logger
import System.Exit (ExitCode(..), exitSuccess)
import System.IO.Error (ioeGetErrorString)
import System.Posix (exitImmediately, Handler(..), getProcessID, setFileMode)
import System.Posix.Signals (sigCHLD)
import qualified System.TimeManager as T

import Program.Mighty
import WaiApp

#ifdef HTTP_OVER_TLS
import Control.Concurrent.Async (concurrently_)
import Data.Char (isSpace)
import Data.List (dropWhileEnd)
import Network.TLS (Credentials(..),SessionManager)
import qualified Network.TLS as TLS
import qualified Network.TLS.SessionTicket as SM
import Network.Wai.Handler.WarpTLS
#ifdef HTTP_OVER_QUIC
import Data.Bits
import Data.ByteString (ByteString)
import Data.List (find)
import Data.Maybe (fromJust)
import qualified Network.QUIC.Internal as Q
import Network.Wai.Handler.WarpQUIC
#endif
#else
data Credentials
data SessionManager
#endif

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

defaultDomain :: Domain
defaultDomain = "localhost"

defaultPort :: Natural
defaultPort = 80

openFileNumber :: Integer
openFileNumber = 10000

logBufferSize :: Natural
logBufferSize = 4 * 1024 * 10

managerNumber :: Int
managerNumber = 1024 -- FIXME

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

type LogRemover = IO ()

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

server :: Option -> Reporter -> RouteDB -> (IO () -> IO ()) -> IO ()
server opt rpt route runMighty = reportDo rpt $ do
    labelMe "Mighty main"
    unlimit openFileNumber
    svc <- openService opt
    runMighty $ do
        unless debug writePidFile
        rdr <- newRouteDBRef route
        let usec = naturalToInt (opt_connection_timeout opt) * 1000000
        T.withManager usec $ \tmgr -> do
            (mcred, smgr) <- setup opt
            _changed <- setGroupUser (opt_user opt) (opt_group opt)
            logCheck logtype
            -- "Time cacher of FastLogger (AutoUpdate)"
            (zdater,_) <- clockDateCacher
            -- Loggerset of FastLogger (Debounce)
            ap <- initLogger FromSocket logtype zdater
            let lgr = apacheLogger ap
                remover = logRemover ap
                pushlgr = serverpushLogger ap
            -- HTTP Client Manager
            mgr <- getManager opt
            setHandlers opt rpt svc remover rdr

            report rpt "Mighty started"
            runInUnboundThread $ do
                labelMe "Mighty main (bound thread)"
                mighty opt rpt svc lgr pushlgr mgr rdr mcred smgr tmgr
            report rpt "Mighty retired"
            remover
            exitSuccess
  where
    debug = opt_debug_mode opt
    port = opt_port opt
    pidfile
        | port == 80 = opt_pid_file opt
        | otherwise  = opt_pid_file opt ++ show port
    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 = naturalToInt $ opt_log_backup_number opt
      }
    logtype
      | not (opt_logging opt) = LogNone
      | debug                 = LogStdout $ naturalToInt logBufferSize
      | otherwise             = LogFile logspec $ naturalToInt logBufferSize

setHandlers :: Option -> Reporter -> Service -> LogRemover -> RouteDBRef -> IO ()
setHandlers opt rpt svc remover rdr = do
    setHandler sigStop   stopHandler
    setHandler sigRetire retireHandler
    setHandler sigInfo   infoHandler
    setHandler sigReload reloadHandler
    setHandler sigCHLD   Ignore        -- for CGI
  where
    stopHandler = Catch $ do
        report rpt "Mighty finished"
        closeService svc
        remover
        exitImmediately ExitSuccess
    retireHandler = Catch $ do
        report rpt "Mighty retiring"
        closeService svc -- this lets warp break
    infoHandler = Catch $ do
        labelMe "Info signale handler"
        threadSummary >>= mapM_ (report rpt . showT)
    showT (i, l, s) = BS.pack (i ++ " " ++ l ++ ": " ++ show s)
    reloadHandler = Catch $ do
        ifRouteFileIsValid rpt opt $ \newroute -> do
            writeRouteDBRef rdr newroute
            report rpt "Mighty reloaded"

#if __GLASGOW_HASKELL__ >= 906
threadSummary :: IO [(String, String, ThreadStatus)]
threadSummary = (sort <$> listThreads) >>= mapM summary
  where
    summary t = do
        let idstr = drop 9 $ show t
        l <- fromMaybe "(no name)" <$> threadLabel t
        s <- threadStatus t
        return (idstr, l, s)
#else
threadSummary :: IO [(String, String, String)]
threadSummary = return []
#endif

#ifdef HTTP_OVER_TLS
loadCredentials :: Option -> IO Credentials
loadCredentials opt = do
    cert   <- BS.readFile $ opt_tls_cert_file opt
    chains <- mapM BS.readFile chain_files
    key    <- BS.readFile $ opt_tls_key_file opt
    let cred = fromRight (error "loadCredentials") $ TLS.credentialLoadX509ChainFromMemory cert chains key
    return $ Credentials [cred]
  where
    strip = dropWhileEnd isSpace . dropWhile isSpace
    split "" = []
    split s = case break (',' ==) s of
      ("",r)  -> split $ drop 1 r
      (s',"") -> [s']
      (s',r)  -> s' : split (drop 1 r)
    chain_files = map strip $ split $ opt_tls_chain_files opt
#endif

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

ifRouteFileIsValid :: Reporter -> Option -> (RouteDB -> IO ()) -> IO ()
ifRouteFileIsValid rpt opt act = case opt_routing_file opt of
    Nothing    -> return ()
    Just rfile -> try (parseRoute rfile defaultDomain defaultPort) >>= either reportError_ act
  where
    reportError_ = report rpt . BS.pack . ioeGetErrorString

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

mighty :: Option -> Reporter -> Service
       -> ApacheLogger -> ServerPushLogger
       -> ConnPool -> RouteDBRef
       -> Maybe Credentials -> Maybe SessionManager -> T.Manager
       -> IO ()
mighty opt rpt svc lgr pushlgr mgr rdr _mcreds _msmgr tmgr
  = reportDo rpt $ case svc of
    HttpOnly s  -> runHTTP setting s app
#ifdef HTTP_OVER_TLS
    HttpsOnly s -> runHTTPS tlsSetting setting s app
    HttpAndHttps s1 s2 -> concurrently_
        (runHTTP setting s1 app)
        (runHTTPS tlsSetting setting s2 app)
#ifdef HTTP_OVER_QUIC
    QUIC s1 s2 ss3 -> do
        let quicPort' = BS.pack $ show quicPort
            strver Q.Version1 = ""
            strver Q.Version2 = ""
            strver v = BS.append "-" $ BS.pack $ show $ fromVersion v
            quicDrafts = map strver quicVersions
            value v = BS.concat ["h3",v,"=\":",quicPort',"\""]
            altsvc = BS.intercalate "," $ map value quicDrafts
            settingT = setAltSvc altsvc setting
            h12  = concurrently_ (runHTTP             setting  s1 app)
                                 (runHTTPS tlsSetting settingT s2 app)
            h123 = concurrently_ (runHTTP3 qconf      setting  ss3 app)
                                 (labelMe "concurrently" >> h12)
        h123
#else
    _ -> error "never reach"
#endif
#else
    _ -> error "never reach"
#endif
  where
    app = fileCgiApp cspec filespec cgispec revproxyspec rdr
    -- We don't use setInstallShutdownHandler because we may use
    -- two sockets for HTTP and HTTPS.
    setting = setPort            (naturalToInt $ opt_port opt) -- just in case
            $ setHost            (fromString (opt_host opt))  -- just in case
            $ setManager         tmgr
            $ setFdCacheDuration (naturalToInt $ opt_fd_cache_duration opt)
            $ setFileInfoCacheDuration 10
            $ setServerName      serverName
            $ setLogger          lgr
            $ setServerPushLogger pushlgr
            defaultSettings
#ifdef HTTP_OVER_TLS
    ~tlsSetting = defaultTlsSettings {
        tlsCredentials    = _mcreds
      , tlsSessionManager = _msmgr
      , tlsAllowedVersions = [TLS.TLS13,TLS.TLS12]
      }
#endif
    serverName = BS.pack $ opt_server_name opt
    cspec = ClassicAppSpec {
        softwareName = serverName
      , statusFileDir = fromString $ opt_status_file_dir opt
      }
    filespec = FileAppSpec {
        indexFile = fromString $ opt_index_file opt
      , isHTML = \x -> ".html" `isSuffixOf` x || ".htm" `isSuffixOf` x
      }
    cgispec = CgiAppSpec {
        indexCgi = "index.cgi"
      }
    revproxyspec = RevProxyAppSpec {
        revProxyManager = mgr
      }
#ifdef HTTP_OVER_QUIC
    ~quicAddr = read <$> opt_quic_addr opt
    ~quicPort = fromIntegral $ opt_quic_port opt
    ~quicVersions = Q.scVersions Q.defaultServerConfig
    -- Lazy binding for opt_service == 0 so that
    -- 'fromJust' is not called.
    ~qconf = Q.defaultServerConfig {
            Q.scAddresses      = (,quicPort) <$> quicAddr
          , Q.scALPN           = Just chooseALPN
          , Q.scRequireRetry   = False
          , Q.scSessionManager = fromJust _msmgr
          , Q.scUse0RTT        = True
          , Q.scDebugLog       = opt_quic_debug_dir opt
          , Q.scQLog           = opt_quic_qlog_dir opt
          , Q.scCredentials    = fromJust _mcreds
          }

chooseALPN :: Q.Version -> [ByteString] -> IO ByteString
chooseALPN ver protos = case find (\x -> x == h3 || x == hq) protos of
  Nothing    -> return ""
  Just proto -> return proto
  where
    h3 | ver == Q.Version1 = "h3"
       | ver == Q.Version2 = "h3"
       | otherwise = "h3-" `BS.append` BS.pack (show (fromVersion ver))
    hq | ver == Q.Version1 = "hq-interop"
       | ver == Q.Version2 = "hq-interop"
       | otherwise = "hq-" `BS.append` BS.pack (show (fromVersion ver))

fromVersion :: Q.Version -> Int
fromVersion (Q.Version ver) = fromIntegral (0x000000ff .&. ver)
#endif

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

data Service = HttpOnly Socket
             | HttpsOnly Socket
             | HttpAndHttps Socket Socket
             | QUIC Socket Socket [Socket]

instance Show Service where
    show HttpOnly{}     = "HttpOnly"
    show HttpsOnly{}    = "HttpOnlys"
    show HttpAndHttps{} = "HttpAndHttps"
    show QUIC{}         = "QUIC"

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

openService :: Option -> IO Service
openService opt
  | service == 1 = do
      s <- bindPortTCP httpsPort hostpref
      putStrLn $ urlForHTTPS httpsPort
      return $ HttpsOnly s
  | service == 2 = do
      s1 <- bindPortTCP httpPort hostpref
      s2 <- bindPortTCP httpsPort hostpref
      putStrLn $ urlForHTTP httpPort
      putStrLn $ urlForHTTPS httpsPort
      return $ HttpAndHttps s1 s2
  | service == 3 = do
      s1 <- bindPortTCP httpPort hostpref
      s2 <- bindPortTCP httpsPort hostpref
      ss3 <- mapM (bindPortUDP quicPort) quicAddrs
      putStrLn $ urlForHTTP httpPort
      putStrLn $ urlForHTTPS httpsPort
      putStrLn "QUIC is also available via Alt-Svc"
      return $ QUIC s1 s2 ss3
  | otherwise = do
      s <- bindPortTCP httpPort hostpref
      putStrLn $ urlForHTTP httpPort
      return $ HttpOnly s
  where
    httpPort  = naturalToInt $ opt_port opt
    httpsPort = naturalToInt $ opt_tls_port opt
    quicPort = naturalToInt $ opt_quic_port opt
    quicAddrs = fromString <$> opt_quic_addr opt
    hostpref  = fromString $ opt_host opt
    service = opt_service opt
    urlForHTTP  80  =  "http://localhost/"
    urlForHTTP  p   =  "http://localhost:" ++ show p ++ "/"
    urlForHTTPS 443 = "https://localhost/"
    urlForHTTPS p   = "https://localhost:" ++ show p ++ "/"


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

closeService :: Service -> IO ()
closeService (HttpOnly s)         = close s
closeService (HttpsOnly s)        = close s
closeService (HttpAndHttps s1 s2) = close s1 >> close s2
closeService (QUIC s1 s2 ss3)     = close s1 >> close s2 >> mapM_ close ss3

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

type ConnPool = H.Manager

getManager :: Option -> IO ConnPool
getManager opt = H.newManager H.defaultManagerSettings {
    H.managerConnCount = managerNumber
  , H.managerResponseTimeout = responseTimeout
  }
  where
    responseTimeout
      | opt_proxy_timeout opt == 0 = H.managerResponseTimeout H.defaultManagerSettings
      | otherwise                  = H.responseTimeoutMicro (naturalToInt $ opt_proxy_timeout opt * 1000000) -- micro seconds

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

setup :: Option -> IO (Maybe Credentials, Maybe SessionManager)
#ifdef HTTP_OVER_TLS
setup opt
  | 1 <= service && service <= 3 = do
        mcred <- Just <$> loadCredentials opt
        smgr <- Just <$> SM.newSessionTicketManager SM.defaultConfig
        return (mcred, smgr)
  | otherwise = return (Nothing, Nothing)
  where
    service = opt_service opt
#else
setup _ = return (Nothing, Nothing)
#endif

labelMe :: String -> IO ()
#if __GLASGOW_HASKELL__ >= 906
labelMe lbl = do
    tid <- myThreadId
    labelThread tid lbl
#else
labelMe _ = return ()
#endif

runHTTP :: Settings -> Socket -> Application -> IO ()
runHTTP setting s app = do
    labelMe "HTTP1/2 server"
    runSettingsSocket setting s app

#ifdef HTTP_OVER_TLS
runHTTPS :: TLSSettings -> Settings -> Socket -> Application -> IO ()
runHTTPS tlsSetting setting s app = do
    labelMe "HTTP1/2 over TLS server"
    runTLSSocket tlsSetting setting s app

#ifdef HTTP_OVER_QUIC
runHTTP3 :: QUICSettings -> Settings -> [Socket]-> Application -> IO ()
runHTTP3 qconf setting ss app = do
    labelMe "HTTP3 server"
    runQUICSockets qconf setting ss app
#endif
#endif
