Permalink
Browse files

initial import.

  • Loading branch information...
0 parents commit e8d19c518f00da363fde2019a75b05c651d8537a @kazu-yamamoto kazu-yamamoto committed Mar 8, 2010
Showing with 606 additions and 0 deletions.
  1. +1 −0 .gitignore
  2. +124 −0 Config.hs
  3. +83 −0 File.hs
  4. +29 −0 LICENSE
  5. +87 −0 LogMsg.hs
  6. +83 −0 Mighttpd.hs
  7. +2 −0 Setup.hs
  8. +59 −0 URLMap.hs
  9. +24 −0 mighttpd.cabal
  10. +95 −0 mkindex.hs
  11. +11 −0 sample.conf
  12. +8 −0 sample.map
@@ -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.
@@ -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)
+ ]
Oops, something went wrong.

0 comments on commit e8d19c5

Please sign in to comment.