diff --git a/Log.hs b/Log.hs deleted file mode 100644 --- a/Log.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Log ( - logInit - , logController - , logCheck - , module Log.Types - ) where - -import Control.Concurrent -import Control.Monad -import Log.Check -import Log.File -import Log.Stdout -import Log.Types - ----------------------------------------------------------------- - -logInit :: LogType -> IO Logger -logInit LogNone = noLoggerInit -logInit LogStdout = stdoutLoggerInit -logInit (LogFile spec) = fileLoggerInit spec - -noLoggerInit :: IO Logger -noLoggerInit = return noLogger - where - noLogger _ _ _ = return () - -logController :: LogType -> LogController -logController LogNone = noLoggerController -logController LogStdout = noLoggerController -logController (LogFile spec) = fileLoggerController spec - -noLoggerController :: LogController -noLoggerController _ = forever $ threadDelay 10000000 diff --git a/Log/Apache.hs b/Log/Apache.hs deleted file mode 100644 --- a/Log/Apache.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Log.Apache where - -import Data.ByteString (ByteString) -import Data.ByteString.Char8 () -import Network.HTTP.Types -import Network.Wai -import Network.Wai.Application.Classic -import Log.Types - -apacheFormat :: ByteString -> Request -> Status -> Maybe Integer -> [LogStr] -apacheFormat tmstr req st msize = [ - LS addr - , LB " - - [" - , LB tmstr - , LB "] \"" - , LB $ requestMethod req - , LB " " - , LB $ rawPathInfo req - , LB " " - , LS $ show . httpVersion $ req - , LB "\" " - , LS . show . statusCode $ st - , LB " " - , LS $ maybe "-" show msize - , LB " \"" - , LB $ lookupRequestField' "referer" req - , LB "\" \"" - , LB $ lookupRequestField' "user-agent" req - , LB "\"\n" - ] - where - addr = showSockAddr (remoteHost req) diff --git a/Log/Check.hs b/Log/Check.hs deleted file mode 100644 --- a/Log/Check.hs +++ /dev/null @@ -1,22 +0,0 @@ -module Log.Check (logCheck) where - -import Control.Monad -import Log.Types -import System.Directory -import System.FilePath - -logCheck :: LogType -> IO () -logCheck LogNone = return () -logCheck LogStdout = return () -logCheck (LogFile spec) = do - dirExist <- doesDirectoryExist dir - unless dirExist $ fail $ dir ++ " does not exist or is not a directory." - dirPerm <- getPermissions dir - unless (writable dirPerm) $ fail $ dir ++ " is not writable." - exist <- doesFileExist file - when exist $ do - perm <- getPermissions file - unless (writable perm) $ fail $ file ++ " is not writable." - where - file = log_file spec - dir = takeDirectory file diff --git a/Log/Date.hs b/Log/Date.hs deleted file mode 100644 --- a/Log/Date.hs +++ /dev/null @@ -1,32 +0,0 @@ -module Log.Date (dateInit, getDate, DateRef) where - -import Control.Applicative -import Control.Concurrent -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as BS -import Data.IORef -import Data.Time -import System.Locale - -newtype DateRef = DateRef (IORef ByteString) - -getDate :: DateRef -> IO ByteString -getDate (DateRef ref) = readIORef ref - -dateInit :: IO DateRef -dateInit = do - ref <- formatDate >>= newIORef - let dateref = DateRef ref - forkIO $ date dateref - return dateref - -date :: DateRef -> IO () -date dateref@(DateRef ref) = do - tmstr <- formatDate - atomicModifyIORef ref (\_ -> (tmstr, ())) - threadDelay 1000000 - date dateref - -formatDate :: IO ByteString -formatDate = - BS.pack . formatTime defaultTimeLocale "%d/%b/%Y:%T %z" <$> getZonedTime diff --git a/Log/File.hs b/Log/File.hs deleted file mode 100644 --- a/Log/File.hs +++ /dev/null @@ -1,96 +0,0 @@ -{-# LANGUAGE DoAndIfThenElse #-} - -module Log.File where - -import Control.Applicative -import Control.Concurrent -import Control.Exception (handle, SomeException, catch) -import Control.Monad -import Data.IORef -import Log.Apache -import Log.Date -import Log.Hput -import Log.Rotate -import Log.Types -import Prelude hiding (catch) -import System.IO -import System.Posix - ----------------------------------------------------------------- - -logBufSize :: Int -logBufSize = 4096 - ----------------------------------------------------------------- - -newtype HandleRef = HandleRef (IORef Handle) - -getHandle :: HandleRef -> IO Handle -getHandle (HandleRef ref) = readIORef ref - ----------------------------------------------------------------- - -fileLoggerInit :: FileLogSpec -> IO Logger -fileLoggerInit spec = do - hdl <- open spec - hdlref <- HandleRef <$> newIORef hdl - forkIO $ fileFlusher hdlref - dateref <- dateInit - installHandler sigUSR1 (Catch $ reopen spec hdlref) Nothing - return $ fileLogger dateref hdlref - -{- - For BlockBuffering, hPut flushes the buffer before writing - the target string. In other words, hPut does not split - the target string. So, to implment multiple line buffering, - just use BlockBuffering. --} -open :: FileLogSpec -> IO Handle -open spec = do - hdl <- openFile file AppendMode - hSetBuffering hdl (BlockBuffering (Just logBufSize)) - return hdl - where - file = log_file spec - -reopen :: FileLogSpec -> HandleRef -> IO () -reopen spec (HandleRef ref) = do - hdl <- open spec - oldhdl <- atomicModifyIORef ref (\oh -> (hdl,oh)) - hClose oldhdl - ----------------------------------------------------------------- - -fileLogger :: DateRef -> HandleRef -> Logger -fileLogger dateref hdlref req status msiz = do - date <- getDate dateref - hdl <- getHandle hdlref - hPutByteStrings hdl $ apacheFormat date req status msiz - -fileFlusher :: HandleRef -> IO () -fileFlusher hdlref = forever $ do - threadDelay 10000000 - getHandle hdlref >>= hFlush - ----------------------------------------------------------------- - -fileLoggerController :: FileLogSpec -> LogController -fileLoggerController spec pids = forever $ do - isOver <- over - when isOver $ do - rotate spec - mapM_ sendSignal pids - threadDelay 10000000 - where - file = log_file spec - over = handle handler $ do - siz <- fromIntegral . fileSize <$> getFileStatus file - if siz > log_file_size spec then - return True - else - return False - sendSignal pid = signalProcess sigUSR1 pid `catch` ignore - handler :: SomeException -> IO Bool - handler _ = return False - ignore :: SomeException -> IO () - ignore _ = return () diff --git a/Log/Hput.hs b/Log/Hput.hs deleted file mode 100644 --- a/Log/Hput.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE DoAndIfThenElse, BangPatterns #-} -{-# LANGUAGE NoImplicitPrelude, RecordWildCards #-} - -module Log.Hput (hPutByteStrings) where - -import qualified Data.ByteString as BS -import Data.ByteString.Internal (ByteString(..), c2w) -import Data.List -import Foreign -import GHC.Base -import GHC.IO.Buffer -import qualified GHC.IO.BufferedIO as Buffered -import GHC.IO.Handle.Internals -import GHC.IO.Handle.Text -import GHC.IO.Handle.Types -import GHC.IORef -import GHC.Num -import GHC.Real -import Log.Types - -hPutByteStrings :: Handle -> [LogStr] -> IO () -hPutByteStrings handle bss = - wantWritableHandle "hPutByteStrings" handle $ \h_ -> bufsWrite h_ bss - -bufsWrite :: Handle__-> [LogStr] -> IO () -bufsWrite h_@Handle__{..} bss = do - old_buf@Buffer{ - bufRaw = old_raw - , bufR = w - , bufSize = size - } <- readIORef haByteBuffer - if size - w > len then do - withRawBuffer old_raw $ \ptr -> - go (ptr `plusPtr` w) bss - writeIORef haByteBuffer old_buf{ bufR = w + len } - else do - old_buf' <- Buffered.flushWriteBuffer haDevice old_buf - writeIORef haByteBuffer old_buf' - bufsWrite h_ bss - where - len = foldl' (\x y -> x + getLength y) 0 bss - getLength (LB s) = BS.length s - getLength (LS s) = length s - go :: Ptr Word8 -> [LogStr] -> IO () - go _ [] = return () - go dst (LB b:bs) = do - dst' <- copy dst b - go dst' bs - go dst (LS s:ss) = do - dst' <- copy' dst s - go dst' ss - -copy :: Ptr Word8 -> ByteString -> IO (Ptr Word8) -copy dst (PS ptr off len) = withForeignPtr ptr $ \s -> do - let src = s `plusPtr` off - memcpy dst src (fromIntegral len) - return (dst `plusPtr` len) - -copy' :: Ptr Word8 -> String -> IO (Ptr Word8) -copy' dst [] = return dst -copy' dst (x:xs) = do - poke dst (c2w x) - copy' (dst `plusPtr` 1) xs diff --git a/Log/Rotate.hs b/Log/Rotate.hs deleted file mode 100644 --- a/Log/Rotate.hs +++ /dev/null @@ -1,18 +0,0 @@ -module Log.Rotate where - -import Control.Monad -import System.Directory -import Log.Types - -rotate :: FileLogSpec -> IO () -rotate spec = mapM_ move srcdsts - where - path = log_file spec - n = log_backup_number spec - dsts' = reverse . ("":) . map (('.':). show) $ [0..n-1] - dsts = map (path++) dsts' - srcs = tail dsts - srcdsts = zip srcs dsts - move (src,dst) = do - exist <- doesFileExist src - when exist $ renameFile src dst diff --git a/Log/Stdout.hs b/Log/Stdout.hs deleted file mode 100644 --- a/Log/Stdout.hs +++ /dev/null @@ -1,19 +0,0 @@ -module Log.Stdout (stdoutLoggerInit) where - -import Control.Applicative -import qualified Data.ByteString as BS -import Data.ByteString.Char8 (pack) -import Log.Apache -import Log.Date -import Log.Types - -stdoutLoggerInit :: IO Logger -stdoutLoggerInit = stdoutLogger <$> dateInit - -stdoutLogger :: DateRef -> Logger -stdoutLogger dateref req status msiz = do - date <- getDate dateref - BS.putStr $ BS.concat $ map toBS $ apacheFormat date req status msiz - where - toBS (LS s) = pack s - toBS (LB s) = s diff --git a/Log/Types.hs b/Log/Types.hs deleted file mode 100644 --- a/Log/Types.hs +++ /dev/null @@ -1,23 +0,0 @@ -module Log.Types ( - Logger - , FileLogSpec(..) - , LogType(..) - , LogController - , LogStr(..) - ) where - -import Data.ByteString -import Network.Wai.Application.Classic (Logger) -import System.Posix (ProcessID) - -data FileLogSpec = FileLogSpec { - log_file :: String - , log_file_size :: Integer - , log_backup_number :: Int - } - -data LogType = LogNone | LogStdout | LogFile FileLogSpec - -type LogController = [ProcessID] -> IO () - -data LogStr = LS !String | LB !ByteString diff --git a/Mighty.hs b/Mighty.hs --- a/Mighty.hs +++ b/Mighty.hs @@ -9,10 +9,10 @@ import qualified Data.ByteString.Char8 as BS import FileCGIApp import FileCache -import Log import Network import Network.Wai.Application.Classic import Network.Wai.Handler.Warp +import Network.Wai.Logger.Prefork import Prelude hiding (catch) import Route import System.Environment @@ -86,7 +86,7 @@ where setting = defaultSettings { settingsPort = opt_port opt - , settingsOnException = ignore + , settingsOnException = printStdout , settingsTimeout = opt_connection_timeout opt } spec lgr getInfo = AppSpec { @@ -146,3 +146,6 @@ ignore :: SomeException -> IO () ignore = const $ return () + +printStdout :: SomeException -> IO () +printStdout e = print e diff --git a/Types.hs b/Types.hs --- a/Types.hs +++ b/Types.hs @@ -15,4 +15,4 @@ programName = "Mighttpd" programVersion :: String -programVersion = "2.3.0" +programVersion = "2.3.1" diff --git a/mighttpd2.cabal b/mighttpd2.cabal --- a/mighttpd2.cabal +++ b/mighttpd2.cabal @@ -1,5 +1,5 @@ Name: mighttpd2 -Version: 2.3.0 +Version: 2.3.1 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 @@ -21,20 +21,11 @@ warp, old-locale, time, wai-app-file-cgi, wai, transformers, http-types, directory, filepath, - haskell98, http-date, hashmap + haskell98, http-date, hashmap, deepseq, wai-logger Other-Modules: Config Config.Internal FileCGIApp FileCache - Log - Log.Apache - Log.Check - Log.Date - Log.File - Log.Hput - Log.Rotate - Log.Stdout - Log.Types Mighty Parser Route