import qualified Data.Attoparsec.Lazy as LP
import qualified Data.ByteString as Strict
import qualified Data.ByteString.Lazy as Lazy
-import qualified Data.Strict.Maybe as S
+import Data.List
+import Data.Maybe
import Data.Monoid.Unicode
import qualified Data.Sequence as S
import Data.Sequence.Unicode hiding ((∅))
-- リクエストを讀む。パースできない場合は直ちに 400 Bad
-- Request 應答を設定し、それを出力してから切斷するやうに
-- ResponseWriter に通知する。
- case LP.parse requestP input of
+ case LP.parse request input of
LP.Done input' req → acceptParsableRequest ctx req input'
LP.Fail _ _ _ → acceptNonparsableRequest ctx
do rsrc ← findResource cResTree cFallbacks $ reqURI $ arRequest ar
case rsrc of
Nothing
- → do let ar' = ar { arInitialStatus = NotFound }
+ → do let ar' = ar {
+ arInitialStatus = fromStatusCode NotFound
+ }
acceptSemanticallyInvalidRequest ctx ar' input
Just (path, def)
→ acceptRequestForResource ctx ar input path def
= do cert ← hGetPeerCert cHandle
ni ← mkNormalInteraction cConfig cAddr cert ar rsrcPath
tid ← spawnResource rsrcDef ni
+ enqueue ctx ni
if reqMustHaveBody arRequest then
waitForReceiveBodyReq ctx ni tid input
else
→ Lazy.ByteString
→ IO ()
waitForReceiveBodyReq ctx ni@(NI {..}) rsrcTid input
- = case S.fromJust niReqBodyLength of
+ = case fromJust niReqBodyLength of
Chunked
→ waitForReceiveChunkedBodyReqForTheFirstTime ctx ni rsrcTid input
Fixed len
where
go ∷ Lazy.ByteString → ChunkReceivingState → IO ()
go input Initial
- = case LP.parse chunkHeaderP input of
+ = case LP.parse chunkHeader input of
LP.Done input' chunkLen
| chunkLen ≡ 0 → gotFinalChunk input'
| otherwise → gotChunk input' chunkLen
- LP.Fail _ _ msg
- → chunkWasMalformed rsrcTid
- $ "wasteAllChunks: chunkHeaderP: " ⧺ msg
+ LP.Fail _ eCtx e
+ → chunkWasMalformed rsrcTid eCtx e
+ "wasteAllChunks: chunkHeader"
go input (InChunk chunkLen)
= gotChunk input chunkLen
gotChunk input chunkLen
= let input' = Lazy.drop (fromIntegral chunkLen) input
in
- case LP.parse chunkFooterP input' of
+ case LP.parse chunkFooter input' of
LP.Done input'' _
→ go input'' Initial
- LP.Fail _ _ msg
- → chunkWasMalformed rsrcTid
- $ "wasteAllChunks: chunkFooterP: " ⧺ msg
+ LP.Fail _ eCtx e
+ → chunkWasMalformed rsrcTid eCtx e
+ "wasteAllChunks: chunkFooter"
gotFinalChunk ∷ Lazy.ByteString → IO ()
gotFinalChunk input
- = case LP.parse chunkTrailerP input of
+ = case LP.parse chunkTrailer input of
LP.Done input' _
→ acceptRequest ctx input'
- LP.Fail _ _ msg
- → chunkWasMalformed rsrcTid
- $ "wasteAllChunks: chunkTrailerP: " ⧺ msg
+ LP.Fail _ eCtx e
+ → chunkWasMalformed rsrcTid eCtx e
+ "wasteAllChunks: chunkTrailer"
readCurrentChunk ∷ HandleLike h
⇒ Context h
where
go ∷ Lazy.ByteString → ChunkReceivingState → IO ()
go input Initial
- = case LP.parse chunkHeaderP input of
+ = case LP.parse chunkHeader input of
LP.Done input' chunkLen
| chunkLen ≡ 0
→ gotFinalChunk input'
| otherwise
→ gotChunk input' chunkLen
- LP.Fail _ _ msg
- → chunkWasMalformed rsrcTid
- $ "readCurrentChunk: chunkHeaderP: " ⧺ msg
+ LP.Fail _ eCtx e
+ → chunkWasMalformed rsrcTid eCtx e
+ "readCurrentChunk: chunkHeader"
go input (InChunk chunkLen)
= gotChunk input chunkLen
chunkLen' = chunkLen - actualReadBytes
atomically $ putTMVar niReceivedBody block'
if chunkLen' ≡ 0 then
- case LP.parse chunkFooterP input' of
+ case LP.parse chunkFooter input' of
LP.Done input'' _
→ waitForReceiveChunkedBodyReq ctx ni rsrcTid input'' Initial
- LP.Fail _ _ msg
- → chunkWasMalformed rsrcTid
- $ "readCurrentChunk: chunkFooterP: " ⧺ msg
+ LP.Fail _ eCtx e
+ → chunkWasMalformed rsrcTid eCtx e
+ "readCurrentChunk: chunkFooter"
else
waitForReceiveChunkedBodyReq ctx ni rsrcTid input' $ InChunk chunkLen'
gotFinalChunk ∷ Lazy.ByteString → IO ()
gotFinalChunk input
= do atomically $ putTMVar niReceivedBody (∅)
- case LP.parse chunkTrailerP input of
+ case LP.parse chunkTrailer input of
LP.Done input' _
→ acceptRequest ctx input'
- LP.Fail _ _ msg
- → chunkWasMalformed rsrcTid
- $ "readCurrentChunk: chunkTrailerP: " ⧺ msg
+ LP.Fail _ eCtx e
+ → chunkWasMalformed rsrcTid eCtx e
+ "readCurrentChunk: chunkTrailer"
-chunkWasMalformed ∷ ThreadId → String → IO ()
-chunkWasMalformed tid msg
+chunkWasMalformed ∷ ThreadId → [String] → String → String → IO ()
+chunkWasMalformed tid eCtx e msg
= let abo = mkAbortion BadRequest [("Connection", "close")]
$ Just
- $ "chunkWasMalformed: " ⊕ T.pack msg
+ $ "chunkWasMalformed: "
+ ⊕ T.pack msg
+ ⊕ ": "
+ ⊕ T.pack (intercalate ", " eCtx)
+ ⊕ ": "
+ ⊕ T.pack e
in
throwTo tid abo