mighttpd2 (empty) → 2.0.0

raw patch · 12 files changed

+653/−0 lines, 12 filesdep +basedep +bytestringdep +directorysetup-changed

Dependencies added: base, bytestring, directory, filepath, haskell98, network, old-locale, parsec, time, transformers, unix, wai, wai-app-file-cgi, warp

Files

• Config.hs +3/−0
• Config/Internal.hs +122/−0
• FileCGIApp.hs +32/−0
• LICENSE +29/−0
• Log.hs +128/−0
• Mighty.hs +105/−0
• Parser.hs +36/−0
• Route.hs +40/−0
• Setup.hs +2/−0
• Types.hs +18/−0
• mighttpd2.cabal +43/−0
• mkindex.hs +95/−0

@@ -0,0 +1,3 @@+module Config (Option(..), parseOption, defaultOption) where++import Config.Internal

@@ -0,0 +1,122 @@+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, OverloadedStrings #-}++module Config.Internal where++import Control.Applicative hiding (many,optional,(<|>))+import Parser+import Text.Parsec+import Text.Parsec.ByteString.Lazy+import Types++----------------------------------------------------------------++defaultOption :: Option+defaultOption = Option {+    opt_port = 8080+  , opt_debug_mode = True+  , opt_user = "nobody"+  , opt_group = "nobody"+  , opt_pid_file = "/var/run/mighty.pid"+  , opt_log_file = "/var/log/mighty"+  , opt_log_file_size = 16777216+  , opt_log_backup_number = 10+  , opt_log_buffer_size = 16384+  , opt_log_flush_period = 10+  , opt_index_file = "index.html"+  , opt_server_name = programName ++ "/" ++ programVersion+}++data Option = Option {+    opt_port :: !Int+  , opt_debug_mode :: !Bool+  , opt_user :: !String+  , opt_group :: !String+  , opt_pid_file :: !String+  , opt_log_file :: !String+  , opt_log_file_size :: !Int+  , opt_log_backup_number :: !Int+  , opt_log_buffer_size :: !Int+  , opt_log_flush_period :: !Int+  , opt_index_file :: !String+  , opt_server_name :: !String+} deriving (Eq,Show)++----------------------------------------------------------------++parseOption :: String -> IO Option+parseOption file = makeOpt defaultOption <$> parseConfig file++----------------------------------------------------------------++makeOpt :: Option -> [Conf] -> Option+makeOpt def conf = Option {+    opt_port              = get "Port" opt_port+  , opt_debug_mode        = get "Debug_Mode" opt_debug_mode+  , opt_user              = get "User" opt_user+  , opt_group             = get "Group" opt_group+  , opt_pid_file          = get "Pid_File" opt_pid_file+  , opt_log_file          = get "Log_File" opt_log_file+  , opt_log_file_size     = get "Log_File_Size" opt_log_file_size+  , opt_log_backup_number = get "Log_Backup_Number" opt_log_backup_number+  , opt_log_buffer_size   = get "Log_Buffer_Size" opt_log_buffer_size+  , opt_log_flush_period  = get "Log_Flush_Period" opt_log_flush_period+  , opt_index_file        = get "Index_File" opt_index_file+  , opt_server_name       = get "Server_Name" opt_server_name+  }+  where+    get k func = maybe (func def) fromConf $ lookup k conf++----------------------------------------------------------------++type Conf = (String, ConfValue)++data ConfValue = CV_Int Int | CV_Bool Bool | CV_String String deriving (Eq,Show)++class FromConf a where+    fromConf :: ConfValue -> a++instance FromConf Int where+    fromConf (CV_Int n) = n+    fromConf _ = error "fromConf int"++instance FromConf Bool where+    fromConf (CV_Bool b) = b+    fromConf _ = error "fromConf bool"++instance FromConf String where+    fromConf (CV_String s) = s+    fromConf _ = error "fromConf string"++----------------------------------------------------------------++parseConfig :: FilePath -> IO [Conf]+parseConfig = parseFile config++----------------------------------------------------------------++config :: Parser [Conf]+config = commentLines *> many cfield <* eof+  where+    cfield = field <* commentLines++field :: Parser Conf+field = (,) <$> key <*> (sep *> value) <* trailing++key :: Parser String+key = many1 (oneOf $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_") <* spcs++sep :: Parser ()+sep = () <$ char ':' *> spcs++value :: Parser ConfValue+value = choice [try cv_int, try cv_bool, cv_string] <* spcs++cv_int :: Parser ConfValue+cv_int = CV_Int . read <$> (many1 digit)++cv_bool :: Parser ConfValue+cv_bool = CV_Bool True  <$ (string "Yes") <|>+          CV_Bool False <$ (string "No")++cv_string :: Parser ConfValue+cv_string = CV_String <$> many1 (noneOf " \t\n")

@@ -0,0 +1,32 @@+{-# LANGUAGE OverloadedStrings #-}++module FileCGIApp (fileCgiApp) where++import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS+import Network.Wai+import Network.Wai.Application.Classic+import Types++fileCgiApp :: AppSpec -> RouteDB -> Application+fileCgiApp spec um req = case mmp of+    Nothing -> return $ responseLBS statusNotFound+                                    [("Content-Type", "text/plain")]+                                    "Not found"+    Just (Route src op dst) -> case op of+        OpFile -> fileApp spec (FileRoute src dst) req+        OpCGI  -> cgiApp  spec (CgiRoute  src dst) req+  where+    mmp = getBlock (serverName req) um >>= getRoute (pathInfo req)++getBlock :: ByteString -> RouteDB -> Maybe [Route]+getBlock _ [] = Nothing+getBlock key (Block doms maps : ms)+  | key `elem` doms = Just maps+  | otherwise       = getBlock key ms++getRoute :: ByteString -> [Route] -> Maybe Route+getRoute _ [] = Nothing+getRoute key (m@(Route src _ _):ms)+  | src `BS.isPrefixOf` key = Just m+  | otherwise               = getRoute key ms

@@ -0,0 +1,29 @@+Copyright (c) 2011, IIJ Innovation Institute Inc.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++  * Redistributions of source code must retain the above copyright+    notice, this list of conditions and the following disclaimer.+  * Redistributions in binary form must reproduce the above copyright+    notice, this list of conditions and the following disclaimer in+    the documentation and/or other materials provided with the+    distribution.+  * Neither the name of the copyright holders nor the names of its+    contributors may be used to endorse or promote products derived+    from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS+FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE+COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,+BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,128 @@+{-# LANGUAGE OverloadedStrings #-}++module Log where++import Control.Concurrent+import Control.Monad+import qualified Data.ByteString.Char8 as BS+import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy.Char8 as BL+import Data.Time+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++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"+  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+    return chan++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++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)+    return hdl+  where+    file = log_file spec++locate :: FileLogSpec -> IO ()+locate spec = mapM_ move srcdsts+  where+    path = log_file spec+    n = log_backup_number spec+    dsts' = reverse . ("":) . map ('.':) . 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++----------------------------------------------------------------++setoutInit :: IO (Chan ByteString)+setoutInit = do+    chan <- newChan+    forkIO $ stdoutSerializer chan+    return chan++stdoutSerializer :: Chan ByteString -> IO ()+stdoutSerializer chan = forever $ readChan chan >>= BL.putStr++----------------------------------------------------------------++mightyLogger :: Chan ByteString -> Request -> Status -> IO ()+mightyLogger chan req st = do+    zt <- getZonedTime+    addr <- getPeerAddr (remoteHost req)+    writeChan chan $ BL.fromChunks (logmsg addr zt)+  where+    logmsg addr zt = [+        BS.pack addr+      , " - - ["+      , BS.pack (formatTime defaultTimeLocale "%d/%b/%Y:%T %z" zt)+      , "] \""+      , requestMethod req+      , " "+      , pathInfo req+      , "\" "+      , BS.pack (show . statusCode $ st)+      , " - \"" -- size+      , lookupRequestField' fkReferer req+      , "\" \""+      , lookupRequestField' fkUserAgent req+      , "\"\n"+      ]

@@ -0,0 +1,105 @@+module Main where++import Config+import Control.Exception (catch, SomeException)+import Control.Monad+import qualified Data.ByteString.Char8 as BS+import Data.List (isSuffixOf)+import FileCGIApp+import Log+import Network+import Network.Wai.Application.Classic+import Network.Wai.Handler.Warp+import Prelude hiding (catch)+import Route+import System.Environment+import System.Exit+import System.IO+import System.Posix+import Types++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+  where+    fileName n = do+        args <- getArgs+        when (length args /= 2) $ do+            hPutStrLn stderr "Usage: mighty config_file routing_file"+            exitFailure+        return $ args !! n++server :: Option -> RouteDB -> IO ()+server opt route = flip catch handle $ do+    s <- sOpen+    installHandler sigCHLD Ignore Nothing+    unless debug writePidFile+    setGroupUser opt+    chan <- if debug then setoutInit else fileInit logspec+    serveConnections ignore port (fileCgiApp (spec chan) route) s+  where+    debug = opt_debug_mode opt+    port = opt_port opt+    ignore = const $ return ()+    sOpen = listenOn (PortNumber . fromIntegral $ port)+    spec chan = AppSpec {+        softwareName = BS.pack $ opt_server_name opt+      , indexFile = opt_index_file opt+      , isHTML = \x -> ".html" `isSuffixOf` x || ".htm" `isSuffixOf` x+      , logger = mightyLogger chan+      }+    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+      }+{-+    warpspec = defaultSettings {+        settingsPort = opt_port opt+      , settingsOnException = ignore+      , settingsTimeout = 30+      }+-}+    pidfile = opt_pid_file opt+    writePidFile = do+        pid <- getProcessID+        writeFile pidfile $ show pid ++ "\n"+        setFileMode pidfile 0o644+    handle :: SomeException -> IO ()+    handle e+      | debug = hPutStrLn stderr $ show e+      | otherwise = writeFile "/tmp/mighty_error" (show e)++----------------------------------------------------------------++setGroupUser :: Option -> IO ()+setGroupUser opt = do+    uid <- getRealUserID+    when (uid == 0) $ do+        getGroupEntryForName (opt_group opt) >>= setGroupID . groupID+        getUserEntryForName (opt_user opt) >>= setUserID . userID++----------------------------------------------------------------++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

@@ -0,0 +1,36 @@+module Parser where++import Control.Applicative hiding (many,(<|>))+import qualified Data.ByteString.Lazy.Char8 as BL+import System.IO+import Text.Parsec+import Text.Parsec.ByteString.Lazy++spcs :: Parser ()+spcs = () <$ many spc++spcs1 :: Parser ()+spcs1 = () <$ many1 spc++spc :: Parser Char+spc = satisfy (\c -> c == ' ' || c == '\t')++commentLines :: Parser ()+commentLines = () <$ many commentLine+  where+    commentLine = trailing++trailing :: Parser ()+trailing = () <$ (comment *> newline <|> newline)++comment :: Parser ()+comment = () <$ char '#' <* many (noneOf "\n")++parseFile :: Parser a -> FilePath -> IO a+parseFile p file = do+    hdl <- openFile file ReadMode+    hSetEncoding hdl latin1+    bs <- BL.hGetContents hdl+    case parse p "parseFile" bs of+        Right x -> return x+        Left  e -> error . show $ e

@@ -0,0 +1,40 @@+{-# LANGUAGE OverloadedStrings #-}++module Route (parseRoute) where++import Control.Applicative hiding (many,(<|>))+import qualified Data.ByteString.Char8 as BS+import Parser+import Text.Parsec+import Text.Parsec.ByteString.Lazy+import Types++parseRoute :: FilePath -> IO RouteDB+parseRoute = parseFile routeDB++routeDB :: Parser RouteDB+routeDB = commentLines *> many1 block <* eof++block :: Parser Block+block = Block <$> cdomains <*> many croute+  where+    cdomains = domains <* commentLines+    croute   = route   <* commentLines++domains :: Parser [Domain]+domains = open *> doms <* close <* trailing+  where+    open  = () <$ char '[' *> spcs+    close = () <$ char ']' *> spcs+    doms = (domain `sepBy1` sep) <* spcs+    domain = BS.pack <$> many1 (noneOf "[], \t\n")+    sep = () <$ spcs1++route :: Parser Route+route = Route <$> src <*> op <*> dst <* trailing+  where+    path = many1 (noneOf "[], \t\n")+    src = BS.pack <$> path <* spcs+    dst = path <* spcs+    op0 = OpFile <$ string "->" <|> OpCGI <$ string "=>"+    op  = op0 <* spcs

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,18 @@+module Types where++import Data.ByteString++type Src      = ByteString+type Dst      = FilePath+type Domain   = ByteString+type PathInfo = ByteString+data Block    = Block [Domain] [Route] deriving (Eq,Show)+data Route    = Route Src Op Dst deriving (Eq,Show)+data Op       = OpFile | OpCGI deriving (Eq,Show)+type RouteDB  = [Block]++programName :: String+programName = "Mighttpd"++programVersion :: String+programVersion = "2.0.0"

@@ -0,0 +1,43 @@+Name:                   mighttpd2+Version:                2.0.0+Author:                 Kazu Yamamoto <kazu@iij.ad.jp>+Maintainer:             Kazu Yamamoto <kazu@iij.ad.jp>+License:                BSD3+License-File:           LICENSE+Synopsis:               A classical web server on WAI/warp+Description:            A classical web server on WAI/warp.+                        Static files and CGI can be handled.+Homepage:               http://www.mew.org/~kazu/proj/mighttpd/+Category:               Distribution+Cabal-Version:          >= 1.6+Build-Type:             Simple+Executable mighty+  Main-Is:              Mighty.hs+  if impl(ghc >= 6.12)+    GHC-Options:        -Wall -fno-warn-unused-do-bind+  else+    GHC-Options:        -Wall+  Build-Depends:        base >= 4.0 && < 5, parsec >= 3,+                        network >=2.2 && <2.3,+                        unix, bytestring, warp, old-locale, time,+                        wai-app-file-cgi, wai, transformers,+                        directory, filepath,+                        haskell98+  Other-Modules:	Config+                        Config.Internal+                        FileCGIApp+                        Log+                        Mighty+                        Parser+                        Route+                        Types+Executable mkindex+  Main-Is:              mkindex.hs+  if impl(ghc >= 6.12)+    GHC-Options:        -Wall -fno-warn-unused-do-bind+  else+    GHC-Options:        -Wall+  Build-Depends:        base >= 4 && < 5+Source-Repository head+  Type:                 git+  Location:             git://github.com/kazu-yamamoto/mighttpd2.git

@@ -0,0 +1,95 @@+{-+  mkindex :: Making index.html for the current directory.+-}+import Control.Applicative+import Data.Time+import Data.Time.Clock.POSIX+import Locale+import System.Directory+import System.Posix.Files+import Text.Printf+import Data.Bits++indexFile :: String+indexFile = "index.html"++main :: IO ()+main = do+    contents <- mkContents+    writeFile indexFile $ header ++ contents ++ tailer+    setFileMode indexFile mode+  where+    mode = ownerReadMode .|. ownerWriteMode .|. groupReadMode .|. otherReadMode++mkContents :: IO String+mkContents = do+    fileNames <- filter dotAndIndex <$> getDirectoryContents "."+    stats <- mapM getFileStatus fileNames+    let fmsls = map pp $ zip fileNames stats+        maxLen = maximum $ map (\(_,_,_,x) -> x) fmsls+        contents = concatMap (content maxLen) fmsls+    return contents+  where+    dotAndIndex x = head x /= '.' && x /= indexFile++pp :: (String,FileStatus) -> (String,String,String,Int)+pp (f,st) = (file,mtime,size,flen)+  where+    file = ppFile f st+    flen = length file+    mtime = ppMtime st+    size = ppSize st++ppFile :: String -> FileStatus -> String+ppFile f st+  | isDirectory st = f ++ "/"+  | otherwise      = f++ppMtime :: FileStatus -> String+ppMtime st = dateFormat . epochTimeToUTCTime $ st+  where+    epochTimeToUTCTime = posixSecondsToUTCTime . realToFrac . modificationTime+    dateFormat = formatTime defaultTimeLocale "%d-%b-%Y %H:%M"++ppSize :: FileStatus -> String+ppSize st+  | isDirectory st = "  - "+  | otherwise      = sizeFormat . fromIntegral . fileSize $ st+  where+    sizeFormat siz = unit siz " KMGT"+    unit _ []  = undefined+    unit s [u] = format s u+    unit s (u:us)+      | s >= 1024 = unit (s `div` 1024) us+      | otherwise = format s u+    format :: Integer -> Char -> String+    format = printf "%3d%c"++header :: String+header = "\+\<html>\n\+\<head>\n\+\<style type=\"text/css\">\n\+\<!--\n\+\body { padding-left: 10%; }\n\+\h1 { font-size: x-large; }\n\+\pre { font-size: large; }\n\+\hr { text-align: left; margin-left: 0px; width: 80% }\n\+\-->\n\+\</style>\n\+\</head>\n\+\<title>Directory contents</title>\n\+\<body>\n\+\<h1>Directory contents</h1>\n\+\<hr>\n\+\<pre>\n"++content :: Int -> (String,String,String,Int) -> String+content lim (f,m,s,len) = "<a href=\"" ++ f ++ "\">" ++ f ++ "</a>  " ++ replicate (lim - len) ' ' ++ m ++ "  " ++ s ++ "\n"++tailer :: String+tailer = "\+\</pre>\n\+\<hr>\n\+\</body>\n\+\</html>\n"