diff --git a/Config.hs b/Config.hs new file mode 100644 --- /dev/null +++ b/Config.hs @@ -0,0 +1,3 @@ +module Config (Option(..), parseOption, defaultOption) where + +import Config.Internal diff --git a/Config/Internal.hs b/Config/Internal.hs new file mode 100644 --- /dev/null +++ b/Config/Internal.hs @@ -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") diff --git a/FileCGIApp.hs b/FileCGIApp.hs new file mode 100644 --- /dev/null +++ b/FileCGIApp.hs @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Log.hs b/Log.hs new file mode 100644 --- /dev/null +++ b/Log.hs @@ -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" + ] diff --git a/Mighty.hs b/Mighty.hs new file mode 100644 --- /dev/null +++ b/Mighty.hs @@ -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 diff --git a/Parser.hs b/Parser.hs new file mode 100644 --- /dev/null +++ b/Parser.hs @@ -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 diff --git a/Route.hs b/Route.hs new file mode 100644 --- /dev/null +++ b/Route.hs @@ -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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Types.hs b/Types.hs new file mode 100644 --- /dev/null +++ b/Types.hs @@ -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" diff --git a/mighttpd2.cabal b/mighttpd2.cabal new file mode 100644 --- /dev/null +++ b/mighttpd2.cabal @@ -0,0 +1,43 @@ +Name: mighttpd2 +Version: 2.0.0 +Author: Kazu Yamamoto +Maintainer: Kazu Yamamoto +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 diff --git a/mkindex.hs b/mkindex.hs new file mode 100644 --- /dev/null +++ b/mkindex.hs @@ -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 = "\ +\\n\ +\\n\ +\\n\ +\\n\ +\Directory contents\n\ +\\n\ +\

Directory contents

\n\ +\
\n\ +\
\n"
+
+content :: Int -> (String,String,String,Int) -> String
+content lim (f,m,s,len) = "" ++ f ++ "  " ++ replicate (lim - len) ' ' ++ m ++ "  " ++ s ++ "\n"
+
+tailer :: String
+tailer = "\
+\
\n\ +\
\n\ +\\n\ +\\n"