mighttpd2-2.5.9/0000755000000000000000000000000011745162726011632 5ustar0000000000000000mighttpd2-2.5.9/Config.hs0000644000000000000000000000012511745162726013371 0ustar0000000000000000module Config (Option(..), parseOption, defaultOption) where import Config.Internal mighttpd2-2.5.9/example.conf0000644000000000000000000000070711745162726014140 0ustar0000000000000000# Example configuration for Mighttpd 2 Port: 80 Debug_Mode: Yes # Yes or No User: nobody Group: nobody Pid_File: /var/run/mighty.pid Logging: Yes # Yes or No Log_File: /var/log/mighty # The directory must be writable by User: Log_File_Size: 16777216 # bytes Log_Backup_Number: 10 Index_File: index.html Index_Cgi: index.cgi Status_File_Dir: /usr/local/share/mighty/status Connection_Timeout: 30 # seconds # Server_Name: Mighttpd/2.x.y Worker_Processes: 1 mighttpd2-2.5.9/example.route0000644000000000000000000000125311745162726014346 0ustar0000000000000000# Example routing for Mighttpd 2 # Domain lists [localhost www.example.com] # Entries are looked up in the specified order # All paths must end with "/" # A path to CGI scripts should be specified with "=>" /~alice/cgi-bin/ => /home/alice/public_html/cgi-bin/ # A path to static files should be specified with "->" /~alice/ -> /home/alice/public_html/ /cgi-bin/ => /export/cgi-bin/ # Reverse proxy rules should be specified with ">>" # /path >> host:port/path2 # Either "host" or ":port" can be committed, but not both. /app/cal/ >> example.net/calendar/ # Yesod app in the same server /app/wiki/ >> 127.0.0.1:3000/ / -> /export/www/ mighttpd2-2.5.9/FileCache.hs0000644000000000000000000000373211745162726013776 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} module FileCache (fileCacheInit) where import Control.Concurrent import Control.Exception import Control.Monad import Data.ByteString (ByteString) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as M import Data.IORef import Network.HTTP.Date import Network.Wai.Application.Classic import System.IO.Unsafe import System.Posix.Files data Entry = Negative | Positive FileInfo type Cache = HashMap ByteString Entry type GetInfo = Path -> IO FileInfo fileInfo :: IORef Cache -> GetInfo fileInfo ref path = do !mx <- atomicModifyIORef ref (lok path) case mx of Nothing -> throwIO (userError "fileInfo") Just x -> return x lok :: Path -> Cache -> (Cache, Maybe FileInfo) lok path cache = unsafePerformIO $ do let ment = M.lookup bpath cache case ment of Nothing -> handle handler $ do let sfile = pathString path fs <- getFileStatus sfile if doesExist fs then pos fs else neg Just Negative -> return (cache, Nothing) Just (Positive x) -> return (cache, Just x) where size = fromIntegral . fileSize mtime = epochTimeToHTTPDate . modificationTime doesExist = not . isDirectory bpath = pathByteString path pos fs = do let info = FileInfo { fileInfoName = path , fileInfoSize = size fs , fileInfoTime = mtime fs } entry = Positive info cache' = M.insert bpath entry cache return (cache', Just info) neg = do let cache' = M.insert bpath Negative cache return (cache', Nothing) handler :: SomeException -> IO (Cache, Maybe FileInfo) handler _ = neg fileCacheInit :: IO GetInfo fileCacheInit = do ref <- newIORef M.empty forkIO (remover ref) return $ fileInfo ref -- atomicModifyIORef is not necessary here. remover :: IORef Cache -> IO () remover ref = forever $ threadDelay 10000000 >> writeIORef ref M.empty mighttpd2-2.5.9/FileCGIApp.hs0000644000000000000000000000513311745162726014033 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module FileCGIApp (fileCgiApp) where import Control.Monad.IO.Class (liftIO) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS import Network.HTTP.Types import Network.Wai import Network.Wai.Application.Classic import Types data Perhaps a = Found a | Redirect | Fail fileCgiApp :: ClassicAppSpec -> FileAppSpec -> CgiAppSpec -> RevProxyAppSpec -> RouteDB -> Application fileCgiApp cspec filespec cgispec revproxyspec um req = case mmp of Fail -> do let st = preconditionFailed412 liftIO $ logger cspec req st Nothing fastResponse st defaultHeader "Precondition Failed\r\n" Redirect -> do let st = movedPermanently301 hdr = defaultHeader ++ redirectHeader req liftIO $ logger cspec req st Nothing fastResponse st hdr "Moved Permanently\r\n" Found (RouteFile src dst) -> do fileApp cspec filespec (FileRoute src dst) req Found (RouteCGI src dst) -> cgiApp cspec cgispec (CgiRoute src dst) req Found (RouteRevProxy src dst dom prt) -> revProxyApp cspec revproxyspec (RevProxyRoute src dst dom prt) req where mmp = case getBlock (serverName req) um of Nothing -> Fail Just blk -> getRoute (rawPathInfo req) blk fastResponse st hdr body = return $ responseLBS st hdr body defaultHeader = [("Content-Type", "text/plain") ,("Server", softwareName cspec)] getBlock :: ByteString -> RouteDB -> Maybe [Route] getBlock _ [] = Nothing getBlock key (Block doms maps : ms) | "*" `elem` doms = Just maps | key `elem` doms = Just maps | otherwise = getBlock key ms getRoute :: ByteString -> [Route] -> Perhaps Route getRoute _ [] = Fail getRoute key (m@(RouteFile src _):ms) | src `isPrefixOf` key = Found m | src `isMountPointOf` key = Redirect | otherwise = getRoute key ms getRoute key (m@(RouteCGI src _):ms) | src `isPrefixOf` key = Found m | src `isMountPointOf` key = Redirect | otherwise = getRoute key ms getRoute key (m@(RouteRevProxy src _ _ _):ms) | src `isPrefixOf` key = Found m | src `isMountPointOf` key = Redirect | otherwise = getRoute key ms isPrefixOf :: Path -> ByteString -> Bool isPrefixOf src key = src' `BS.isPrefixOf` key where src' = pathByteString src isMountPointOf :: Path -> ByteString -> Bool isMountPointOf src key = hasTrailingPathSeparator src && BS.length src' - BS.length key == 1 && key `BS.isPrefixOf` src' where src' = pathByteString src mighttpd2-2.5.9/LICENSE0000644000000000000000000000276511745162726012651 0ustar0000000000000000Copyright (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. mighttpd2-2.5.9/mighttpd2.cabal0000644000000000000000000000651411745162726014526 0ustar0000000000000000Name: mighttpd2 Version: 2.5.9 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 License-File: LICENSE Synopsis: High performance web server on WAI/warp Description: High performance web server to handle static files and CGI on WAI/warp. Reverse proxy functionality is also provided to connect web applications behind. Homepage: http://www.mew.org/~kazu/proj/mighttpd/ Category: Network, Web Cabal-Version: >= 1.8 Build-Type: Simple Data-Files: example.conf example.route Executable mighty Main-Is: Mighty.hs GHC-Options: -Wall -fno-warn-unused-do-bind -threaded Build-Depends: base >= 4.0 && < 5 , bytestring , deepseq , directory , filepath , http-conduit , http-date , http-types , network , network-conduit , old-locale , parsec >= 3 , time , transformers , unix , unix-bytestring , unordered-containers , wai >= 1.1 , wai-app-file-cgi , wai-logger , wai-logger-prefork , warp Other-Modules: Config Config.Internal FileCGIApp FileCache Mighty Parser Route Types Paths_mighttpd2 Executable mkindex Main-Is: mkindex.hs GHC-Options: -Wall -fno-warn-unused-do-bind Build-Depends: base >= 4 && < 5 , unix , old-locale , directory , time Test-Suite test Main-Is: Test.hs Hs-Source-Dirs: test, . Type: exitcode-stdio-1.0 Build-Depends: base >= 4 && < 5 , bytestring , deepseq , directory , filepath , http-conduit , http-date , http-types , network , network-conduit , old-locale , parsec >= 3 , time , transformers , unix , unix-bytestring , unordered-containers , wai >= 1.1 , wai-app-file-cgi , wai-logger , wai-logger-prefork , warp , HUnit , test-framework-hunit , test-framework-th-prime Source-Repository head Type: git Location: git://github.com/kazu-yamamoto/mighttpd2.git mighttpd2-2.5.9/Mighty.hs0000644000000000000000000001416311745162726013434 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Main where import Config import Control.Applicative import Control.Concurrent import Control.Exception (catch, handle, SomeException) import Control.Monad import qualified Data.ByteString.Char8 as BS import Data.Conduit.Network import FileCGIApp import FileCache import Network import qualified Network.HTTP.Conduit as H import Network.Wai.Application.Classic import Network.Wai.Handler.Warp import Network.Wai.Logger import Network.Wai.Logger.Prefork import Prelude hiding (catch) import Route import System.Directory import System.Environment import System.Exit import System.FilePath import System.IO import System.Posix import Types errorFile :: FilePath errorFile = "/tmp/mighty_error" main :: IO () main = do (opt,route) <- getOptRoute if opt_debug_mode opt then server opt route else do putStrLn "Detaching this terminal..." putStrLn $ "If any, errors can be found in \"" ++ errorFile ++ "\"" hFlush stdout daemonize $ server opt route where getOptRoute = getArgs >>= eachCase eachCase args | n == 0 = do root <- amIrootUser let opt = if root then defaultOption { opt_port = 80 } else defaultOption dir <- getCurrentDirectory let dst = fromString . addTrailingPathSeparator $ dir route = [Block ["*"] [RouteFile "/" dst]] return (opt, route) | n == 2 = do opt <- parseOption $ args !! 0 route <- parseRoute $ args !! 1 return (opt,route) | otherwise = do hPutStrLn stderr "Usage: mighty" hPutStrLn stderr " mighty config_file routing_file" exitFailure where n = length args ---------------------------------------------------------------- server :: Option -> RouteDB -> IO () server opt route = handle handler $ do s <- sOpen if debug then do putStrLn $ "Serving on port " ++ show port ++ "." hFlush stdout else writePidFile setGroupUser opt logCheck logtype if workers == 1 then do forkIO $ single opt route s logtype myid <- getProcessID logController logtype [myid] else do cids <- multi opt route s logtype logController logtype cids where debug = opt_debug_mode opt port = opt_port opt sOpen = listenOn (PortNumber . fromIntegral $ port) pidfile = opt_pid_file opt workers = opt_worker_processes opt writePidFile = do pid <- getProcessID writeFile pidfile $ show pid ++ "\n" setFileMode pidfile 0o644 handler :: SomeException -> IO () handler e | debug = hPrint stderr e | otherwise = writeFile errorFile (show e) 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 } logtype | not (opt_logging opt) = LogNone | debug = LogStdout | otherwise = LogFile logspec ---------------------------------------------------------------- single :: Option -> RouteDB -> Socket -> LogType -> IO () single opt route s logtype = do ignoreSigChild lgr <- logInit FromSocket logtype getInfo <- fileCacheInit mgr <- H.newManager H.def { -- FIXME H.managerConnCount = 1024 } runSettingsSocket setting s $ \req -> fileCgiApp (cspec lgr) (filespec getInfo) cgispec (revproxyspec mgr) route req where setting = defaultSettings { settingsPort = opt_port opt , settingsOnException = printStdout , settingsTimeout = opt_connection_timeout opt , settingsHost = HostAny } serverName = BS.pack $ opt_server_name opt cspec lgr = ClassicAppSpec { softwareName = serverName , logger = lgr , statusFileDir = fromString $ opt_status_file_dir opt } filespec getInfo = FileAppSpec { indexFile = fromString $ opt_index_file opt , isHTML = \x -> ".html" `isSuffixOf` x || ".htm" `isSuffixOf` x , getFileInfo = getInfo } cgispec = CgiAppSpec { indexCgi = "index.cgi" } revproxyspec mgr = RevProxyAppSpec { revProxyManager = mgr } multi :: Option -> RouteDB -> Socket -> LogType -> IO [ProcessID] multi opt route s logtype = do ignoreSigChild cids <- replicateM workers $ forkProcess (single opt route s logtype) sClose s initHandler sigTERM $ terminateHandler cids initHandler sigINT $ terminateHandler cids return cids where workers = opt_worker_processes opt terminateHandler cids = Catch $ do mapM_ terminateChild cids exitImmediately ExitSuccess terminateChild cid = signalProcess sigTERM cid `catch` ignore initHandler :: Signal -> Handler -> IO Handler initHandler sig func = installHandler sig func Nothing ignoreSigChild :: IO Handler ignoreSigChild = initHandler sigCHLD Ignore ---------------------------------------------------------------- amIrootUser :: IO Bool amIrootUser = (== 0) <$> getRealUserID setGroupUser :: Option -> IO () setGroupUser opt = do root <- amIrootUser when root $ 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 ---------------------------------------------------------------- ignore :: SomeException -> IO () ignore _ = return () printStdout :: SomeException -> IO () printStdout = print mighttpd2-2.5.9/mkindex.hs0000644000000000000000000000462211745162726013631 0ustar0000000000000000{- mkindex :: Making index.html for the current directory. -} import Control.Applicative import Data.Bits import Data.Time import Data.Time.Clock.POSIX import System.Directory import System.Locale import System.Posix.Files import Text.Printf 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 = zipWith pp 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 _ [] = error "unit" 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" mighttpd2-2.5.9/Parser.hs0000644000000000000000000000153411745162726013425 0ustar0000000000000000module Parser where import Control.Applicative hiding (many,(<|>)) import Control.Exception 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 (`elem` " \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 -> throwIO . userError . show $ e mighttpd2-2.5.9/Route.hs0000644000000000000000000000343311745162726013267 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, TupleSections #-} module Route (parseRoute) where import Control.Applicative hiding (many,(<|>)) import qualified Data.ByteString.Char8 as BS import Network.Wai.Application.Classic 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 data Op = OpFile | OpCGI | OpRevProxy route :: Parser Route route = do s <- src o <- op case o of OpFile -> RouteFile s <$> dst <* trailing OpCGI -> RouteCGI s <$> dst <* trailing OpRevProxy -> do (dom,prt,d) <- domPortDst return $ RouteRevProxy s d dom prt where src = path dst = path op0 = OpFile <$ string "->" <|> OpCGI <$ string "=>" <|> OpRevProxy <$ string ">>" op = op0 <* spcs path :: Parser Path path = do c <- char '/' fromByteString . BS.pack . (c:) <$> many (noneOf "[], \t\n") <* spcs -- [host1][:port2]/path2 domPortDst :: Parser (Domain, Port, Dst) domPortDst = (defaultDomain,,) <$> port <*> path <|> try((,,) <$> domain <*> port <*> path) <|> (,defaultPort,) <$> domain <*> path where domain = BS.pack <$> many1 (noneOf ":/[], \t\n") port = do char ':' read <$> many1 (oneOf ['0'..'9']) mighttpd2-2.5.9/Setup.hs0000644000000000000000000000005611745162726013267 0ustar0000000000000000import Distribution.Simple main = defaultMain mighttpd2-2.5.9/Types.hs0000644000000000000000000000136011745162726013272 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Types where import Data.ByteString import Data.ByteString.Char8 () import Data.Version import Network.Wai.Application.Classic import Paths_mighttpd2 type Src = Path type Dst = Path type Domain = ByteString type PathInfo = ByteString type Port = Int data Block = Block [Domain] [Route] deriving (Eq,Show) data Route = RouteFile Src Dst | RouteCGI Src Dst | RouteRevProxy Src Dst Domain Port deriving (Eq,Show) type RouteDB = [Block] programName :: String programName = "Mighttpd" programVersion :: String programVersion = showVersion version defaultDomain :: Domain defaultDomain = "localhost" defaultPort :: Int defaultPort = 80 mighttpd2-2.5.9/Config/0000755000000000000000000000000011745162726013037 5ustar0000000000000000mighttpd2-2.5.9/Config/Internal.hs0000644000000000000000000000772411745162726015161 0ustar0000000000000000{-# 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_logging = True , opt_log_file = "/var/log/mighty" , opt_log_file_size = 16777216 , opt_log_backup_number = 10 , opt_index_file = "index.html" , opt_index_cgi = "index.cgi" , opt_status_file_dir = "/usr/local/share/mighty/status" , opt_connection_timeout = 30 , opt_server_name = programName ++ "/" ++ programVersion , opt_worker_processes = 1 } data Option = Option { opt_port :: !Int , opt_debug_mode :: !Bool , opt_user :: !String , opt_group :: !String , opt_pid_file :: !String , opt_logging :: !Bool , opt_log_file :: !String , opt_log_file_size :: !Int , opt_log_backup_number :: !Int , opt_index_file :: !String , opt_index_cgi :: !String , opt_status_file_dir :: !String , opt_connection_timeout :: !Int , opt_server_name :: !String , opt_worker_processes :: !Int } 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_logging = get "Logging" opt_logging , 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_index_file = get "Index_File" opt_index_file , opt_index_cgi = get "Index_Cgi" opt_index_cgi , opt_status_file_dir = get "Status_File_Dir" opt_status_file_dir , opt_connection_timeout = get "Connection_Timeout" opt_connection_timeout , opt_server_name = get "Server_Name" opt_server_name , opt_worker_processes = get "Worker_Processes" opt_worker_processes } 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") mighttpd2-2.5.9/test/0000755000000000000000000000000011745162726012611 5ustar0000000000000000mighttpd2-2.5.9/test/Test.hs0000644000000000000000000000271711745162726014073 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, TemplateHaskell #-} module Main where import Config.Internal import Route import Test.Framework.Providers.HUnit import Test.Framework.TH.Prime import Test.HUnit import Types ---------------------------------------------------------------- main :: IO () main = $(defaultMainGenerator) ---------------------------------------------------------------- case_config :: Assertion case_config = do res <- parseConfig "sample.conf" res @?= ans where ans = [("Port",CV_Int 80),("Debug_Mode",CV_Bool True),("User",CV_String "nobody"),("Group",CV_String "nobody"),("Pid_File",CV_String "/var/run/mighty.pid"),("Logging",CV_Bool True),("Log_File",CV_String "/var/log/mighty"),("Log_File_Size",CV_Int 16777216),("Log_Backup_Number",CV_Int 10),("Index_File",CV_String "index.html"),("Index_Cgi",CV_String "index.cgi"),("Status_File_Dir",CV_String "/usr/local/share/mighty/status"),("Connection_Timeout",CV_Int 30),("Worker_Processes",CV_Int 1)] case_route :: Assertion case_route = do res <- parseRoute "sample.route" res @?= ans where ans = [Block ["localhost","www.example.com"] [RouteCGI "/~alice/cgi-bin/" "/home/alice/public_html/cgi-bin/",RouteFile "/~alice/" "/home/alice/public_html/",RouteCGI "/cgi-bin/" "/export/cgi-bin/",RouteRevProxy "/app/cal/" "/calendar/" "example.net" 80,RouteRevProxy "/app/wiki/" "/" "127.0.0.1" 8080,RouteFile "/" "/export/www/"]] ----------------------------------------------------------------