mighttpd (empty) → 0.1.0

raw patch · 11 files changed

+606/−0 lines, 11 filesdep +basedep +bytestringdep +c10ksetup-changed

Dependencies added: base, bytestring, c10k, directory, filepath, haskell98, hdaemonize, hslogger, network, parsec, time, unix, webserver

Files

• Config.hs +124/−0
• File.hs +83/−0
• LICENSE +29/−0
• LogMsg.hs +87/−0
• Mighttpd.hs +83/−0
• Setup.hs +2/−0
• URLMap.hs +59/−0
• mighttpd.cabal +25/−0
• mkindex.hs +95/−0
• sample.conf +11/−0
• sample.map +8/−0

@@ -0,0 +1,124 @@+{-# LANGUAGE TypeSynonymInstances #-}++module Config (Option(..), parseOption, defaultOption) where++import Text.ParserCombinators.Parsec+import Data.List (isPrefixOf)++----------------------------------------------------------------++defaultOption :: Option+defaultOption = Option {+    opt_port = 8080+  , opt_prefork_process_number = 20+  , opt_thread_number_per_process = 500+  , opt_connection_timer = 10+  , opt_sleep_timer = 2+  , opt_debug_mode = True+  , opt_user = "nobody"+  , opt_group = "nobody"+  , opt_syslog_facility = "local5"+  , opt_log_level = "info"+  , opt_pid_file = "/var/run/pbws.pid"+}++data Option = Option {+    opt_port :: Int+  , opt_prefork_process_number :: Int+  , opt_thread_number_per_process :: Int+  , opt_connection_timer :: Int+  , opt_sleep_timer :: Int+  , opt_debug_mode :: Bool+  , opt_user :: String+  , opt_group :: String+  , opt_syslog_facility :: String+  , opt_log_level :: String+  , opt_pid_file :: String+} deriving Show++----------------------------------------------------------------++parseOption :: String -> Option+parseOption = makeOpt defaultOption . parseConfig++----------------------------------------------------------------++makeOpt :: Option -> [Conf] -> Option+makeOpt def conf = Option {+    opt_port = get "Port" opt_port+  , opt_prefork_process_number = get "Prefork_Process_Number" opt_prefork_process_number+  , opt_thread_number_per_process = get "Thread_Number_Per_Process" opt_thread_number_per_process+  , opt_connection_timer = get "Connection_Timer" opt_connection_timer+  , opt_sleep_timer      = get "Sleep_Timer" opt_sleep_timer+  , opt_debug_mode       = get "Debug_Mode" opt_debug_mode+  , opt_user             = get "User" opt_user+  , opt_group            = get "Group" opt_group+  , opt_syslog_facility  = get "Syslog_Facility" opt_syslog_facility+  , opt_log_level        = get "Log_Level" opt_log_level+  , opt_pid_file         = get "Pid_File" opt_pid_file+  }+    where+      get key func = case lookup key conf of+                       Nothing -> func def+                       Just x  -> fromConf x++----------------------------------------------------------------++type Conf = (String, ConfValue)++data ConfValue = CV_Int Int | CV_Bool Bool | CV_String String deriving 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 :: String -> [Conf]+parseConfig cs = let css = filter (not.isPrefixOf "#") $ lines cs+                 in map parseConf css+    where+      parseConf xs = case parse config "config" xs of+                       Right cnf -> cnf+                       Left  err -> error $ "parseConfig " ++ show err++----------------------------------------------------------------++config :: Parser Conf+config = do nm <- name+            spaces+            char ':'+            spaces+            vl <- value+            return (nm,vl)++name :: Parser String+name = many1.oneOf $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_"++value :: Parser ConfValue+value = choice [try cv_int, try cv_bool, cv_string]++cv_int :: Parser ConfValue+cv_int = do ns <- many1 digit+            spaces+            eof+            return $ CV_Int $ read ns++cv_bool :: Parser ConfValue+cv_bool = do { string "Yes"; spaces; eof; return (CV_Bool True)  } <|>+          do { string "No";  spaces; eof; return (CV_Bool False) }++cv_string :: Parser ConfValue+cv_string = do ss <- many1 (noneOf " \t\n")+               return $ CV_String ss

@@ -0,0 +1,83 @@+module File (mighty, progName) where++import Control.Applicative+import Data.ByteString.Lazy.Char8 (ByteString)+import qualified Data.ByteString.Lazy.Char8 as LBS+import Data.List+import Data.Time+import Data.Time.Clock.POSIX+import IO+import Network.TCPInfo+import Network.URI+import Network.Web.Server+import Network.Web.Server.Basic+import Network.Web.Utils+import System.Directory+import System.FilePath+import System.Posix.Files+import URLMap++progName :: String+progName = "Mighttpd"++progVersion :: String+progVersion = "0.1.0"++progNameVersion :: String+progNameVersion = progName ++ " " ++ progVersion++----------------------------------------------------------------++mighty :: WebConfig -> URLMap -> Handle -> TCPInfo -> IO ()+mighty wcnf umap hdl tcpinfo = do+  let bcnf = BasicConfig { obtain = fileGet+                         , info   = fileInfo+                         , mapper = fileMapper umap+                         , serverName = progNameVersion+                         , tcpInfo = tcpinfo+                         }+  connection hdl (basicServer bcnf) wcnf++----------------------------------------------------------------++lookupFileMap :: URLMap -> URL -> Path+lookupFileMap [] _          = None+lookupFileMap ((from,to):xs) url+    | from `isPrefixOf` url = toPath to $ drop (length from) url+    | otherwise             = lookupFileMap xs url+  where+    toPath (File dir) restPath = File $ dir </> restPath+    toPath (CGI dir _ urlPath) progParam = CGI prog param scriptName+      where+        (prog',param) = break (\x -> x == '?' || x == '/') progParam+        prog = dir </> prog'+        scriptName = urlPath </> prog'+    toPath _ _ = error "toPath"++fileMapper :: URLMap -> URI -> Path+fileMapper umap uri = fileMapper' (lookupFileMap umap url)+  where+    url = unEscapeString $ toURLwoPort uri+    fileMapper' None                  = None+    fileMapper' cgi@(CGI _ _ _)       = cgi+    fileMapper' (File file)+      | hasTrailingPathSeparator file = File $ file </> "index.html"+      | otherwise                     = File file++fileGet :: FilePath -> Maybe (Integer,Integer) -> IO ByteString+fileGet file Nothing = openFile file ReadMode >>= LBS.hGetContents+fileGet file (Just (skip,len)) = do+    h <- openFile file ReadMode+    hSeek h AbsoluteSeek skip+    LBS.take (fromIntegral len) <$> LBS.hGetContents h++fileInfo :: FilePath -> IO (Maybe (Integer, UTCTime))+fileInfo file = do+    exist <- doesFileExist file+    if exist+       then do+         fs <- getFileStatus file+         let size = fromIntegral . fileSize $ fs+             mtime = posixSecondsToUTCTime . realToFrac . modificationTime $ fs+         return $ Just (size, mtime)+       else return Nothing

@@ -0,0 +1,29 @@+Copyright (c) 2009, 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,87 @@+module LogMsg (initLog,+               FacilityString, LevelString, LogSystem(..),+               errorMsg, warnMsg, noticeMsg,+               infoMsg, debugMsg) where++import Data.Maybe+import System.Log.Logger+import System.Log.Handler.Syslog++errorMsg :: String -> IO ()+errorMsg = errorM rootLoggerName++warnMsg :: String -> IO ()+warnMsg = warningM rootLoggerName++noticeMsg :: String -> IO ()+noticeMsg = noticeM rootLoggerName++infoMsg :: String -> IO ()+infoMsg = infoM rootLoggerName++debugMsg :: String -> IO ()+debugMsg = debugM rootLoggerName++type FacilityString = String+type LevelString = String++data LogSystem = StdErr | SysLog++initLog :: String+        -> FacilityString+        -> LevelString+        -> LogSystem+        -> IO ()++initLog name fcl lvl SysLog = do+    let level = toLevel lvl+        facility = toFacility fcl+    s <- openlog name [PID] facility level+    updateGlobalLogger rootLoggerName (setLevel level . setHandlers [s])+initLog _ _ lvl StdErr = do+    let level = toLevel lvl+    updateGlobalLogger rootLoggerName (setLevel level)++toLevel :: String -> Priority+toLevel str = maybe (error ("Unknown level " ++ show str))+                     id (lookup str levelDB)++toFacility :: String -> Facility+toFacility str = maybe (error ("Unknown facility " ++ show str))+                        id (lookup str facilityDB)++levelDB :: [(String, Priority)]+levelDB = [+    ("debug",DEBUG)+  , ("info",INFO)+  , ("notice",NOTICE)+  , ("warning",WARNING)+  , ("error",ERROR)+  , ("critical",CRITICAL)+  , ("alert",ALERT)+  , ("emergency",EMERGENCY)+  ]++facilityDB :: [(String, Facility)]+facilityDB = [+    ("kern",KERN)+  , ("use",USER)+  , ("mail",MAIL)+  , ("daemon",DAEMON)+  , ("auth",AUTH)+  , ("syslog",SYSLOG)+  , ("lpr",LPR)+  , ("news",NEWS)+  , ("uucp",UUCP)+  , ("cron",CRON)+  , ("authpriv",AUTHPRIV)+  , ("ftp",FTP)+  , ("local0",LOCAL0)+  , ("local1",LOCAL1)+  , ("local2",LOCAL2)+  , ("local3",LOCAL3)+  , ("local4",LOCAL4)+  , ("local5",LOCAL5)+  , ("local6",LOCAL6)+  , ("local7",LOCAL7)+  ]

@@ -0,0 +1,83 @@+{-# LANGUAGE BangPatterns#-}++module Main where++import Config+import Control.Monad+import File+import IO+import LogMsg+import Network.C10kServer+import Network.Web.Server+import System.Environment+import System.Exit+import System.Posix.Daemonize+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 runC10kServer prog c10kConfig+       else daemonize $ runC10kServer prog c10kConfig+  where+    fileName n = do+        args <- getArgs+        when (length args /= 2) $ do+            hPutStrLn stderr "Usage: pbws 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+  , pidFile = opt_pid_file opt+  , user = opt_user opt+  , group = opt_group opt+}++makeInitHook :: Option -> IO ()+makeInitHook opt =+  if opt_debug_mode opt == True+  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 =+  if opt_debug_mode opt == True+  then do+    initLog progName "" (opt_log_level opt) StdErr+  else do+    initLog progName (opt_syslog_facility opt) (opt_log_level opt) SysLog

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

@@ -0,0 +1,59 @@+module URLMap (parseURLMap, URL, URLMap) where++import Control.Applicative ((<$>),(<$),(<*),(<*>),(*>),pure)+import Network.URI+import Network.Web.Server.Basic+import Text.Parsec+import Text.Parsec.String++type URL = String+type URLMap = [(URL,Path)]++parseURLMap :: String -> URLMap+parseURLMap cs = either (fail . show) (map fixCGI) (parse umap "umap" cs)+  where+    fixCGI (k, CGI prog param _) = (k, CGI prog param (scriptDir k))+    fixCGI x                     = x+    scriptDir x = maybe "" uriPath (parseURI x)++umap :: Parser [(URL,Path)]+umap =  comments *> many (line <* comments)++comments :: Parser ()+comments = () <$ many comment++comment :: Parser ()+comment = () <$ char '#' >> many (noneOf "\n") >> eol++line :: Parser (URL,Path)+line = (,) <$> uri <*> (fileOrCGI <* eol)++uri :: Parser URL+uri = spcs *> (str <* spcs)++fileOrCGI :: Parser Path+fileOrCGI = file <|> cgi++file :: Parser Path+file = File <$> (arrow *> dir)++cgi :: Parser Path+cgi = CGI <$> (darrow *> dir) <*> pure "" <*> pure ""++arrow :: Parser ()+arrow = () <$ string "->" >> spcs++darrow :: Parser ()+darrow = () <$ string "=>" >> spcs++dir :: Parser FilePath+dir =  str <* spcs++str :: Parser String+str = many1 (noneOf " \t\n")++eol :: Parser ()+eol = () <$ char '\n'++spcs :: Parser ()+spcs = () <$ many (oneOf " \t")

@@ -0,0 +1,25 @@+Name:                   mighttpd+Version:                0.1.0+Author:                 Kazu Yamamoto <kazu@iij.ad.jp>+Maintainer:             Kazu Yamamoto <kazu@iij.ad.jp>+License:                BSD3+License-File:           LICENSE+Synopsis:               Simple Web Server in Haskell+Description:            A simple but practical HTTP server in Haskell.+                        'mighttpd' should be called 'mighty'.+Homepage:               http://www.mew.org/~kazu/proj/mighttpd/+Category:               Network+Cabal-Version:          >= 1.6+Build-Type:             Simple+Extra-Source-Files:     Config.hs, LogMsg.hs, Setup.hs, File.hs, URLMap.hs+Data-Files:             sample.conf, sample.map+Executable mighttpd+    Main-Is:            Mighttpd.hs+    GHC-Options:        -Wall -O2+    Build-Depends:      base >= 4 && < 10, parsec >= 3,+                        c10k, hslogger, webserver, bytestring, filepath,+                        haskell98, hdaemonize, directory, unix, time, network+Executable mkindex+    Main-Is:            mkindex.hs+    GHC-Options:        -Wall -O2+    Build-Depends:      base >= 4

@@ -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 [' ','K','M','G','T']+    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"

@@ -0,0 +1,11 @@+Port: 80+Prefork_Process_Number: 20+Thread_Number_Per_Process: 300+Connection_Timer: 10+Sleep_Timer: 2+Debug_Mode: No+User: nobody+Group: nobody+Syslog_Facility: local6+Log_Level: info+Pid_File: /tmp/mighttpd.pid

@@ -0,0 +1,8 @@+# CGI directory mapping+http://example.org/ja/cgi-bin/ => /export/www/cgi-bin/+http://example.org/mailman/    => /usr/local/mailman/cgi-bin/+# Directory mapping+http://example.org/pipermail/  -> /usr/local/mailman/archives/public/+http://example.org/icons/      -> /usr/local/mailman/icons/+http://example.org/~user/      -> /home/user/public_html/+http://example.org/            -> /export/www/