- where
- acceptRequest :: ByteString -> IO ()
- acceptRequest input
- -- キューに最大パイプライン深度以上のリクエストが溜まってゐる
- -- 時は、それが限度以下になるまで待つ。
- = {-# SCC "acceptRequest" #-}
- do atomically $ do queue <- readTVar tQueue
- when (S.length queue >= cnfMaxPipelineDepth cnf)
- retry
-
- -- リクエストを讀む。パースできない場合は直ちに 400 Bad
- -- Request 應答を設定し、それを出力してから切斷するやう
- -- に ResponseWriter に通知する。
- case parse requestP input of
- (# Success req , input' #) -> acceptParsableRequest req input'
- (# IllegalInput, _ #) -> acceptNonparsableRequest BadRequest
- (# ReachedEOF , _ #) -> acceptNonparsableRequest BadRequest
-
- acceptNonparsableRequest :: StatusCode -> IO ()
- acceptNonparsableRequest status
- = {-# SCC "acceptNonparsableRequest" #-}
- do itr <- newInteraction cnf addr Nothing
- atomically $ do updateItr itr itrResponse
- $ \ res -> res {
- resStatus = status
- }
- writeItr itr itrWillClose True
- writeItr itr itrState Done
- writeDefaultPage itr
- postprocess itr
- enqueue itr
-
- acceptParsableRequest :: Request -> ByteString -> IO ()
- acceptParsableRequest req input
- = {-# SCC "acceptParsableRequest" #-}
- do itr <- newInteraction cnf addr (Just req)
- action
- <- atomically $
- do preprocess itr
- isErr <- readItr itr itrResponse (isError . resStatus)
- if isErr then
- acceptSemanticallyInvalidRequest itr input
- else
- do rsrcM <- unsafeIOToSTM $ findResource tree fbs $ reqURI req
- case rsrcM of
- Nothing -- Resource が無かった
- -> acceptRequestForNonexistentResource itr input