diff --git a/Config.hs b/Config.hs --- a/Config.hs +++ b/Config.hs @@ -2,8 +2,9 @@ module Config (Option(..), parseOption, defaultOption) where -import Text.ParserCombinators.Parsec +import Control.Applicative ((<$>),(<$),(<*),(<*>),(*>)) import Data.List (isPrefixOf) +import Text.ParserCombinators.Parsec ---------------------------------------------------------------- @@ -58,9 +59,7 @@ , 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 + get key func = maybe (func def) fromConf $ lookup key conf ---------------------------------------------------------------- @@ -86,9 +85,9 @@ ---------------------------------------------------------------- parseConfig :: String -> [Conf] -parseConfig cs = let css = filter (not.isPrefixOf "#") $ lines cs - in map parseConf css +parseConfig cs = map parseConf css where + css = filter (not.isPrefixOf "#") . lines $ cs parseConf xs = case parse config "config" xs of Right cnf -> cnf Left err -> error $ "parseConfig " ++ show err @@ -96,12 +95,7 @@ ---------------------------------------------------------------- config :: Parser Conf -config = do nm <- name - spaces - char ':' - spaces - vl <- value - return (nm,vl) +config = (,) <$> name <*> (spaces >> char ':' >> spaces *> value) name :: Parser String name = many1.oneOf $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_" @@ -110,15 +104,11 @@ 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_int = CV_Int . read <$> (many1 digit <* (spaces >> eof)) 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_bool = CV_Bool True <$ (string "Yes" >> spaces >> eof) <|> + CV_Bool False <$ (string "No" >> spaces >> eof) cv_string :: Parser ConfValue -cv_string = do ss <- many1 (noneOf " \t\n") - return $ CV_String ss +cv_string = CV_String <$> many1 (noneOf " \t\n") diff --git a/File.hs b/File.hs --- a/File.hs +++ b/File.hs @@ -1,19 +1,20 @@ +{-# LANGUAGE OverloadedStrings #-} + module File (mighty, progName) where import Control.Applicative -import Data.ByteString.Lazy.Char8 (ByteString) -import qualified Data.ByteString.Lazy.Char8 as LBS +import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString.Lazy.Char8 as L import Data.List import Data.Time import Data.Time.Clock.POSIX -import IO -import Network.Socket -import Network.URI +import Network.TCPInfo import Network.Web.Server import Network.Web.Server.Basic -import Network.Web.Utils +import Network.Web.URI import System.Directory import System.FilePath +import System.IO import System.Posix.Files import URLMap @@ -21,21 +22,19 @@ progName = "Mighttpd" progVersion :: String -progVersion = "0.2.0" +progVersion = "0.3.0" progNameVersion :: String progNameVersion = progName ++ " " ++ progVersion ---------------------------------------------------------------- -mighty :: WebConfig -> URLMap -> Socket -> IO () -mighty wcnf umap s = do - tcpinfo <- getTCPInfo s - hdl <- socketToHandle s ReadWriteMode +mighty :: WebConfig -> URLMap -> Handle -> TCPInfo -> IO () +mighty wcnf umap hdl tcpinfo = do let bcnf = BasicConfig { obtain = fileGet , info = fileInfo , mapper = fileMapper umap - , serverName = progNameVersion + , serverName = S.pack progNameVersion , tcpInfo = tcpinfo } connection hdl (basicServer bcnf) wcnf @@ -46,7 +45,7 @@ lookupFileMap [] _ = None lookupFileMap ((from,to):xs) url | from `isPrefixOf` url = toPath to $ drop (length from) url - | otherwise = lookupFileMap xs url + | otherwise = lookupFileMap xs url where toPath (File dir) restPath = File $ dir restPath toPath (CGI dir _ urlPath) progParam = CGI prog param scriptName @@ -59,19 +58,19 @@ fileMapper :: URLMap -> URI -> Path fileMapper umap uri = fileMapper' (lookupFileMap umap url) where - url = unEscapeString $ toURLwoPort uri + url = unEscapeString . S.unpack . 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 :: FilePath -> Maybe (Integer,Integer) -> IO L.ByteString +fileGet file Nothing = openFile file ReadMode >>= L.hGetContents fileGet file (Just (skip,len)) = do h <- openFile file ReadMode hSeek h AbsoluteSeek skip - LBS.take (fromIntegral len) <$> LBS.hGetContents h + L.take (fromIntegral len) <$> L.hGetContents h fileInfo :: FilePath -> IO (Maybe (Integer, UTCTime)) fileInfo file = do diff --git a/Mighttpd.hs b/Mighttpd.hs --- a/Mighttpd.hs +++ b/Mighttpd.hs @@ -26,8 +26,8 @@ !uriMap = parseURLMap mapf !prog = mighty webConfig uriMap if opt_debug_mode opt - then runC10kServer prog c10kConfig - else daemonize $ runC10kServer prog c10kConfig + then runC10kServerH prog c10kConfig + else daemonize $ runC10kServerH prog c10kConfig where fileName n = do args <- getArgs diff --git a/URLMap.hs b/URLMap.hs --- a/URLMap.hs +++ b/URLMap.hs @@ -1,8 +1,11 @@ +{-# LANGUAGE OverloadedStrings #-} + module URLMap (parseURLMap, URL, URLMap) where import Control.Applicative ((<$>),(<$),(<*),(<*>),(*>),pure) -import Network.URI +import qualified Data.ByteString.Char8 as S import Network.Web.Server.Basic +import Network.Web.URI import Text.Parsec import Text.Parsec.String @@ -13,8 +16,8 @@ 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) + fixCGI kv = kv + scriptDir x = maybe "" (S.unpack . uriPath) $ parseURI $ S.pack x umap :: Parser [(URL,Path)] umap = comments *> many (line <* comments) diff --git a/mighttpd.cabal b/mighttpd.cabal --- a/mighttpd.cabal +++ b/mighttpd.cabal @@ -1,5 +1,5 @@ Name: mighttpd -Version: 0.2.0 +Version: 0.3.0 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3