Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

initial import.

  • Loading branch information...
commit e8d19c518f00da363fde2019a75b05c651d8537a 0 parents
@kazu-yamamoto kazu-yamamoto authored
1  .gitignore
@@ -0,0 +1 @@
+dist/
124 Config.hs
@@ -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
83 File.hs
@@ -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
29 LICENSE
@@ -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.
87 LogMsg.hs
@@ -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)
+ ]
83 Mighttpd.hs
@@ -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
2  Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
59 URLMap.hs
@@ -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")
24 mighttpd.cabal
@@ -0,0 +1,24 @@
+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: Netowrk
+Cabal-Version: >= 1.2
+Build-Type: Simple
+Executable mighttpd
+ Main-Is: Mighttpd.hs
+ GHC-Options: -Wall -O2
+ Build-Depends: base >= 4,
+ 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
95 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 [' ','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"
11 sample.conf
@@ -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
8 sample.map
@@ -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/
Please sign in to comment.
Something went wrong with that request. Please try again.