mighttpd2-4.0.4: src/Server.hs
{-# 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 Data.Either (fromRight)
import qualified Data.ByteString.Char8 as BS
import Data.Streaming.Network (bindPortTCP)
import qualified Network.HTTP.Client as H
import Network.Socket (Socket, close)
import Network.Wai.Application.Classic hiding ((</>))
import Network.Wai.Handler.Warp
import Network.Wai.Logger
import System.Exit (ExitCode(..), exitSuccess)
import System.IO
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 Network.TLS.SessionManager
import qualified Network.TLS.SessionManager as SM
import Network.Wai.Handler.WarpTLS
#ifdef HTTP_OVER_QUIC
import Control.Concurrent.Async (mapConcurrently_)
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
#ifdef DROP_EXCEPT_BIND
import Control.Monad (forM_)
import Foreign.C.Types (CInt(..))
import System.Directory (listDirectory)
import System.Posix.Signals (sigUSR1)
#endif
#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 ()
server opt rpt route = reportDo rpt $ do
unlimit openFileNumber
svc <- openService opt
unless debug writePidFile
rdr <- newRouteDBRef route
tmgr <- T.initialize (naturalToInt (opt_connection_timeout opt) * 1000000)
(mcred, smgr) <- setup opt
_changed <- setGroupUser (opt_user opt) (opt_group opt)
#ifdef DROP_EXCEPT_BIND
when _changed dropExceptBind
#endif
logCheck logtype
(zdater,_) <- clockDateCacher
ap <- initLogger FromSocket logtype zdater
let lgr = apacheLogger ap
remover = logRemover ap
pushlgr = serverpushLogger ap
mgr <- getManager opt
setHandlers opt rpt svc remover rdr
report rpt "Mighty started"
runInUnboundThread $ 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 $ report rpt "obsoleted"
reloadHandler = Catch $ do
ifRouteFileIsValid rpt opt $ \newroute -> do
writeRouteDBRef rdr newroute
report rpt "Mighty reloaded"
#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 (tail r)
(s',"") -> [s']
(s',r) -> s' : split (tail 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 -> runSettingsSocket setting s app
#ifdef HTTP_OVER_TLS
HttpsOnly s -> runTLSSocket tlsSetting setting s app
HttpAndHttps s1 s2 -> concurrently_
(runSettingsSocket setting s1 app)
(runTLSSocket tlsSetting setting s2 app)
#ifdef HTTP_OVER_QUIC
QUIC s1 s2 -> 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
mapConcurrently_ id [runSettingsSocket setting s1 app
,runTLSSocket tlsSetting settingT s2 app
,runQUIC qconf setting app
]
#else
_ -> error "never reach"
#endif
#else
_ -> error "never reach"
#endif
where
app = fileCgiApp cspec filespec cgispec revproxyspec rdr
debug = opt_debug_mode opt
-- 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
$ setOnException (if debug then printStdout else warpHandler rpt)
$ 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
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
debugMessage $ urlForHTTPS httpsPort
return $ HttpsOnly s
| service == 2 = do
s1 <- bindPortTCP httpPort hostpref
s2 <- bindPortTCP httpsPort hostpref
debugMessage $ urlForHTTP httpPort
debugMessage $ urlForHTTPS httpsPort
return $ HttpAndHttps s1 s2
| service == 3 = do
s1 <- bindPortTCP httpPort hostpref
s2 <- bindPortTCP httpsPort hostpref
debugMessage $ urlForHTTP httpPort
debugMessage $ urlForHTTPS httpsPort
debugMessage "QUIC is also available via Alt-Svc"
return $ QUIC s1 s2
| otherwise = do
s <- bindPortTCP httpPort hostpref
debugMessage $ urlForHTTP httpPort
return $ HttpOnly s
where
httpPort = naturalToInt $ opt_port opt
httpsPort = naturalToInt $ opt_tls_port opt
hostpref = fromString $ opt_host opt
service = opt_service opt
debug = opt_debug_mode opt
debugMessage msg = when debug $ do
putStrLn msg
hFlush stdout
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) = close s1 >> close s2
----------------------------------------------------------------
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
#ifdef DROP_EXCEPT_BIND
foreign import ccall unsafe "send_signal"
c_send_signal :: CInt -> CInt -> IO ()
dropExceptBind :: IO ()
dropExceptBind = do
pid <- getProcessID
strtids <- listDirectory ("/proc/" ++ show pid ++ "/task")
let tids = map read strtids :: [Int]
forM_ tids $ \tid -> c_send_signal (fromIntegral tid) sigUSR1
#endif
----------------------------------------------------------------
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.newSessionManager SM.defaultConfig { dbMaxSize = 1000 }
return (mcred, smgr)
| otherwise = return (Nothing, Nothing)
where
service = opt_service opt
#else
setup _ = return (Nothing, Nothing)
#endif