--- /dev/null
+# 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$
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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)
+
--- /dev/null
+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
--- /dev/null
+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"
--- /dev/null
+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))
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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 }
--- /dev/null
+#!/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
--- /dev/null
+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
projects / Lucu.git / commitdiff