import Data.Sequence (Seq, (<|), ViewR(..))
import Network
import Network.HTTP.Lucu.Config
+import Network.HTTP.Lucu.DefaultPage
import Network.HTTP.Lucu.HttpVersion
import Network.HTTP.Lucu.Interaction
import Network.HTTP.Lucu.Parser
requestReader :: Config -> ResTree -> Handle -> HostName -> InteractionQueue -> IO ()
requestReader cnf tree h host tQueue
- = do input <- B.hGetContents h
- catch (acceptRequest input) $ \ exc ->
+ = do catch (acceptRequest B.empty) $ \ exc ->
case exc of
- IOException _ -> return ()
- _ -> print exc
+ IOException _ -> return ()
+ AsyncException ThreadKilled -> return ()
+ BlockedIndefinitely -> putStrLn "requestReader: blocked indefinitely"
+ _ -> print exc
where
acceptRequest :: ByteString -> IO ()
- acceptRequest input
+ acceptRequest soFar
-- キューに最大パイプライン深度以上のリクエストが溜まってゐる
-- 時は、それが限度以下になるまで待つ。
- = 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
+ = do atomically $ do queue <- readTVar tQueue
+ when (S.length queue >= cnfMaxPipelineDepth cnf)
+ retry
+
+ -- リクエストを讀む。パースできない場合は直ちに 400 Bad
+ -- Request 應答を設定し、それを出力してから切斷するやう
+ -- に ResponseWriter に通知する。
+ hWaitForInput h (-1)
+ chunk <- B.hGetNonBlocking h 1024
+
+ let input = B.append soFar chunk
+ case parse requestP input of
+ (Success req , input') -> acceptParsableRequest req input'
+ (IllegalInput, _ ) -> acceptNonparsableRequest BadRequest
+ (ReachedEOF , _ ) -> if B.length input >= 1024 * 1024 then
+ -- ヘッダ長過ぎ
+ acceptNonparsableRequest RequestEntityTooLarge
+ else
+ acceptRequest input
+
+ acceptNonparsableRequest :: StatusCode -> IO ()
+ acceptNonparsableRequest status
+ = do itr <- newInteraction cnf host Nothing
let res = Response {
resVersion = HttpVersion 1 1
- , resStatus = BadRequest
+ , resStatus = status
, resHeaders = []
}
- atomically $ do writeTVar (itrResponse itr) $ Just res
- writeTVar (itrWillClose itr) True
- writeTVar (itrState itr) Done
+ atomically $ do writeItr itr itrResponse $ Just res
+ writeItr itr itrWillClose True
+ writeItr itr itrState Done
+ writeDefaultPage itr
postprocess itr
enqueue itr
acceptParsableRequest :: Request -> ByteString -> IO ()
- acceptParsableRequest req input'
- = do itr <- newInteraction host (Just req)
+ acceptParsableRequest req soFar
+ = do itr <- newInteraction cnf host (Just req)
action
<- atomically $
do preprocess itr
- res <- readTVar (itrResponse itr)
- if fmap isError (fmap resStatus res) == Just True then
- acceptSemanticallyInvalidRequest itr input'
+ isErr <- readItrF itr itrResponse (isError . resStatus)
+ if isErr == Just True then
+ acceptSemanticallyInvalidRequest itr soFar
else
case findResource tree $ (reqURI . fromJust . itrRequest) itr of
Nothing -- Resource が無かった
- -> acceptRequestForNonexistentResource itr input'
+ -> acceptRequestForNonexistentResource itr soFar
Just rsrcDef -- あった
- -> acceptRequestForExistentResource itr input' rsrcDef
+ -> acceptRequestForExistentResource itr soFar rsrcDef
action
acceptSemanticallyInvalidRequest :: Interaction -> ByteString -> STM (IO ())
- acceptSemanticallyInvalidRequest itr input
- = do writeTVar (itrState itr) Done
+ acceptSemanticallyInvalidRequest itr soFar
+ = do writeItr itr itrState Done
+ writeDefaultPage itr
postprocess itr
enqueue itr
- return $ acceptRequest input
+ return $ acceptRequest soFar
acceptRequestForNonexistentResource :: Interaction -> ByteString -> STM (IO ())
- acceptRequestForNonexistentResource itr input
+ acceptRequestForNonexistentResource itr soFar
= do let res = Response {
resVersion = HttpVersion 1 1
, resStatus = NotFound
, resHeaders = []
}
- writeTVar (itrResponse itr) $ Just res
- writeTVar (itrState itr) Done
+ writeItr itr itrResponse $ Just res
+ writeItr itr itrState Done
+ writeDefaultPage itr
postprocess itr
enqueue itr
- return $ acceptRequest input
+ return $ acceptRequest soFar
acceptRequestForExistentResource :: Interaction -> ByteString -> ResourceDef -> STM (IO ())
- acceptRequestForExistentResource itr input rsrcDef
- = do requestHasBody <- readTVar (itrRequestHasBody itr)
- writeTVar (itrState itr) (if requestHasBody
- then ExaminingHeader
- else DecidingHeader)
+ acceptRequestForExistentResource itr soFar rsrcDef
+ = do requestHasBody <- readItr itr itrRequestHasBody id
+ writeItr itr itrState (if requestHasBody
+ then ExaminingHeader
+ else DecidingHeader)
enqueue itr
return $ do runResource rsrcDef itr
if requestHasBody then
- observeRequest itr input
+ observeRequest itr soFar
else
- acceptRequest input
+ acceptRequest soFar
observeRequest :: Interaction -> ByteString -> IO ()
- observeRequest itr input = fail "FIXME: Not Implemented"
+ observeRequest itr soFar
+ = do isChunked <- atomically $ readItr itr itrRequestIsChunked id
+ if isChunked then
+ observeChunkedRequest itr soFar
+ else
+ observeNonChunkedRequest itr soFar
+
+ observeChunkedRequest :: Interaction -> ByteString -> IO ()
+ observeChunkedRequest itr soFar
+ = fail "FIXME: not implemented"
+
+ observeNonChunkedRequest :: Interaction -> ByteString -> IO ()
+ observeNonChunkedRequest itr soFar
+ = fail "FIXME: not implemented"
+{-
+ = do action
+ <- atomically $
+ do wantedM <- readItr itr itrReqBodyWanted id
+ if wantedM == Nothing then
+ do wasteAll <- readItr itr itrReqBodyWasteAll id
+ if wasteAll then
+ return $ wasteAllReqBody itr soFar
+ else
+ retry
+ else
+ -- 受信要求が來た。
+ if B.empty soFar then
+ return $ receiveNonChunkedReqBody itr
+ else
+ do remaining <- readItr itr itrReqChunkRemaining fromJust
+
+ let wanted = fromJust wanted
+ (chunk, input') = B.splitAt (min wanted remaining) soFar
+ newRemaining = remaining - B.length chunk
+ isOver = newRemaining == 0
+
+ writeItr itr itrReqChunkRemaining newRemaining
+ writeItr itr itrReqChunkIsOver isOver
+ writeItr itr itrReqBodyWanted (if isOver then
+ Nothing
+ else
+ Just wanted)
+ writeItr itr itrReceivedBody chunk
+
+ if isOver then
+ return $ acceptRequest input'
+ else
+ return $ observeNonChunkedRequest itr input'
+ action
+
+ receiveNonChunkedReqBody :: Interaction -> IO ()
+ receiveNonChunkedReqBody itr
+ = do wanted <- atomically $ readItr itr itrReqBodyWanted fromJust
+ remaining <- atomically $ readItr itr itrReqChunkRemaining fromJust
+
+ hWaitForInput h (-1)
+ chunk <- B.hGetNonBlocking h (min wanted remaining)
+
+ let newRemaining = remaining - B.length chunk
+ isOver = newRemaining == 0
+
+ atomically $ do writeItr itr itrReqChunkRemaining newRemaining
+ writeItr itr itrReqChunkIsOver isOver
+ writeItr itr itrReqBodyWanted (if isOver then
+ Nothing
+ else
+ Just wanted)
+ writeItr itr itrReceivedBody chunk
+
+ if isOver then
+ return $ acceptRequest B.empty
+ else
+ return $ observeNonChunkedRequest itr B.empty
+
+
+ wasteAllReqBody :: Interaction -> ByteString -> IO ()
+ wasteAllReqBody itr soFar
+ =
+
+-}
enqueue :: Interaction -> STM ()
enqueue itr = do queue <- readTVar tQueue
projects / Lucu.git / blobdiff