Homepage: http://ccm.sherry.jp/
Category: Incomplete
Build-Depends:
- base, mtl, network
+ base, mtl, network, stm, parsec
Exposed-Modules:
Network.HTTP.Lucu.Config
Network.HTTP.Lucu.Headers
Network.HTTP.Lucu.Response
Network.HTTP.Lucu.Resource
Network.HTTP.Lucu.Request
+ghc-options: -threaded
Executable: HelloWorld
Main-Is: HelloWorld.hs
Hs-Source-Dirs: ., examples
+ghc-options: -threaded
\ No newline at end of file
import Network
data Config = Config {
- cnfServerPort :: PortID
- , cnfMaxEntityLength :: Integer
- , cnfMaxURILength :: Int
+ cnfServerPort :: PortID
+ , cnfMaxPipelineDepth :: Int
+ , cnfMaxEntityLength :: Integer
+ , cnfMaxURILength :: Int
}
defaultConfig = Config {
- cnfServerPort = Service "http"
- , cnfMaxEntityLength = 16 * 1024 * 1024 -- 16 MiB
- , cnfMaxURILength = 4 * 1024 -- 4 KiB
+ cnfServerPort = Service "http"
+ , cnfMaxPipelineDepth = 100
+ , cnfMaxEntityLength = 16 * 1024 * 1024 -- 16 MiB
+ , cnfMaxURILength = 4 * 1024 -- 4 KiB
}
\ No newline at end of file
module Network.HTTP.Lucu.Headers
( Headers
, HasHeaders(..)
- , emptyHeaders -- Headers
+ , emptyHeaders -- Headers
+ , headersP -- Parser Headers
+ , hPutHeaders -- Handle -> Headers -> IO ()
)
where
-import qualified Data.ByteString.Lazy.Char8 as B
-import Data.ByteString.Lazy.Char8 (ByteString)
import Data.Char
import Data.List
+import Network.HTTP.Lucu.Parser
+import Network.HTTP.Lucu.Parser.Http
+import Network.HTTP.Lucu.Utils
+import System.IO
-type Headers = [ (ByteString, ByteString) ]
+type Headers = [ (String, String) ]
class HasHeaders a where
getHeaders :: a -> Headers
setHeaders :: a -> Headers -> a
- getHeader :: a -> ByteString -> Maybe ByteString
+ getHeader :: a -> String -> Maybe String
getHeader a key
= fmap snd $ find (noCaseEq key . fst) (getHeaders a)
- deleteHeader :: a -> ByteString -> a
+ deleteHeader :: a -> String -> a
deleteHeader a key
= setHeaders a $ filter (not . noCaseEq key . fst) (getHeaders a)
- addHeader :: a -> ByteString -> ByteString -> a
+ addHeader :: a -> String -> String -> a
addHeader a key val
= setHeaders a $ (getHeaders a) ++ [(key, val)]
- setHeader :: a -> ByteString -> ByteString -> a
+ setHeader :: a -> String -> String -> a
setHeader a key val
= let list = getHeaders a
deleted = filter (not . noCaseEq key . fst) list
in
setHeaders a added
-noCaseEq :: ByteString -> ByteString -> Bool
-noCaseEq a b
- = (B.map toLower a) == (B.map toLower b)
+emptyHeaders :: Headers
+emptyHeaders = []
-emptyHeaders :: Headers
-emptyHeaders = []
\ No newline at end of file
+{-
+ message-header = field-name ":" [ field-value ]
+ field-name = token
+ field-value = *( field-content | LWS )
+ field-content = <field-value を構成し、*TEXT あるいは
+ token, separators, quoted-string を連結
+ したものから成る OCTET>
+
+ field-value の先頭および末尾にある LWS は全て削除され、それ以外の
+ LWS は單一の SP に變換される。
+-}
+headersP :: Parser Headers
+headersP = do xs <- many header
+ crlf
+ return xs
+ where
+ header :: Parser (String, String)
+ header = do name <- token
+ char ':'
+ -- FIXME: これは多少インチキだが、RFC 2616 のこの部分
+ -- の記述はひどく曖昧であり、この動作が本當に間違って
+ -- ゐるのかどうかも良く分からない。例へば
+ -- quoted-string の内部にある空白は纏めていいのか惡い
+ -- のか？直勸的には駄目さうに思へるが、そんな記述は見
+ -- 付からない。
+ contents <- many (lws <|> many1 text)
+ crlf
+ let value = foldr (++) "" contents
+ return (name, normalize value)
+
+ normalize :: String -> String
+ normalize = trimBody . trim isWhiteSpace
+
+ trimBody = nubBy (\ a b -> a == ' ' && b == ' ')
+ . map (\ c -> if isWhiteSpace c
+ then ' '
+ else c)
+
+
+hPutHeaders :: Handle -> Headers -> IO ()
+hPutHeaders h hds = mapM_ putH hds >> hPutStr h "\r\n"
+ where
+ putH (name, value) = do hPutStr h name
+ hPutStr h ": "
+ hPutStr h value
+ hPutStr h "\r\n"
module Network.HTTP.Lucu.HttpVersion
( HttpVersion(..)
- , httpVersionP -- Parser HttpVersion
+ , httpVersionP -- Parser HttpVersion
+ , hPutHttpVersion -- Handle -> HttpVersion -> IO ()
)
where
import qualified Data.ByteString.Lazy.Char8 as B
import Data.ByteString.Lazy.Char8 (ByteString)
import Network.HTTP.Lucu.Parser
+import System.IO
data HttpVersion = HttpVersion Int Int
- deriving (Show, Eq)
+ deriving (Eq)
+
+instance Show HttpVersion where
+ show (HttpVersion maj min) = "HTTP/" ++ show maj ++ "." ++ show min
instance Ord HttpVersion where
(HttpVersion majA minA) `compare` (HttpVersion majB minB)
minor <- many1 digit
return $ HttpVersion (read major) (read minor)
+
+hPutHttpVersion :: Handle -> HttpVersion -> IO ()
+hPutHttpVersion h (HttpVersion maj min)
+ = do hPutStr h "HTTP/"
+ hPutStr h (show maj)
+ hPutChar h '.'
+ hPutStr h (show min)
\ No newline at end of file
module Network.HTTP.Lucu.Httpd
- ( ResourceTable
- , mkResourceTable -- [ ([String], Resource ()) ] -> ResourceTable
- , runHttpd -- Config -> ResourceTable -> IO ()
+ ( runHttpd -- Config -> ResTree -> IO ()
)
where
import Control.Concurrent
+import Control.Concurrent.STM
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.Interaction
+import Network.HTTP.Lucu.RequestReader
import Network.HTTP.Lucu.Resource
-import Network.HTTP.Lucu.Response
+import Network.HTTP.Lucu.ResponseWriter
import System.IO
-type ResourceTable = Map [String] (Resource ())
-
-
-mkResourceTable :: [ ([String], Resource ()) ] -> ResourceTable
-mkResourceTable = M.fromList
-
-
-runHttpd :: Config -> ResourceTable -> IO ()
+runHttpd :: Config -> ResTree -> IO ()
runHttpd cnf table
= withSocketsDo $
do so <- listenOn (cnfServerPort cnf)
where
loop :: Socket -> IO ()
loop so
- = do (h, host, port) <- accept so
- forkIO $ service h host port
+ = do (h, host, _) <- accept so
+ tQueue <- newInteractionQueue
+ forkIO $ requestReader cnf table h host tQueue
+ forkIO $ responseWriter h tQueue
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.Interaction
+ ( Interaction(..)
+ , InteractionState(..)
+ , InteractionQueue
+ , newInteractionQueue -- IO InteractionQueue
+ , newInteraction -- HostName -> Maybe Request -> IO Interaction
+ )
+ where
+
+import Control.Concurrent.STM
+import qualified Data.ByteString.Lazy.Char8 as B
+import Data.ByteString.Lazy.Char8 (ByteString)
+import qualified Data.Sequence as S
+import Data.Sequence (Seq)
+import Network
+import Network.HTTP.Lucu.Request
+import Network.HTTP.Lucu.Response
+
+data Interaction = Interaction {
+ itrRemoteHost :: HostName
+ , itrRequest :: Maybe Request
+ , itrResponse :: TVar (Maybe Response)
+
+ , itrRequestHasBody :: TVar Bool
+ , itrRequestBodyLength :: TVar (Maybe Integer) -- chunked の場合は不明
+ , itrRequestIsChunked :: TVar Bool
+ , itrReceivedBody :: TVar ByteString -- Resource が受領した部分は削除される
+
+ , itrExpectedContinue :: TVar Bool
+
+ , itrWillChunkBody :: TVar Bool
+ , itrWillDiscardBody :: TVar Bool
+ , itrWillClose :: TVar Bool
+ , itrBodyToSend :: TVar ByteString
+
+ , itrState :: TVar InteractionState
+
+ , itrWroteContinue :: TVar Bool
+ , itrWroteHeader :: TVar Bool
+ }
+
+-- Resource の視點で見た時の状態。常に上から下へ行き、逆行しない。初期
+-- 状態は ExaminingHeader (リクエストボディが有る時) または
+-- DecidingHeader (無い時)。終了状態は常に Done
+data InteractionState = ExaminingHeader
+ | GettingBody
+ | DecidingHeader
+ | DecidingBody
+ | Done
+ deriving (Show, Eq, Ord)
+
+type InteractionQueue = TVar (Seq Interaction)
+
+
+newInteractionQueue :: IO InteractionQueue
+newInteractionQueue = newTVarIO S.empty
+
+
+newInteraction :: HostName -> Maybe Request -> IO Interaction
+newInteraction host req
+ = do responce <- newTVarIO Nothing
+
+ requestHasBody <- newTVarIO False
+ requestBodyLength <- newTVarIO Nothing
+ requestIsChunked <- newTVarIO False
+ receivedBody <- newTVarIO B.empty
+
+ expectedContinue <- newTVarIO False
+
+ willChunkBody <- newTVarIO False
+ willDiscardBody <- newTVarIO False
+ willClose <- newTVarIO False
+ bodyToSend <- newTVarIO B.empty
+
+ state <- newTVarIO undefined
+
+ wroteContinue <- newTVarIO False
+ wroteHeader <- newTVarIO False
+
+ return $ Interaction {
+ itrRemoteHost = host
+ , itrRequest = req
+ , itrResponse = responce
+
+ , itrRequestHasBody = requestHasBody
+ , itrRequestBodyLength = requestBodyLength
+ , itrRequestIsChunked = requestIsChunked
+ , itrReceivedBody = receivedBody
+
+ , itrExpectedContinue = expectedContinue
+
+ , itrWillChunkBody = willChunkBody
+ , itrWillDiscardBody = willDiscardBody
+ , itrWillClose = willClose
+ , itrBodyToSend = bodyToSend
+
+ , itrState = state
+
+ , itrWroteContinue = wroteContinue
+ , itrWroteHeader = wroteHeader
+ }
, many1 -- Parser a -> Parser [a]
, manyTill -- Parser a -> Parser end -> Parser [a]
, many1Till -- Parser a -> Parser end -> Parser [a]
+ , option -- a -> Parser a -> Parser a
, sp -- Parser Char
+ , ht -- Parser Char
, crlf -- Parser String
)
where
return x
+option :: a -> Parser a -> Parser a
+option def p = p <|> return def
+
+
sp :: Parser Char
sp = char ' '
+ht :: Parser Char
+ht = char '\t'
+
+
crlf :: Parser String
crlf = string "\x0d\x0a"
module Network.HTTP.Lucu.Parser.Http
( isCtl -- Char -> Bool
, isSeparator -- Char -> Bool
- , token -- Parser Char
+ , isChar -- Char -> Bool
+ , token -- Parser String
+ , lws -- Parser String
+ , text -- Parser Char
+ , separator -- Parser Char
+ , quotedStr -- Parser String
)
where
isSeparator c = elem c "()<>@,;:\\\"/[]?={} \t"
-token :: Parser Char
-token = satisfy (\ c -> not (isCtl c || isSeparator c))
+isChar :: Char -> Bool
+isChar c
+ | c <= '\x7f' = True
+ | otherwise = False
+
+
+token :: Parser String
+token = many1 $ satisfy (\ c -> not (isCtl c || isSeparator c))
+
+
+lws :: Parser String
+lws = do s <- option "" crlf
+ xs <- many1 (sp <|> ht)
+ return (s ++ xs)
+
+
+text :: Parser Char
+text = satisfy (\ c -> not (isCtl c))
+
+
+separator :: Parser Char
+separator = satisfy isSeparator
+
+
+quotedStr :: Parser String
+quotedStr = do char '"'
+ xs <- many (qdtext <|> quotedPair)
+ char '"'
+ return $ foldr (++) "" (["\""] ++ xs ++ ["\""])
+ where
+ qdtext = char '"' >> fail ""
+ <|>
+ do c <- text
+ return [c]
+
+ quotedPair = do q <- char '\\'
+ c <- satisfy isChar
+ return [q, c]
--- /dev/null
+module Network.HTTP.Lucu.Postprocess
+ ( postprocess -- Interaction -> STM ()
+ , completeUnconditionalHeaders -- Response -> IO Response
+ )
+ where
+
+import Control.Concurrent.STM
+import Control.Monad
+import Data.Char
+import Data.Maybe
+import GHC.Conc (unsafeIOToSTM)
+import Network.HTTP.Lucu.Headers
+import Network.HTTP.Lucu.HttpVersion
+import Network.HTTP.Lucu.Interaction
+import Network.HTTP.Lucu.RFC1123DateTime
+import Network.HTTP.Lucu.Request
+import Network.HTTP.Lucu.Response
+import Network.HTTP.Lucu.Utils
+import System.Time
+
+{-
+
+ * Response が未設定なら、HTTP/1.1 500 Internal Server Error にする。
+
+ * Content-Length があれば、それを削除する。
+
+ * HTTP/1.1 であり、且つ body を持つ事が出來る時、Transfer-Encoding の
+ 最後の要素が chunked でなければ 500 Internal Error にする。
+ Transfer-Encoding が未設定であれば、chunked に設定する。
+
+ * HTTP/1.0 なのに Transfer-Encoding が設定濟なら 500 Internal Server
+ Error にする。但し identity だけは許す。
+
+ * body を持つ事が出來る時、Content-Type が無ければ
+ application/octet-stream にする。出來ない時、HEAD でなければ
+ Content-Type を削除する。
+
+ * body を持つ事が出來ない時、body 破棄フラグを立てる。
+
+ * Connection: close が設定されてゐる時、切斷フラグを立てる。
+
+ * 切斷フラグが立ってゐる時、Connection: close を設定する。
+
+ * Server が無ければ設定。
+
+ * Date が無ければ設定。
+
+-}
+
+{- Postprocess は body を補完した後で實行する事 -}
+
+postprocess :: Interaction -> STM ()
+postprocess itr
+ = do res <- readTVar (itrResponse itr)
+
+ when (res == Nothing)
+ $ setStatus itr InternalServerError
+
+ when (itrRequest itr /= Nothing)
+ $ relyOnRequest itr
+
+ do oldRes <- readTVar (itrResponse itr)
+ newRes <- unsafeIOToSTM $ completeUnconditionalHeaders $ fromJust oldRes
+ setRes itr newRes
+ where
+ relyOnRequest itr
+ = do resM <- readTVar (itrResponse itr)
+
+ let req = fromJust $ itrRequest itr
+ reqVer = reqVersion req
+ res = fromJust resM
+ status = resStatus res
+ canHaveBody = if reqMethod req == HEAD then
+ False
+ else
+ isInformational status ||
+ status == NoContent ||
+ status == ResetContent ||
+ status == NotModified
+
+ setRes itr (deleteHeader res "Content-Length")
+
+ if canHaveBody then
+ do if reqVer == HttpVersion 1 1 then
+
+ case getHeader res "Transfer-Encoding" of
+ Nothing -> setRes itr (setHeader res "Transfer-Encoding" "chunked")
+ Just te -> let teList = [trim isWhiteSpace x
+ | x <- splitBy (== ',') (map toLower te)]
+ in
+ when (teList == [] || last teList /= "chunked")
+ $ setStatus itr InternalServerError
+ else
+ case getHeader res "Transfer-Encoding" of
+ Nothing -> return ()
+ Just "identity" -> return ()
+ _ -> setStatus itr InternalServerError
+
+ when (getHeader res "Content-Type" == Nothing)
+ $ setRes itr (setHeader res "Content-Type" "application/octet-stream")
+ else
+ -- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す
+ do setRes itr (deleteHeader res "Transfer-Encoding")
+ when (reqMethod req /= HEAD)
+ $ setRes itr (deleteHeader res "Content-Type")
+
+ if fmap (map toLower) (getHeader res "Connection") == Just "close" then
+ writeTVar (itrWillClose itr) True
+ else
+ setRes itr (setHeader res "Connection" "close")
+
+ when (reqMethod req == HEAD || not canHaveBody)
+ $ writeTVar (itrWillDiscardBody itr) True
+
+ setStatus itr status
+ = writeTVar (itrResponse itr) (Just $ Response {
+ resVersion = HttpVersion 1 1
+ , resStatus = status
+ , resHeaders = []
+ })
+
+ setRes itr res
+ = writeTVar (itrResponse itr) (Just res)
+
+
+completeUnconditionalHeaders :: Response -> IO Response
+completeUnconditionalHeaders res
+ = return res >>= compServer >>= compDate >>= return
+ where
+ compServer res
+ = case getHeader res "Server" of
+ Nothing -> return $ addHeader res "Server" "Lucu/1.0"
+ Just _ -> return res
+
+ compDate res
+ = case getHeader res "Date" of
+ Nothing -> do time <- getClockTime
+ return $ addHeader res "Date" $ formatHTTPDateTime time
+ Just _ -> return res
\ No newline at end of file
--- /dev/null
+module Network.HTTP.Lucu.Preprocess
+ ( preprocess -- Interaction -> STM ()
+ )
+ where
+
+import Control.Concurrent.STM
+import Control.Monad
+import Data.Char
+import Data.Maybe
+import Network.HTTP.Lucu.Headers
+import Network.HTTP.Lucu.HttpVersion
+import Network.HTTP.Lucu.Interaction
+import Network.HTTP.Lucu.Request
+import Network.HTTP.Lucu.Response
+import Network.HTTP.Lucu.Utils
+import Network.URI
+
+{-
+
+ * Expect: に問題があった場合は 417 Expectation Failed に設定。
+ 100-continue 以外のものは全部 417 に。
+
+ * Transfer-Encoding: に問題があったら 501 Not Implemented にする。具
+ 体的には、identity でも chunked でもなければ 501 Not Implemented に
+ する。
+
+ * HTTP/1.1 リクエストであり、URI にホスト名が無く、Host: ヘッダも無い
+ 場合には 400 Bad Request にする。
+
+ * メソッドが GET, HEAD, POST, PUT, DELETE の何れでもない場合は 501
+ Not Implemented にする。
+
+ * HTTP/1.0 でも HTTP/1.1 でもないリクエストに對しては 505 HTTP
+ Version Not Supported を返す。
+
+ * POST または PUT に Content-Length も Transfer-Encoding も無い時は、
+ 411 Length Required にする。
+
+ * Content-Length の値が數値でなかったり負だったりしたら 400 Bad
+ Request にする。
+
+ * willDiscardBody その他の變數を設定する。
+
+-}
+
+import GHC.Conc (unsafeIOToSTM)
+
+preprocess :: Interaction -> STM ()
+preprocess itr
+ = do let req = fromJust $ itrRequest itr
+ reqVer = reqVersion req
+
+ if reqVer /= HttpVersion 1 0 &&
+ reqVer /= HttpVersion 1 1 then
+
+ do setStatus itr HttpVersionNotSupported
+ writeTVar (itrWillClose itr) True
+
+ else
+ do if reqVer == HttpVersion 1 0 then
+ -- HTTP/1.0 では Keep-Alive できない
+ writeTVar (itrWillClose itr) True
+ else
+ -- URI または Host: ヘッダのどちらかにホストが無ければ
+ -- ならない。
+ when (uriAuthority (reqURI req) == Nothing &&
+ getHeader req "Host" == Nothing)
+ $ setStatus itr BadRequest
+
+ case reqMethod req of
+ GET -> return ()
+ HEAD -> writeTVar (itrWillDiscardBody itr) True
+ POST -> ensureHavingBody itr
+ PUT -> ensureHavingBody itr
+ _ -> setStatus itr NotImplemented
+
+ mapM_ (preprocessHeader itr) (reqHeaders req)
+ where
+ ensureHavingBody itr
+ = let req = fromJust $ itrRequest itr
+ in
+ if getHeader req "Content-Length" == Nothing &&
+ getHeader req "Transfer-Encoding" == Nothing then
+
+ setStatus itr LengthRequired
+ else
+ writeTVar (itrRequestHasBody itr) True
+
+ setStatus itr status
+ = writeTVar (itrResponse itr) (Just $ Response {
+ resVersion = HttpVersion 1 1
+ , resStatus = status
+ , resHeaders = []
+ })
+
+ preprocessHeader itr (name, value)
+ = case map toLower name of
+
+ "expect"
+ -> if value `noCaseEq` "100-continue" then
+ writeTVar (itrExpectedContinue itr) True
+ else
+ setStatus itr ExpectationFailed
+
+ "transfer-encoding"
+ -> case map toLower value of
+ "identity" -> return ()
+ "chunked" -> writeTVar (itrRequestIsChunked itr) True
+ _ -> setStatus itr NotImplemented
+
+ "content-length"
+ -> if all isDigit value then
+ writeTVar (itrRequestBodyLength itr) (Just $ read value)
+ else
+ setStatus itr BadRequest
+
+ "connection"
+ -> case map toLower value of
+ "close" -> writeTVar (itrWillClose itr) True
+ _ -> return ()
+
+ _ -> return ()
\ No newline at end of file
--- /dev/null
+module Network.HTTP.Lucu.RFC1123DateTime
+ ( formatRFC1123DateTime -- CalendarTime -> String
+ , formatHTTPDateTime -- ClockTime -> String
+ , parseHTTPDateTime -- String -> Maybe ClockTime
+ )
+ where
+
+import Control.Monad
+import System.Time
+import System.Locale
+import Text.ParserCombinators.Parsec
+import Text.Printf
+
+month = ["Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"]
+week = ["Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"]
+
+formatRFC1123DateTime :: CalendarTime -> String
+formatRFC1123DateTime time
+ = printf "%s, %02d %s %04d %02d:%02d:%02d %s"
+ (week !! fromEnum (ctWDay time))
+ (ctDay time)
+ (month !! fromEnum (ctMonth time))
+ (ctYear time)
+ (ctHour time)
+ (ctMin time)
+ (ctSec time)
+ (ctTZName time)
+
+
+formatHTTPDateTime :: ClockTime -> String
+formatHTTPDateTime = formatRFC1123DateTime . (\cal -> cal { ctTZName = "GMT" }) . toUTCTime
+
+
+parseHTTPDateTime :: String -> Maybe ClockTime
+parseHTTPDateTime src
+ = case parse httpDateTime "" src of
+ Right ct -> Just ct
+ Left err -> Nothing
+
+httpDateTime :: Parser ClockTime
+httpDateTime = do foldl (<|>) (unexpected "") (map (try . string) week)
+ char ','
+ char ' '
+ day <- liftM read (count 2 digit)
+ char ' '
+ mon <- foldl (<|>) (unexpected "") (map tryEqToFst (zip month [1..]))
+ char ' '
+ year <- liftM read (count 4 digit)
+ char ' '
+ hour <- liftM read (count 2 digit)
+ char ':'
+ min <- liftM read (count 2 digit)
+ char ':'
+ sec <- liftM read (count 2 digit)
+ char ' '
+ string "GMT"
+ eof
+ return $ toClockTime $ CalendarTime {
+ ctYear = year
+ , ctMonth = toEnum (mon - 1)
+ , ctDay = day
+ , ctHour = hour
+ , ctMin = min
+ , ctSec = sec
+ , ctPicosec = 0
+ , ctTZ = 0
+ , ctWDay = undefined
+ , ctYDay = undefined
+ , ctTZName = undefined
+ , ctIsDST = undefined
+ }
+ where
+ tryEqToFst :: (String, a) -> Parser a
+ tryEqToFst (str, a) = try $ string str >> return a
+
\ No newline at end of file
module Network.HTTP.Lucu.Request
( Method(..)
- , Request
+ , Request(..)
, requestP -- Parser Request
)
where
data Method = OPTIONS
| GET
| HEAD
+ | POST
| PUT
| DELETE
| TRACE
, reqURI :: URI
, reqVersion :: HttpVersion
, reqHeaders :: Headers
- , reqBody :: Maybe ByteString
}
- deriving (Show)
+ deriving (Show, Eq)
instance HasHeaders Request where
getHeaders = reqHeaders
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
+ headers <- headersP
+ return Request {
+ reqMethod = method
+ , reqURI = uri
+ , reqVersion = version
+ , reqHeaders = headers
+ }
requestLineP :: Parser (Method, URI, HttpVersion)
methodP = (let methods = [ ("OPTIONS", OPTIONS)
, ("GET" , GET )
, ("HEAD" , HEAD )
+ , ("POST" , POST )
, ("PUT" , PUT )
, ("DELETE" , DELETE )
, ("TRACE" , TRACE )
in foldl (<|>) (fail "") $ map (\ (str, mth)
-> string str >> return mth) methods)
<|>
- many1 token >>= return . ExtensionMethod
+ token >>= return . ExtensionMethod
uriP :: Parser URI
--- /dev/null
+module Network.HTTP.Lucu.RequestReader
+ ( requestReader -- Config -> ResTree -> Handle -> HostName -> InteractionQueue -> IO ()
+ )
+ where
+
+import Control.Concurrent.STM
+import Control.Exception
+import Control.Monad
+import qualified Data.ByteString.Lazy.Char8 as B
+import Data.ByteString.Lazy.Char8 (ByteString)
+import Data.Map as M
+import Data.Map (Map)
+import Data.Maybe
+import qualified Data.Sequence as S
+import Data.Sequence (Seq, (<|), ViewR(..))
+import Network
+import Network.HTTP.Lucu.Config
+import Network.HTTP.Lucu.HttpVersion
+import Network.HTTP.Lucu.Interaction
+import Network.HTTP.Lucu.Parser
+import Network.HTTP.Lucu.Postprocess
+import Network.HTTP.Lucu.Preprocess
+import Network.HTTP.Lucu.Request
+import Network.HTTP.Lucu.Response
+import Network.HTTP.Lucu.Resource
+import Prelude hiding (catch)
+import System.IO
+
+import GHC.Conc (unsafeIOToSTM)
+
+requestReader :: Config -> ResTree -> Handle -> HostName -> InteractionQueue -> IO ()
+requestReader cnf tree h host tQueue
+ = do input <- B.hGetContents h
+ catch (acceptRequest input) $ \ exc ->
+ case exc of
+ IOException _ -> return ()
+ _ -> print exc
+ where
+ acceptRequest :: ByteString -> IO ()
+ acceptRequest input
+ -- キューに最大パイプライン深度以上のリクエストが溜まってゐる
+ -- 時は、それが限度以下になるまで待つ。
+ = do action
+ <- atomically $
+ do queue <- readTVar tQueue
+ when (S.length queue >= cnfMaxPipelineDepth cnf)
+ retry
+
+ -- リクエストを讀む。パースできない場合は直ち
+ -- に 400 Bad Request 應答を設定し、それを出力
+ -- してから切斷するやうに ResponseWriter に通
+ -- 知する。
+ case parse requestP input of
+ Nothing -> return acceptNonparsableRequest
+ Just (req, input') -> return $ acceptParsableRequest req input'
+ action
+
+ acceptNonparsableRequest :: IO ()
+ acceptNonparsableRequest
+ = do itr <- newInteraction host Nothing
+ let res = Response {
+ resVersion = HttpVersion 1 1
+ , resStatus = BadRequest
+ , resHeaders = []
+ }
+ atomically $ do writeTVar (itrResponse itr) $ Just res
+ writeTVar (itrWillClose itr) True
+ writeTVar (itrState itr) Done
+ postprocess itr
+ enqueue itr
+
+ acceptParsableRequest :: Request -> ByteString -> IO ()
+ acceptParsableRequest req input'
+ = do itr <- newInteraction host (Just req)
+ action
+ <- atomically $
+ do preprocess itr
+ res <- readTVar (itrResponse itr)
+ if fmap isError (fmap resStatus res) == Just True then
+ acceptSemanticallyInvalidRequest itr input'
+ else
+ case findResource tree $ (reqURI . fromJust . itrRequest) itr of
+ Nothing -- Resource が無かった
+ -> acceptRequestForNonexistentResource itr input'
+
+ Just rsrcDef -- あった
+ -> acceptRequestForExistentResource itr input' rsrcDef
+ action
+
+ acceptSemanticallyInvalidRequest :: Interaction -> ByteString -> STM (IO ())
+ acceptSemanticallyInvalidRequest itr input
+ = do writeTVar (itrState itr) Done
+ postprocess itr
+ enqueue itr
+ return $ acceptRequest input
+
+ acceptRequestForNonexistentResource :: Interaction -> ByteString -> STM (IO ())
+ acceptRequestForNonexistentResource itr input
+ = do let res = Response {
+ resVersion = HttpVersion 1 1
+ , resStatus = NotFound
+ , resHeaders = []
+ }
+ writeTVar (itrResponse itr) $ Just res
+ writeTVar (itrState itr) Done
+ postprocess itr
+ enqueue itr
+ return $ acceptRequest input
+
+ acceptRequestForExistentResource :: Interaction -> ByteString -> ResourceDef -> STM (IO ())
+ acceptRequestForExistentResource itr input rsrcDef
+ = do requestHasBody <- readTVar (itrRequestHasBody itr)
+ writeTVar (itrState itr) (if requestHasBody
+ then ExaminingHeader
+ else DecidingHeader)
+ enqueue itr
+ return $ do runResource rsrcDef itr
+ if requestHasBody then
+ observeRequest itr input
+ else
+ acceptRequest input
+
+ observeRequest :: Interaction -> ByteString -> IO ()
+ observeRequest itr input = fail "FIXME: Not Implemented"
+
+ enqueue :: Interaction -> STM ()
+ enqueue itr = do queue <- readTVar tQueue
+ writeTVar tQueue (itr <| queue)
\ No newline at end of file
module Network.HTTP.Lucu.Resource
- ( Resource
+ ( ResourceDef(..)
+ , Resource
+ , ResTree
+ , mkResTree -- [ ([String], ResourceDef) ] -> ResTree
+ , findResource -- ResTree -> URI -> Maybe ResourceDef
+ , runResource -- ResourceDef -> Interaction -> IO ThreadId
)
where
-import Control.Monad.State
+import Control.Concurrent
+import Control.Monad.Reader
import qualified Data.ByteString.Lazy.Char8 as B
import Data.ByteString.Lazy.Char8 (ByteString)
+import Data.List
+import qualified Data.Map as M
+import Data.Map (Map)
+import Network.HTTP.Lucu.Interaction
+import Network.HTTP.Lucu.Utils
+import Network.URI
-data ResState = ResState -- FIXME
-type ResourceT m a = StateT ResState m a
+type Resource a = ReaderT Interaction IO a
-type Resource a = ResourceT IO a
+
+{- /aaa/bbb/ccc にアクセスされた時、もし /aaa/bbb に貪欲なリソースがあ
+ れば、假に /aaa/bbb/ccc に何らかのリソースがあったとしても必ず
+ /aaa/bbb が撰ばれる。/aaa/bbb のリソースが貪欲でなければ、それは無視
+ される。 -}
+data ResourceDef = ResourceDef {
+ resUsesNativeThread :: Bool
+ , resIsGreedy :: Bool
+ , resResource :: Resource ()
+ }
+type ResTree = ResNode -- root だから Map ではない
+type ResSubtree = Map String ResNode
+data ResNode = ResNode (Maybe ResourceDef) ResSubtree
+
+
+mkResTree :: [ ([String], ResourceDef) ] -> ResTree
+mkResTree list = processRoot list
+ where
+ processRoot :: [ ([String], ResourceDef) ] -> ResTree
+ processRoot list
+ = let (roots, nonRoots) = partition (\ (path, _) -> path == []) list
+ children = processNonRoot nonRoots
+ in
+ if null roots then
+ -- / にリソースが定義されない。/foo とかにはあるかも。
+ ResNode Nothing children
+ else
+ -- / がある。
+ let (_, def) = last roots
+ in
+ ResNode (Just def) children
+
+ processNonRoot :: [ ([String], ResourceDef) ] -> ResSubtree
+ processNonRoot list
+ = let subtree = M.fromList [(name, node name)
+ | name <- childNames]
+ childNames = [name | (name:_, _) <- list]
+ node name = let defs = [def | (path, def) <- list, path == [name]]
+ in
+ if null defs then
+ -- この位置にリソースが定義されない。
+ -- もっと下にはあるかも。
+ ResNode Nothing children
+ else
+ -- この位置にリソースがある。
+ ResNode (Just $ last defs) children
+ children = processNonRoot [(path, def)
+ | (_:path, def) <- list, not (null path)]
+ in
+ subtree
+
+
+findResource :: ResTree -> URI -> Maybe ResourceDef
+findResource (ResNode rootDefM subtree) uri
+ = let pathStr = uriPath uri
+ path = [x | x <- splitBy (== '/') pathStr, x /= ""]
+ in
+ if null path then
+ rootDefM
+ else
+ walkTree subtree path
+ where
+ walkTree :: ResSubtree -> [String] -> Maybe ResourceDef
+
+ walkTree subtree (name:[])
+ = case M.lookup name subtree of
+ Nothing -> Nothing
+ Just (ResNode defM _) -> defM
+
+ walkTree subtree (x:xs)
+ = case M.lookup x subtree of
+ Nothing -> Nothing
+ Just (ResNode defM children) -> case defM of
+ Just (ResourceDef { resIsGreedy = True })
+ -> defM
+ _ -> walkTree children xs
+
+
+runResource :: ResourceDef -> Interaction -> IO ThreadId
+runResource def itr = fork $ runReaderT rsrc itr -- FIXME: 例外をcatch
+ where
+ fork = if (resUsesNativeThread def)
+ then forkOS
+ else forkIO
+ rsrc = resResource def
\ No newline at end of file
module Network.HTTP.Lucu.Response
( StatusCode(..)
, Response(..)
+ , hPutResponse -- Handle -> Response -> IO ()
+ , isInformational -- StatusCode -> Bool
+ , isError -- StatusCode -> Bool
)
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 System.IO
+import Text.Printf
data StatusCode = Continue
| SwitchingProtocols
| GatewayTimeout
| HttpVersionNotSupported
| InsufficientStorage
+ deriving (Eq)
+
+instance Show StatusCode where
+ show sc = let (num, msg) = statusCode sc
+ in
+ printf "%03d %s" num msg
+
data Response = Response {
resVersion :: HttpVersion
, resStatus :: StatusCode
, resHeaders :: Headers
- , resBody :: Maybe ByteString
}
+ deriving (Show, Eq)
instance HasHeaders Response where
getHeaders = resHeaders
setHeaders res hdr = res { resHeaders = hdr }
+
+
+hPutResponse :: Handle -> Response -> IO ()
+hPutResponse h res = do hPutHttpVersion h (resVersion res)
+ hPutChar h ' '
+ hPutStatus h (resStatus res)
+ hPutStr h "\r\n"
+ hPutHeaders h (resHeaders res)
+
+hPutStatus :: Handle -> StatusCode -> IO ()
+hPutStatus h sc = let (num, msg) = statusCode sc
+ in
+ hPrintf h "%03d %s" num msg
+
+
+isInformational :: StatusCode -> Bool
+isInformational sc = let (num, _) = statusCode sc
+ in num < 200
+
+isError :: StatusCode -> Bool
+isError sc = let (num, _) = statusCode sc
+ in num >= 400
+
+
+statusCode :: StatusCode -> (Int, String)
+statusCode Continue = (100, "Continue")
+statusCode SwitchingProtocols = (101, "Switching Protocols")
+statusCode Processing = (102, "Processing")
+--
+statusCode Ok = (200, "OK")
+statusCode Created = (201, "Created")
+statusCode Accepted = (202, "Accepted")
+statusCode NonAuthoritativeInformation = (203, "Non Authoritative Information")
+statusCode NoContent = (204, "No Content")
+statusCode ResetContent = (205, "Reset Content")
+statusCode PartialContent = (206, "Partial Content")
+statusCode MultiStatus = (207, "Multi Status")
+--
+statusCode MultipleChoices = (300, "Multiple Choices")
+statusCode MovedPermanently = (301, "Moved Permanently")
+statusCode Found = (302, "Found")
+statusCode SeeOther = (303, "See Other")
+statusCode NotModified = (304, "Not Modified")
+statusCode UseProxy = (305, "Use Proxy")
+statusCode TemporaryRedirect = (306, "Temporary Redirect")
+--
+statusCode BadRequest = (400, "Bad Request")
+statusCode Unauthorized = (401, "Unauthorized")
+statusCode PaymentRequired = (402, "Payment Required")
+statusCode Forbidden = (403, "Forbidden")
+statusCode NotFound = (404, "Not Found")
+statusCode MethodNotAllowed = (405, "Method Not Allowed")
+statusCode NotAcceptable = (406, "Not Acceptable")
+statusCode ProxyAuthenticationRequired = (407, "Proxy Authentication Required")
+statusCode RequestTimeout = (408, "Request Timeout")
+statusCode Conflict = (409, "Conflict")
+statusCode Gone = (410, "Gone")
+statusCode LengthRequired = (411, "Length Required")
+statusCode PreconditionFailed = (412, "Precondition Failed")
+statusCode RequestEntityTooLarge = (413, "Request Entity Too Large")
+statusCode RequestURITooLarge = (414, "Request URI Too Large")
+statusCode UnsupportedMediaType = (415, "Unsupported Media Type")
+statusCode RequestRangeNotSatisfiable = (416, "Request Range Not Satisfiable")
+statusCode ExpectationFailed = (417, "Expectation Failed")
+statusCode UnprocessableEntitiy = (422, "Unprocessable Entity")
+statusCode Locked = (423, "Locked")
+statusCode FailedDependency = (424, "Failed Dependency")
+--
+statusCode InternalServerError = (500, "Internal Server Error")
+statusCode NotImplemented = (501, "Not Implemented")
+statusCode BadGateway = (502, "Bad Gateway")
+statusCode ServiceUnavailable = (503, "Service Unavailable")
+statusCode GatewayTimeout = (504, "Gateway Timeout")
+statusCode HttpVersionNotSupported = (505, "HTTP Version Not Supported")
+statusCode InsufficientStorage = (507, "Insufficient Storage")
\ No newline at end of file
--- /dev/null
+module Network.HTTP.Lucu.ResponseWriter
+ ( responseWriter -- Handle -> InteractionQueue -> IO ()
+ )
+ where
+
+import qualified Data.ByteString.Lazy.Char8 as B
+import Data.ByteString.Lazy.Char8 (ByteString)
+import Control.Concurrent.STM
+import Control.Exception
+import Control.Monad
+import Data.Maybe
+import qualified Data.Sequence as S
+import Data.Sequence (Seq, ViewR(..))
+import Network.HTTP.Lucu.Interaction
+import Network.HTTP.Lucu.Response
+import Prelude hiding (catch)
+import System.IO
+
+import Debug.Trace
+
+
+responseWriter :: Handle -> InteractionQueue -> IO ()
+responseWriter h tQueue
+ = catch awaitSomethingToWrite $ \ exc
+ -> case exc of
+ IOException _ -> return ()
+ _ -> print exc
+ where
+ awaitSomethingToWrite :: IO ()
+ awaitSomethingToWrite
+ = do action
+ <- atomically $
+ do -- キューが空でなくなるまで待つ
+ queue <- readTVar tQueue
+ when (S.null queue)
+ retry
+ let _ :> itr = S.viewr queue
+
+ -- GettingBody 状態にあり、Continue が期待され
+ -- てゐて、それがまだ送信前なのであれば、
+ -- Continue を送信する。
+ state <- readTVar (itrState itr)
+
+ if state == GettingBody then
+ writeContinueIfNecessary itr
+ else
+ if state >= DecidingBody then
+ writeHeaderOrBodyIfNecessary itr
+ else
+ retry
+ action
+
+ writeContinueIfNecessary :: Interaction -> STM (IO ())
+ writeContinueIfNecessary itr
+ = do expectedContinue <- readTVar (itrExpectedContinue itr)
+ if expectedContinue then
+
+ do wroteContinue <- readTVar $ itrWroteContinue itr
+ if wroteContinue then
+ -- 既に Continue を書込み濟
+ retry
+ else
+ return $ writeContinue itr
+ else
+ retry
+
+ writeHeaderOrBodyIfNecessary :: Interaction -> STM (IO ())
+ writeHeaderOrBodyIfNecessary itr
+ -- DecidingBody 以降の状態にあり、まだヘッダを出力する前であ
+ -- れば、ヘッダを出力する。ヘッダ出力後であり、bodyToSend が
+ -- 空でなければ、それを出力する。空である時は、もし状態が
+ -- Done であれば後処理をする。
+ = do wroteHeader <- readTVar (itrWroteHeader itr)
+
+ if not wroteHeader then
+ return $ writeHeader itr
+ else
+ do bodyToSend <- readTVar (itrBodyToSend itr)
+
+ if B.null bodyToSend then
+ do state <- readTVar (itrState itr)
+
+ if state == Done then
+ return $ finalize itr
+ else
+ retry
+ else
+ return $ writeBodyChunk itr
+
+ writeContinue :: Interaction -> IO ()
+ writeContinue itr = fail "FIXME: not implemented"
+
+ writeHeader :: Interaction -> IO ()
+ writeHeader itr
+ = do res <- atomically $ do writeTVar (itrWroteHeader itr) True
+ readTVar (itrResponse itr)
+ hPutResponse h (fromJust res)
+ hFlush h
+ awaitSomethingToWrite
+
+ writeBodyChunk :: Interaction -> IO ()
+ writeBodyChunk itr = fail "FIXME: not implemented"
+
+ finishBodyChunk :: Interaction -> IO ()
+ finishBodyChunk itr = return () -- FIXME: not implemented
+
+ finalize :: Interaction -> IO ()
+ finalize itr
+ = do finishBodyChunk itr
+ willClose <- atomically $ do queue <- readTVar tQueue
+
+ let (remaining :> _) = S.viewr queue
+ writeTVar tQueue remaining
+
+ readTVar $ itrWillClose itr
+ if willClose then
+ hClose h
+ else
+ awaitSomethingToWrite
--- /dev/null
+module Network.HTTP.Lucu.Utils
+ ( splitBy -- (a -> Bool) -> [a] -> [[a]]
+ , trim -- (a -> Bool) -> [a] -> [a]
+ , noCaseEq -- String -> String -> Bool
+ , isWhiteSpace -- Char -> Bool
+ )
+ where
+
+import Data.Char
+import Data.List
+
+
+splitBy :: (a -> Bool) -> [a] -> [[a]]
+splitBy isSeparator src
+ = case break isSeparator src
+ of (last , [] ) -> last : []
+ (first, sep:rest) -> first : splitBy isSeparator rest
+
+
+trim :: (a -> Bool) -> [a] -> [a]
+trim p = trimTail . trimHead
+ where
+ trimHead = dropWhile p
+ trimTail = reverse . trimHead . reverse
+
+
+noCaseEq :: String -> String -> Bool
+noCaseEq a b
+ = (map toLower a) == (map toLower b)
+
+
+isWhiteSpace :: Char -> Bool
+isWhiteSpace = flip elem " \t\r\n"
import Network
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.Httpd
+import Network.HTTP.Lucu.Resource
main :: IO ()
main = let config = defaultConfig { cnfServerPort = PortNumber 9999 }
- resources = mkResourceTable []
+ resources = mkResTree []
in
runHttpd config resources
\ No newline at end of file
projects / Lucu.git / commitdiff