-
Notifications
You must be signed in to change notification settings - Fork 3
/
Mighttpd.hs
108 lines (95 loc) · 3.03 KB
/
Mighttpd.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
{-# LANGUAGE BangPatterns#-}
module Main where
import Config
import Control.Monad
import File
import LogMsg
import Network.C10kServer
import Network.Web.Server
import System.Environment
import System.Exit
import System.IO
import System.Posix
import URLMap
----------------------------------------------------------------
main :: IO ()
main = do
conf <- readFile =<< fileName 0
mapf <- readFile =<< fileName 1
let !opt = parseOption conf
!webConfig = toWebConfig opt
!c10kConfig = toC10kConfig opt
!uriMap = parseURLMap mapf
!prog = mighty webConfig uriMap
if opt_debug_mode opt
then runC10kServerH prog c10kConfig
else daemonize $ runC10kServerH prog c10kConfig
where
fileName n = do
args <- getArgs
when (length args /= 2) $ do
hPutStrLn stderr "Usage: mighttpd config_file uri_map"
exitFailure
return $ args !! n
----------------------------------------------------------------
toWebConfig :: Option -> WebConfig
toWebConfig opt = WebConfig {
closedHook = debugMsg
, accessHook = noticeMsg
, errorHook = warnMsg
, fatalErrorHook = errorMsg
, connectionTimer = opt_connection_timer opt
}
toC10kConfig :: Option -> C10kConfig
toC10kConfig opt = C10kConfig {
initHook = makeInitHook opt
, exitHook = makeExitHook
, parentStartedHook = makeParentHook
, startedHook = makeStartedHook opt
, sleepTimer = opt_sleep_timer opt
, preforkProcessNumber = opt_prefork_process_number opt
, threadNumberPerProcess = opt_thread_number_per_process opt
, portName = show $ opt_port opt
, ipAddr = Nothing
, pidFile = opt_pid_file opt
, user = opt_user opt
, group = opt_group opt
}
makeInitHook :: Option -> IO ()
makeInitHook opt =
if opt_debug_mode opt
then initLog progName "" (opt_log_level opt) StdErr
else initLog progName (opt_syslog_facility opt) (opt_log_level opt) SysLog
makeExitHook :: String -> IO ()
makeExitHook = errorMsg
makeParentHook :: IO ()
makeParentHook = infoMsg $ progName ++ " started"
makeStartedHook :: Option -> IO ()
makeStartedHook opt = do
let initlog = opt_prefork_process_number opt /= 1
if opt_debug_mode opt
then do
ignoreSigChild
when initlog $ initLog progName "" (opt_log_level opt) StdErr
else do
ignoreSigChild
when initlog $ initLog progName (opt_syslog_facility opt) (opt_log_level opt) SysLog
where
ignoreSigChild = installHandler sigCHLD Ignore Nothing
----------------------------------------------------------------
daemonize :: IO () -> IO ()
daemonize program = ensureDetachTerminalCanWork $ do
detachTerminal
ensureNeverAttachTerminal $ do
changeWorkingDirectory "/"
setFileCreationMask 0
mapM_ closeFd [stdInput, stdOutput, stdError]
program
where
ensureDetachTerminalCanWork p = do
forkProcess p
exitImmediately ExitSuccess
ensureNeverAttachTerminal p = do
forkProcess p
exitImmediately ExitSuccess
detachTerminal = createSession