content: {-# LANGUAGE CPP #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE TupleSections #-}
  
  module Server (server, defaultDomain, defaultPort) where
  
  import Control.Concurrent (runInUnboundThread)
  import Control.Exception (try)
  import Control.Monad (unless, when)
  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, nub)
  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 $ nub 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
        when debug $ putStrLn $ urlForHTTPS httpsPort
        return $ HttpsOnly s
    | service == 2 = do
        s1 <- bindPortTCP httpPort hostpref
        s2 <- bindPortTCP httpsPort hostpref
        when debug $ putStrLn $ urlForHTTP httpPort
        when debug $ putStrLn $ urlForHTTPS httpsPort
        return $ HttpAndHttps s1 s2
    | service == 3 = do
        s1 <- bindPortTCP httpPort hostpref
        s2 <- bindPortTCP httpsPort hostpref
        ss3 <- mapM (bindPortUDP quicPort) quicAddrs
        when debug $ putStrLn $ urlForHTTP httpPort
        when debug $ putStrLn $ urlForHTTPS httpsPort
        when debug $ putStrLn "QUIC is also available via Alt-Svc"
        return $ QUIC s1 s2 ss3
    | otherwise = do
        s <- bindPortTCP httpPort hostpref
        when debug $ putStrLn $ urlForHTTP httpPort
        return $ HttpOnly s
    where
      debug = opt_debug_mode opt
      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
  