From: pho Date: Wed, 21 Mar 2007 15:17:31 +0000 (+0900) Subject: Initial Import X-Git-Tag: RELEASE-0_2_1~69 X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=9961a721f98b101825ef154a2122c1fc2fa6d1ac;p=Lucu.git Initial Import darcs-hash:20070321151731-62b54-8d40da886d55c7dd3ad0ef9fafb36c77b68d4417.gz --- 9961a721f98b101825ef154a2122c1fc2fa6d1ac diff --git a/.boring b/.boring new file mode 100644 index 0000000..93f3d7a --- /dev/null +++ b/.boring @@ -0,0 +1,53 @@ +# Boring file regexps: +\.hi$ +\.hi-boot$ +\.o-boot$ +\.o$ +\.o\.cmd$ +# *.ko files aren't boring by default because they might +# be Korean translations rather than kernel modules. +# \.ko$ +\.ko\.cmd$ +\.mod\.c$ +(^|/)\.tmp_versions($|/) +(^|/)CVS($|/) +(^|/)RCS($|/) +~$ +#(^|/)\.[^/] +(^|/)_darcs($|/) +\.bak$ +\.BAK$ +\.orig$ +(^|/)vssver\.scc$ +\.swp$ +(^|/)MT($|/) +(^|/)\{arch\}($|/) +(^|/).arch-ids($|/) +(^|/), +\.class$ +\.prof$ +(^|/)\.DS_Store$ +(^|/)BitKeeper($|/) +(^|/)ChangeSet($|/) +(^|/)\.svn($|/) +\.py[co]$ +\# +\.cvsignore$ +(^|/)Thumbs\.db$ +(^|/)autom4te\.cache($|/) +,v$ +^\.# +\.elc$ +(^|/)(tags|TAGS)$ +(^|/)SCCS($|/) +(^|/)config\.(log|status)$ +\.rej$ +\.bzr$ +(^|/|\.)core$ +\.(obj|a|exe|so|lo|la)$ +^\.darcs-temp-mail$ +^\.depend$ + +^dist($|/) +^run\.sh$ +^Setup$ diff --git a/Lucu.cabal b/Lucu.cabal new file mode 100644 index 0000000..b04dc16 --- /dev/null +++ b/Lucu.cabal @@ -0,0 +1,21 @@ +Name: Lucu +Synopsis: HTTP Daemon Library +Version: 0 +License: PublicDomain +Author: PHO +Homepage: http://ccm.sherry.jp/ +Category: Incomplete +Build-Depends: + base, mtl, network +Exposed-Modules: + Network.HTTP.Lucu.Config + Network.HTTP.Lucu.Headers + Network.HTTP.Lucu.Httpd + Network.HTTP.Lucu.HttpVersion + Network.HTTP.Lucu.Response + Network.HTTP.Lucu.Resource + Network.HTTP.Lucu.Request + +Executable: HelloWorld +Main-Is: HelloWorld.hs +Hs-Source-Dirs: ., examples diff --git a/Network/HTTP/Lucu/Config.hs b/Network/HTTP/Lucu/Config.hs new file mode 100644 index 0000000..919e134 --- /dev/null +++ b/Network/HTTP/Lucu/Config.hs @@ -0,0 +1,19 @@ +module Network.HTTP.Lucu.Config + ( Config(..) + , defaultConfig -- Config + ) + where + +import Network + +data Config = Config { + cnfServerPort :: PortID + , cnfMaxEntityLength :: Integer + , cnfMaxURILength :: Int + } + +defaultConfig = Config { + cnfServerPort = Service "http" + , cnfMaxEntityLength = 16 * 1024 * 1024 -- 16 MiB + , cnfMaxURILength = 4 * 1024 -- 4 KiB + } \ No newline at end of file diff --git a/Network/HTTP/Lucu/Headers.hs b/Network/HTTP/Lucu/Headers.hs new file mode 100644 index 0000000..fbab856 --- /dev/null +++ b/Network/HTTP/Lucu/Headers.hs @@ -0,0 +1,45 @@ +module Network.HTTP.Lucu.Headers + ( Headers + , HasHeaders(..) + , emptyHeaders -- Headers + ) + where + +import qualified Data.ByteString.Lazy.Char8 as B +import Data.ByteString.Lazy.Char8 (ByteString) +import Data.Char +import Data.List + +type Headers = [ (ByteString, ByteString) ] + +class HasHeaders a where + getHeaders :: a -> Headers + setHeaders :: a -> Headers -> a + + getHeader :: a -> ByteString -> Maybe ByteString + getHeader a key + = fmap snd $ find (noCaseEq key . fst) (getHeaders a) + + deleteHeader :: a -> ByteString -> a + deleteHeader a key + = setHeaders a $ filter (not . noCaseEq key . fst) (getHeaders a) + + addHeader :: a -> ByteString -> ByteString -> a + addHeader a key val + = setHeaders a $ (getHeaders a) ++ [(key, val)] + + setHeader :: a -> ByteString -> ByteString -> a + setHeader a key val + = let list = getHeaders a + deleted = filter (not . noCaseEq key . fst) list + added = deleted ++ [(key, val)] + in + setHeaders a added + +noCaseEq :: ByteString -> ByteString -> Bool +noCaseEq a b + = (B.map toLower a) == (B.map toLower b) + + +emptyHeaders :: Headers +emptyHeaders = [] \ No newline at end of file diff --git a/Network/HTTP/Lucu/HttpVersion.hs b/Network/HTTP/Lucu/HttpVersion.hs new file mode 100644 index 0000000..88dc24e --- /dev/null +++ b/Network/HTTP/Lucu/HttpVersion.hs @@ -0,0 +1,29 @@ +module Network.HTTP.Lucu.HttpVersion + ( HttpVersion(..) + , httpVersionP -- Parser HttpVersion + ) + where + +import qualified Data.ByteString.Lazy.Char8 as B +import Data.ByteString.Lazy.Char8 (ByteString) +import Network.HTTP.Lucu.Parser + +data HttpVersion = HttpVersion Int Int + deriving (Show, Eq) + +instance Ord HttpVersion where + (HttpVersion majA minA) `compare` (HttpVersion majB minB) + | majA > majB = GT + | majA < majB = LT + | minA > minB = GT + | minA < minB = LT + | otherwise = EQ + + +httpVersionP :: Parser HttpVersion +httpVersionP = do string "HTTP/" + major <- many1 digit + char '.' + minor <- many1 digit + return $ HttpVersion (read major) (read minor) + diff --git a/Network/HTTP/Lucu/Httpd.hs b/Network/HTTP/Lucu/Httpd.hs new file mode 100644 index 0000000..70df377 --- /dev/null +++ b/Network/HTTP/Lucu/Httpd.hs @@ -0,0 +1,52 @@ +module Network.HTTP.Lucu.Httpd + ( ResourceTable + , mkResourceTable -- [ ([String], Resource ()) ] -> ResourceTable + , runHttpd -- Config -> ResourceTable -> IO () + ) + where + +import Control.Concurrent +import qualified Data.ByteString.Lazy.Char8 as B +import Data.ByteString.Lazy.Char8 (ByteString) +import Data.Map as M +import Data.Map (Map) +import Network +import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.Parser +import Network.HTTP.Lucu.Request +import Network.HTTP.Lucu.Resource +import Network.HTTP.Lucu.Response +import System.IO + + +type ResourceTable = Map [String] (Resource ()) + + +mkResourceTable :: [ ([String], Resource ()) ] -> ResourceTable +mkResourceTable = M.fromList + + +runHttpd :: Config -> ResourceTable -> IO () +runHttpd cnf table + = withSocketsDo $ + do so <- listenOn (cnfServerPort cnf) + loop so + where + loop :: Socket -> IO () + loop so + = do (h, host, port) <- accept so + forkIO $ service h host port + loop so + + +service :: Handle -> HostName -> PortNumber -> IO () +service h host port + = do input <- B.hGetContents h + loop input + where + loop :: ByteString -> IO () + loop input = case parse requestP input of + Nothing + -> fail "FIXME" + Just (req, input') + -> print req diff --git a/Network/HTTP/Lucu/Parser.hs b/Network/HTTP/Lucu/Parser.hs new file mode 100644 index 0000000..7a51ddc --- /dev/null +++ b/Network/HTTP/Lucu/Parser.hs @@ -0,0 +1,129 @@ +module Network.HTTP.Lucu.Parser + ( Parser(..) + , parse -- Parser a -> ByteString -> Maybe (a, ByteString) + , anyChar -- Parser Char + , satisfy -- (Char -> Bool) -> Parser Char + , char -- Char -> Parser Char + , string -- String -> Parser String + , (<|>) -- Parser a -> Parser a -> Parser a + , oneOf -- [Char] -> Parser Char + , digit -- Parser Char + , notFollowedBy -- Parser a -> Parser () + , many -- Parser a -> Parser [a] + , many1 -- Parser a -> Parser [a] + , manyTill -- Parser a -> Parser end -> Parser [a] + , many1Till -- Parser a -> Parser end -> Parser [a] + , sp -- Parser Char + , crlf -- Parser String + ) + where + +import Control.Monad +import Control.Monad.State +import qualified Data.ByteString.Lazy.Char8 as B +import Data.ByteString.Lazy.Char8 (ByteString) + +data Parser a = Parser { + runParser :: State ByteString (Maybe a) + } + + +-- (>>=) :: Parser a -> (a -> Parser b) -> Parser b +instance Monad Parser where + p >>= f = Parser $ do saved <- get -- 失敗した時の爲に状態を保存 + result <- runParser p + case result of + Just a -> runParser (f a) + Nothing -> do put saved -- 状態を復歸 + return Nothing + return = Parser . return . Just + fail _ = Parser $ return Nothing + + +parse :: Parser a -> ByteString -> Maybe (a, ByteString) +parse p input = case runState (runParser p) input of + (Just a , input') -> Just (a, input') + (Nothing, _ ) -> Nothing + + +anyChar :: Parser Char +anyChar = Parser $ do input <- get + if B.null input then + return Nothing + else + do let c = B.head input + put (B.tail input) + return (Just c) + + +satisfy :: (Char -> Bool) -> Parser Char +satisfy f = do c <- anyChar + unless (f c) (fail "") + return c + + +char :: Char -> Parser Char +char c = satisfy (== c) + + +string :: String -> Parser String +string str = do mapM_ char str + return str + + +infixr 0 <|> + +(<|>) :: Parser a -> Parser a -> Parser a +f <|> g = Parser $ do saved <- get -- 状態を保存 + result <- runParser f + case result of + Just a -> return (Just a) + Nothing -> do put saved -- 状態を復歸 + runParser g + + +oneOf :: [Char] -> Parser Char +oneOf = foldl (<|>) (fail "") . map char + + +notFollowedBy :: Parser a -> Parser () +notFollowedBy p = p >>= fail "" <|> return () + + +digit :: Parser Char +digit = oneOf "0123456789" + + +many :: Parser a -> Parser [a] +many p = do x <- p + xs <- many p + return (x:xs) + <|> + return [] + + +many1 :: Parser a -> Parser [a] +many1 p = do ret <- many p + case ret of + [] -> fail "" + xs -> return xs + + +manyTill :: Parser a -> Parser end -> Parser [a] +manyTill p end = many $ do x <- p + end + return x + + +many1Till :: Parser a -> Parser end -> Parser [a] +many1Till p end = many1 $ do x <- p + end + return x + + +sp :: Parser Char +sp = char ' ' + + +crlf :: Parser String +crlf = string "\x0d\x0a" diff --git a/Network/HTTP/Lucu/Parser/Http.hs b/Network/HTTP/Lucu/Parser/Http.hs new file mode 100644 index 0000000..021ced8 --- /dev/null +++ b/Network/HTTP/Lucu/Parser/Http.hs @@ -0,0 +1,25 @@ +module Network.HTTP.Lucu.Parser.Http + ( isCtl -- Char -> Bool + , isSeparator -- Char -> Bool + , token -- Parser Char + ) + where + +import qualified Data.ByteString.Lazy.Char8 as B +import Data.ByteString.Lazy.Char8 (ByteString) +import Data.List +import Network.HTTP.Lucu.Parser + +isCtl :: Char -> Bool +isCtl c + | c < '\x1f' = True + | c == '\x7f' = True + | otherwise = False + + +isSeparator :: Char -> Bool +isSeparator c = elem c "()<>@,;:\\\"/[]?={} \t" + + +token :: Parser Char +token = satisfy (\ c -> not (isCtl c || isSeparator c)) diff --git a/Network/HTTP/Lucu/Request.hs b/Network/HTTP/Lucu/Request.hs new file mode 100644 index 0000000..3c235eb --- /dev/null +++ b/Network/HTTP/Lucu/Request.hs @@ -0,0 +1,84 @@ +module Network.HTTP.Lucu.Request + ( Method(..) + , Request + , requestP -- Parser Request + ) + where + +import qualified Data.ByteString.Lazy.Char8 as B +import Data.ByteString.Lazy.Char8 (ByteString) +import Network.HTTP.Lucu.Headers +import Network.HTTP.Lucu.HttpVersion +import Network.HTTP.Lucu.Parser +import Network.HTTP.Lucu.Parser.Http +import Network.URI + +data Method = OPTIONS + | GET + | HEAD + | PUT + | DELETE + | TRACE + | CONNECT + | ExtensionMethod String + deriving (Eq, Show) + + +data Request + = Request { + reqMethod :: Method + , reqURI :: URI + , reqVersion :: HttpVersion + , reqHeaders :: Headers + , reqBody :: Maybe ByteString + } + deriving (Show) + +instance HasHeaders Request where + getHeaders = reqHeaders + setHeaders req hdr = req { reqHeaders = hdr } + + +requestP :: Parser Request +requestP = do many crlf + (method, uri, version) <- requestLineP + let req = Request { + reqMethod = method + , reqURI = uri + , reqVersion = version + , reqHeaders = emptyHeaders -- FIXME + , reqBody = Nothing -- FIXME + } + return req + + +requestLineP :: Parser (Method, URI, HttpVersion) +requestLineP = do method <- methodP + sp + uri <- uriP + sp + ver <- httpVersionP + crlf + return (method, uri, ver) + + +methodP :: Parser Method +methodP = (let methods = [ ("OPTIONS", OPTIONS) + , ("GET" , GET ) + , ("HEAD" , HEAD ) + , ("PUT" , PUT ) + , ("DELETE" , DELETE ) + , ("TRACE" , TRACE ) + , ("CONNECT", CONNECT) + ] + in foldl (<|>) (fail "") $ map (\ (str, mth) + -> string str >> return mth) methods) + <|> + many1 token >>= return . ExtensionMethod + + +uriP :: Parser URI +uriP = do str <- many1 $ satisfy (\ c -> not (isCtl c || c == ' ')) + case parseURIReference str of + Nothing -> fail "" + Just uri -> return uri \ No newline at end of file diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs new file mode 100644 index 0000000..bc4bf33 --- /dev/null +++ b/Network/HTTP/Lucu/Resource.hs @@ -0,0 +1,14 @@ +module Network.HTTP.Lucu.Resource + ( Resource + ) + where + +import Control.Monad.State +import qualified Data.ByteString.Lazy.Char8 as B +import Data.ByteString.Lazy.Char8 (ByteString) + +data ResState = ResState -- FIXME + +type ResourceT m a = StateT ResState m a + +type Resource a = ResourceT IO a diff --git a/Network/HTTP/Lucu/Response.hs b/Network/HTTP/Lucu/Response.hs new file mode 100644 index 0000000..e61a6a5 --- /dev/null +++ b/Network/HTTP/Lucu/Response.hs @@ -0,0 +1,72 @@ +module Network.HTTP.Lucu.Response + ( StatusCode(..) + , Response(..) + ) + where + +import qualified Data.ByteString.Lazy.Char8 as B +import Data.ByteString.Lazy.Char8 (ByteString) +import Network.HTTP.Lucu.Headers +import Network.HTTP.Lucu.HttpVersion + +data StatusCode = Continue + | SwitchingProtocols + | Processing + -- + | Ok + | Created + | Accepted + | NonAuthoritativeInformation + | NoContent + | ResetContent + | PartialContent + | MultiStatus + -- + | MultipleChoices + | MovedPermanently + | Found + | SeeOther + | NotModified + | UseProxy + | TemporaryRedirect + -- + | BadRequest + | Unauthorized + | PaymentRequired + | Forbidden + | NotFound + | MethodNotAllowed + | NotAcceptable + | ProxyAuthenticationRequired + | RequestTimeout + | Conflict + | Gone + | LengthRequired + | PreconditionFailed + | RequestEntityTooLarge + | RequestURITooLarge + | UnsupportedMediaType + | RequestRangeNotSatisfiable + | ExpectationFailed + | UnprocessableEntitiy + | Locked + | FailedDependency + -- + | InternalServerError + | NotImplemented + | BadGateway + | ServiceUnavailable + | GatewayTimeout + | HttpVersionNotSupported + | InsufficientStorage + +data Response = Response { + resVersion :: HttpVersion + , resStatus :: StatusCode + , resHeaders :: Headers + , resBody :: Maybe ByteString + } + +instance HasHeaders Response where + getHeaders = resHeaders + setHeaders res hdr = res { resHeaders = hdr } diff --git a/Setup.hs b/Setup.hs new file mode 100755 index 0000000..411bd08 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,163 @@ +#!/usr/bin/env runghc + +import Distribution.Simple +main = defaultMain + +{- +import Data.Maybe +import Distribution.PackageDescription +import Distribution.Setup +import Distribution.Simple +import Distribution.Simple.Configure +import Distribution.Simple.LocalBuildInfo +import System.IO +import System.Exit +import System.Directory +import System.Process +import Control.Monad +import Control.Exception + +buildInfoName = "Kirschbaum.buildinfo" +cgiName = "Kirschbaum.cgi" + +main = defaultMainWithHooks defaultUserHooks {preConf = preConf, postConf = postConf} + where + preConf :: [String] -> ConfigFlags -> IO HookedBuildInfo + preConf args flags + = do try (removeFile buildInfoName) + return emptyHookedBuildInfo + postConf :: [String] -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO ExitCode + postConf args flags _ localbuildinfo + = do binfo <- pkgConfigBuildInfo (configVerbose flags) + let default_binfo = emptyBuildInfo {extraLibs = ["xml2", "xslt", "exslt"]} + writeHookedBuildInfo buildInfoName (Just emptyBuildInfo, + [(cgiName, fromMaybe default_binfo binfo)]) + return ExitSuccess + + +message :: String -> IO () +message s = putStrLn $ "configure: " ++ s + +rawSystemGrabOutput :: Int -> FilePath -> [String] -> IO String +rawSystemGrabOutput verbose path args + = do when (verbose > 0) $ + putStrLn (path ++ concatMap (' ':) args) + (inp,out,err,pid) <- runInteractiveProcess path args Nothing Nothing + exitCode <- waitForProcess pid + if exitCode /= ExitSuccess then + do errMsg <- hGetContents err + hPutStr stderr errMsg + exitWith exitCode else + return () + hClose inp + hClose err + hGetContents out + +{- +mergeBuildInfo :: BuildInfo -> BuildInfo -> BuildInfo +mergeBuildInfo b1 b2 = BuildInfo { + buildable = buildable b1 || buildable b2, + ccOptions = ccOptions b1 ++ ccOptions b2, + ldOptions = ldOptions b1 ++ ldOptions b2, + frameworks = frameworks b1 ++ frameworks b2, + cSources = cSources b1 ++ cSources b2, + hsSourceDirs = hsSourceDirs b1 ++ hsSourceDirs b2, + otherModules = otherModules b1 ++ otherModules b2, + extensions = extensions b1 ++ extensions b2, + extraLibs = extraLibs b1 ++ extraLibs b2, + extraLibDirs = extraLibDirs b1 ++ extraLibDirs b2, + includeDirs = includeDirs b1 ++ includeDirs b2, + includes = includes b1 ++ includes b2, + installIncludes = installIncludes b1 ++ installIncludes b2, + options = options b1 ++ options b2, + ghcProfOptions = ghcProfOptions b1 ++ ghcProfOptions b2 + } + +libXml2ConfigBuildInfo :: Int -> IO (Maybe BuildInfo) +libXml2ConfigBuildInfo verbose + = do mb_libxml2_config_path <- findProgram "xml2-config" Nothing + case mb_libxml2_config_path + of Just libxml2_config_path + -> do message "configuring libxml2 library" + res <- rawSystemGrabOutput verbose libxml2_config_path ["--libs"] + let (lib_dirs, libs, ld_opts) = splitLibsFlags (words res) + res <- rawSystemGrabOutput verbose libxml2_config_path ["--cflags"] + let (inc_dirs, cc_opts) = splitCFlags (words res) + let bi = emptyBuildInfo { + extraLibDirs = lib_dirs, + extraLibs = libs, + ldOptions = ld_opts, + includeDirs = inc_dirs, + ccOptions = cc_opts + } + return $ Just bi + Nothing + -> do message "This package will be built using default settings for libxml2 library" + return Nothing + +libXsltConfigBuildInfo :: Int -> IO (Maybe BuildInfo) +libXsltConfigBuildInfo verbose + = do mb_libxslt_config_path <- findProgram "xslt-config" Nothing + case mb_libxslt_config_path + of Just libxslt_config_path + -> do message "configuring libxslt library" + res <- rawSystemGrabOutput verbose libxslt_config_path ["--libs"] + let (lib_dirs, libs, ld_opts) = splitLibsFlags (words res) + res <- rawSystemGrabOutput verbose libxslt_config_path ["--cflags"] + let (inc_dirs, cc_opts) = splitCFlags (words res) + let bi = emptyBuildInfo { + extraLibDirs = lib_dirs, + extraLibs = libs, + ldOptions = ld_opts, + includeDirs = inc_dirs, + ccOptions = cc_opts + } + return $ Just bi + Nothing + -> do message "This package will be built using default settings for libxslt library" + return Nothing +-} + +pkgConfigBuildInfo :: Int -> IO (Maybe BuildInfo) +pkgConfigBuildInfo verbose + = do mb_libxslt_config_path <- findProgram "pkg-config" Nothing + case mb_libxslt_config_path + of Just libxslt_config_path + -> do message "configuring libxml2, libxslt and libexslt library" + let modules = ["libxml-2.0", "libxslt", "libexslt"] + res <- rawSystemGrabOutput verbose libxslt_config_path (modules ++ ["--libs"]) + let (lib_dirs, libs, ld_opts) = splitLibsFlags (words res) + res <- rawSystemGrabOutput verbose libxslt_config_path (modules ++ ["--cflags"]) + let (inc_dirs, cc_opts) = splitCFlags (words res) + let bi = emptyBuildInfo { + extraLibDirs = lib_dirs, + extraLibs = libs, + ldOptions = ld_opts, + includeDirs = inc_dirs, + ccOptions = cc_opts + } + return $ Just bi + Nothing + -> do message "This package will be built using default settings for libxslt library" + return Nothing + +splitLibsFlags :: [String] -> ([String], [String], [String]) +splitLibsFlags [] = ([], [], []) +splitLibsFlags (arg:args) + = case arg + of ('-':'L':lib_dir) -> let (lib_dirs, libs, ld_opts) = splitLibsFlags args + in (lib_dir:lib_dirs, libs, ld_opts) + ('-':'l':lib) -> let (lib_dirs, libs, ld_opts) = splitLibsFlags args + in (lib_dirs, lib:libs, ld_opts) + ld_opt -> let (lib_dirs, libs, ld_opts) = splitLibsFlags args + in (lib_dirs, libs, ld_opt:ld_opts) + +splitCFlags :: [String] -> ([String], [String]) +splitCFlags [] = ([], []) +splitCFlags (arg:args) + = case arg + of ('-':'I':inc_dir) -> let (inc_dirs, c_opts) = splitCFlags args + in (inc_dir:inc_dirs, c_opts) + c_opt -> let (inc_dirs, c_opts) = splitCFlags args + in (inc_dirs, c_opt:c_opts) +-} \ No newline at end of file diff --git a/examples/HelloWorld.hs b/examples/HelloWorld.hs new file mode 100644 index 0000000..52ceceb --- /dev/null +++ b/examples/HelloWorld.hs @@ -0,0 +1,9 @@ +import Network +import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.Httpd + +main :: IO () +main = let config = defaultConfig { cnfServerPort = PortNumber 9999 } + resources = mkResourceTable [] + in + runHttpd config resources \ No newline at end of file