Merge branch 'simple-write'

Conflicts:
	Mighty.hs

Config/Internal.hs

@@ -26,6 +26,7 @@ defaultOption = Option {
   , opt_index_file = "index.html"
   , opt_connection_timeout = 30
   , opt_server_name = programName ++ "/" ++ programVersion
+  , opt_prefork_process_number = 1
 }
 
 data Option = Option {
@@ -43,6 +44,7 @@ data Option = Option {
   , opt_index_file :: !String
   , opt_connection_timeout :: !Int
   , opt_server_name :: !String
+  , opt_prefork_process_number :: !Int
 } deriving (Eq,Show)
 
 ----------------------------------------------------------------
@@ -68,6 +70,7 @@ makeOpt def conf = Option {
   , opt_index_file         = get "Index_File" opt_index_file
   , opt_connection_timeout = get "Connection_Timeout" opt_connection_timeout
   , opt_server_name        = get "Server_Name" opt_server_name
+  , opt_prefork_process_number = get "Prefork_Process_Number" opt_prefork_process_number
   }
   where
     get k func = maybe (func def) fromConf $ lookup k conf

FileCache.hs

@@ -1,4 +1,4 @@
-module FileCache where
+module FileCache (fileCacheInit) where
 
 import Control.Concurrent
 import Control.Exception
@@ -48,8 +48,8 @@ lok path cache = unsafePerformIO $ do
     handler :: SomeException -> IO (Cache, Maybe FileInfo)
     handler _ = neg
 
-initialize :: IO (GetInfo)
-initialize = do
+fileCacheInit :: IO (GetInfo)
+fileCacheInit = do
     ref <- newIORef M.empty
     forkIO (remover ref)
     return $ fileInfo ref

Log.hs

@@ -1,96 +1,73 @@
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings, DoAndIfThenElse #-}
 
 module Log where
 
+import Control.Applicative
 import Control.Concurrent
 import Control.Monad
+import Data.ByteString (ByteString)
 import qualified Data.ByteString.Char8 as BS
-import Data.ByteString.Lazy (ByteString)
-import qualified Data.ByteString.Lazy.Char8 as BL
+import Data.IORef
 import Data.Time
 import Network.HTTP.Types
 import Network.Wai
 import Network.Wai.Application.Classic
 import System.Directory
-import System.Exit
-import System.FilePath
-import System.IO
 import System.Locale
-import System.Posix
+import System.IO
 
 data FileLogSpec = FileLogSpec {
     log_file :: String
   , log_file_size :: Integer
   , log_backup_number :: Int
-  , log_buffer_size :: Int
-  , log_flush_period :: Int
   }
 
-fileCheck :: FileLogSpec -> IO ()
-fileCheck spec = do
-    dirperm <- getPermissions dir
-    unless (writable dirperm) $ exit $ dir ++ " is not writable"
-    fileexist <- doesFileExist file
-    when fileexist $ do
-        fileperm <- getPermissions file
-        unless (writable fileperm) $ exit $ file ++ " is not writable"
+newtype TimeRef = TimeRef (IORef ByteString)
+newtype HandleRef = HandleRef (IORef Handle)
+newtype CountRef = CountRef (IORef Int)
+
+----------------------------------------------------------------
+
+logInit :: FileLogSpec -> IO Logger
+logInit spec = do
+    timref <- clockInit
+    fdref <- fileInit spec
+    cntref <- zeroCount
+    return $ apacheLogger timref fdref cntref
+
+----------------------------------------------------------------
+
+getDate :: TimeRef -> IO ByteString
+getDate (TimeRef ref) = readIORef ref
+
+getHandle :: HandleRef -> IO Handle
+getHandle (HandleRef ref) = readIORef ref
+
+zeroCount :: IO CountRef
+zeroCount = CountRef <$> newIORef 0
+
+getCount :: CountRef -> IO Bool
+getCount (CountRef ref) = atomicModifyIORef ref func
   where
-    file = log_file spec
-    dir = takeDirectory file
-    exit msg = hPutStrLn stderr msg >> exitFailure
-
-fileInit :: FileLogSpec -> IO (Chan ByteString)
-fileInit spec = do
-    hdl <- open spec
-    mvar <- newMVar hdl
-    chan <- newChan
-    forkIO $ fileFlusher mvar spec
-    forkIO $ fileSerializer chan mvar
-    let handler = fileFlushHandler mvar
-    installHandler sigTERM handler Nothing
-    installHandler sigKILL handler Nothing
-    return chan
-
-fileFlushHandler :: MVar Handle -> Handler
-fileFlushHandler mvar = Catch $ do
-    hdl <- takeMVar mvar
-    hFlush hdl
-    putMVar mvar hdl
-    exitImmediately ExitSuccess
-
-fileFlusher :: MVar Handle -> FileLogSpec -> IO ()
-fileFlusher mvar spec = forever $ do
-    threadDelay $ log_flush_period spec
-    hdl <- takeMVar mvar
-    hFlush hdl
-    size <- hFileSize hdl
-    if size > log_file_size spec
-       then do
-        hClose hdl
-        locate spec
-        newhdl <- open spec
-        putMVar mvar newhdl
-       else putMVar mvar hdl
-
-fileSerializer :: Chan ByteString -> MVar Handle -> IO ()
-fileSerializer chan mvar = forever $ do
-    xs <- readChan chan
-    hdl <- takeMVar mvar
-    BL.hPut hdl xs
-    putMVar mvar hdl
+    func n
+      | n == 25   = (0,True) -- FIXME
+      | otherwise = (n+1,False)
+
+----------------------------------------------------------------
+
+fileInit :: FileLogSpec -> IO HandleRef
+fileInit spec = open spec >>= (\ref -> HandleRef <$> newIORef ref)
 
 open :: FileLogSpec -> IO Handle
 open spec = do
     hdl <- openFile file AppendMode
-    setFileMode file 0o644
-    hSetEncoding hdl latin1
-    hSetBuffering hdl $ BlockBuffering (Just $ log_buffer_size spec)
+    hSetBuffering hdl (BlockBuffering (Just 4096)) -- FIXME
     return hdl
   where
     file = log_file spec
 
-locate :: FileLogSpec -> IO ()
-locate spec = mapM_ move srcdsts
+rotate :: FileLogSpec -> IO ()
+rotate spec = mapM_ move srcdsts
   where
     path = log_file spec
     n = log_backup_number spec
@@ -104,27 +81,15 @@ locate spec = mapM_ move srcdsts
 
 ----------------------------------------------------------------
 
-stdoutInit :: IO (Chan ByteString)
-stdoutInit = do
-    chan <- newChan
-    forkIO $ stdoutSerializer chan
-    return chan
-
-stdoutSerializer :: Chan ByteString -> IO ()
-stdoutSerializer chan = forever $ readChan chan >>= BL.putStr
-
-----------------------------------------------------------------
-
-mightyLogger :: Chan ByteString -> Request -> Status -> Maybe Integer -> IO ()
-mightyLogger chan req st msize = do
-    zt <- getZonedTime
-    addr <- getPeerAddr (remoteHost req)
-    writeChan chan $ BL.fromChunks (logmsg addr zt)
-  where
-    logmsg addr zt = [
+apacheLogger :: TimeRef -> HandleRef -> CountRef -> Request -> Status -> Maybe Integer -> IO ()
+apacheLogger timref hdlref cntref req st msize = do
+    let addr = showSockAddr (remoteHost req)
+    tmstr <- getDate timref
+    hdl <- getHandle hdlref
+    BS.hPut hdl $ BS.concat [
         BS.pack addr
       , " - - ["
-      , BS.pack (formatTime defaultTimeLocale "%d/%b/%Y:%T %z" zt)
+      , tmstr
       , "] \""
       , requestMethod req
       , " "
@@ -139,3 +104,26 @@ mightyLogger chan req st msize = do
       , lookupRequestField' "user-agent" req
       , "\"\n"
       ]
+    flush <- getCount cntref
+    when flush $ hFlush hdl
+    return ()
+
+----------------------------------------------------------------
+
+clockInit :: IO (TimeRef)
+clockInit = do
+    ref <- timeByteString >>= newIORef
+    let timeref = TimeRef ref
+    forkIO $ clock timeref
+    return timeref
+
+clock :: TimeRef -> IO ()
+clock timeref@(TimeRef ref) = do
+    tmstr <- timeByteString
+    atomicModifyIORef ref (\_ -> (tmstr, undefined))
+    threadDelay 1000000
+    clock timeref
+
+timeByteString :: IO ByteString
+timeByteString =
+    BS.pack . formatTime defaultTimeLocale "%d/%b/%Y:%T %z" <$> getZonedTime

Mighty.hs

@@ -1,12 +1,14 @@
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings, DoAndIfThenElse #-}
 
 module Main where
 
 import Config
-import Control.Exception (handle, SomeException)
+import Control.Concurrent
+import Control.Exception (catch, handle, SomeException)
 import Control.Monad
 import qualified Data.ByteString.Char8 as BS
 import FileCGIApp
+import FileCache
 import Log
 import Network
 import Network.Wai.Application.Classic
@@ -18,15 +20,15 @@ import System.Exit
 import System.IO
 import System.Posix
 import Types
-import FileCache
 
 main :: IO ()
 main = do
     opt  <- fileName 0 >>= parseOption
     route <- fileName 1 >>= parseRoute
-    if opt_debug_mode opt
-       then server opt route
-       else daemonize $ server opt route
+    if opt_debug_mode opt then
+        server opt route
+    else
+        daemonize $ server opt route
   where
     fileName n = do
         args <- getArgs
@@ -38,49 +40,75 @@ main = do
 server :: Option -> RouteDB -> IO ()
 server opt route = handle handler $ do
     s <- sOpen
-    installHandler sigCHLD Ignore Nothing
     unless debug writePidFile
     setGroupUser opt
-    lgr <- if opt_logging opt
-              then do
-               chan <- if debug then stdoutInit else fileInit logspec
-               return $ mightyLogger chan
-              else return (\_ _ _ -> return ())
-    fif <- initialize
-    runSettingsSocket setting s $ fileCgiApp (spec lgr fif) route
+    if preN == 1 then do
+        single opt route s logspec
+--        fileRotater logspec [pid]
+    else do
+        multi opt route s logspec
+--        fileRotater logspec [pid]
   where
     debug = opt_debug_mode opt
     port = opt_port opt
-    ignore = const $ return ()
     sOpen = listenOn (PortNumber . fromIntegral $ port)
-    spec lgr fif = AppSpec {
-        softwareName = BS.pack $ opt_server_name opt
-      , indexFile = BS.pack $ opt_index_file opt
-      , isHTML = \x -> ".html" `BS.isSuffixOf` x || ".htm" `BS.isSuffixOf` x
-      , logger = lgr
-      , getFileInfo = fif
-      }
+    pidfile = opt_pid_file opt
+    preN = opt_prefork_process_number opt
+    writePidFile = do
+        pid <- getProcessID
+        writeFile pidfile $ show pid ++ "\n"
+        setFileMode pidfile 0o644
+    handler :: SomeException -> IO ()
+    handler e
+      | debug = hPutStrLn stderr $ show e
+      | otherwise = writeFile "/tmp/mighty_error" (show e)
     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
-      , log_buffer_size   = opt_log_buffer_size opt
-      , log_flush_period  = opt_log_flush_period opt * 1000000
       }
+
+single :: Option -> RouteDB -> Socket -> FileLogSpec -> IO ()
+single opt route s logspec = do
+    lgr <- if opt_logging opt then do
+               logInit logspec
+           else
+               return (\_ _ _ -> return ())
+    getInfo <- fileCacheInit
+    runSettingsSocket setting s $ fileCgiApp (spec lgr getInfo) route
+  where
+--    debug = opt_debug_mode opt
     setting = defaultSettings {
         settingsPort        = opt_port opt
       , settingsOnException = ignore
       , settingsTimeout     = opt_connection_timeout opt
       }
-    pidfile = opt_pid_file opt
-    writePidFile = do
-        pid <- getProcessID
-        writeFile pidfile $ show pid ++ "\n"
-        setFileMode pidfile 0o644
-    handler :: SomeException -> IO ()
-    handler e
-      | debug = hPutStrLn stderr $ show e
-      | otherwise = writeFile "/tmp/mighty_error" (show e)
+    spec lgr getInfo = AppSpec {
+        softwareName = BS.pack $ opt_server_name opt
+      , indexFile = BS.pack $ opt_index_file opt
+      , isHTML = \x -> ".html" `BS.isSuffixOf` x || ".htm" `BS.isSuffixOf` x
+      , logger = lgr
+      , getFileInfo = getInfo
+      }
+
+multi :: Option -> RouteDB -> Socket -> FileLogSpec -> IO ()
+multi opt route s logspec = do
+    ignoreSigChild
+    cids <- replicateM preN $ forkProcess (single opt route s logspec)
+    sClose s
+    initHandler sigTERM $ terminateHandler cids
+    initHandler sigINT  $ terminateHandler cids
+    forever $ threadDelay 10000000
+    return ()
+--    fileRotater logspec cids
+  where
+    preN = opt_prefork_process_number opt
+    initHandler sig func = installHandler sig func Nothing
+    ignoreSigChild = initHandler sigCHLD Ignore
+    terminateHandler cids = Catch $ do
+        mapM_ terminateChild cids
+        exitImmediately ExitSuccess
+    terminateChild cid = signalProcess sigTERM cid `catch` ignore
 
 ----------------------------------------------------------------
 
@@ -109,3 +137,8 @@ daemonize program = ensureDetachTerminalCanWork $ do
         forkProcess p
         exitImmediately ExitSuccess
     detachTerminal = createSession
+
+----------------------------------------------------------------
+
+ignore :: SomeException -> IO ()
+ignore = const $ return ()