{-# LANGUAGE
- DoAndIfThenElse
+ CPP
+ , DoAndIfThenElse
, OverloadedStrings
, RecordWildCards
, ScopedTypeVariables
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 ((∅))
import qualified Data.Text as T
import Network.HTTP.Lucu.Abortion
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.Response
import Network.HTTP.Lucu.Resource.Internal
import Network.HTTP.Lucu.Resource.Tree
+import Network.HTTP.Lucu.Utils
import Network.Socket
import Prelude.Unicode
import System.IO (hPutStrLn, stderr)
acceptRequest (Context cnf tree fbs h port addr tQueue) input
`catches`
[ Handler handleAsyncE
- , Handler handleBIOS
, Handler handleOthers
]
+ `finally`
+ enqueue' tQueue EndOfInteraction
where
handleAsyncE ∷ AsyncException → IO ()
handleAsyncE ThreadKilled = return ()
handleAsyncE e = dump e
- handleBIOS ∷ BlockedIndefinitelyOnSTM → IO ()
- handleBIOS = dump
-
handleOthers ∷ SomeException → IO ()
handleOthers = dump
dump ∷ Exception e ⇒ e → IO ()
dump e
- = do hPutStrLn stderr "requestReader caught an exception:"
- hPutStrLn stderr (show $ toException e)
+ = do hPutStrLn stderr "Lucu: requestReader caught an exception:"
+ hPutStrLn stderr $ show e
acceptRequest ∷ HandleLike h ⇒ Context h → Lazy.ByteString → IO ()
acceptRequest ctx@(Context {..}) input
- -- キューに最大パイプライン深度以上のリクエストが溜まってゐる時は、
- -- それが限度以下になるまで待つ。
= do atomically $
do queue ← readTVar cQueue
- when (S.length queue ≥ cnfMaxPipelineDepth cConfig) $
+ when (S.length queue ≥ cnfMaxPipelineDepth cConfig)
+ -- Too many requests in the pipeline...
retry
- -- リクエストを讀む。パースできない場合は直ちに 400 Bad
- -- Request 應答を設定し、それを出力してから切斷するやうに
- -- ResponseWriter に通知する。
- case LP.parse requestP input of
- LP.Done input' req → acceptParsableRequest ctx req input'
- LP.Fail _ _ _ → acceptNonparsableRequest ctx
+ if Lazy.null input then
+ return ()
+ else
+ case LP.parse request input of
+ LP.Done input' req → acceptParsableRequest ctx req input'
+ LP.Fail _ _ _ → acceptNonparsableRequest ctx
acceptNonparsableRequest ∷ HandleLike h ⇒ Context h → IO ()
acceptNonparsableRequest ctx@(Context {..})
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
→ AugmentedRequest
→ Lazy.ByteString
→ [Strict.ByteString]
- → ResourceDef
+ → Resource
→ IO ()
acceptRequestForResource ctx@(Context {..}) ar@(AugmentedRequest {..}) input rsrcPath rsrcDef
- = do cert ← hGetPeerCert cHandle
+ = do
+#if defined(HAVE_SSL)
+ cert ← hGetPeerCert cHandle
ni ← mkNormalInteraction cConfig cAddr cert ar rsrcPath
- tid ← spawnResource rsrcDef ni
+#else
+ ni ← mkNormalInteraction cConfig cAddr ar rsrcPath
+#endif
+ tid ← spawnRsrc 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
acceptRequest ctx input
enqueue ∷ (HandleLike h, Interaction i) ⇒ Context h → i → IO ()
-{-# INLINEABLE enqueue #-}
-enqueue (Context {..}) itr
+enqueue (Context {..}) = enqueue' cQueue
+
+enqueue' ∷ Interaction i ⇒ InteractionQueue → i → IO ()
+enqueue' tQueue itr
= atomically $
- do queue ← readTVar cQueue
- writeTVar cQueue (toInteraction itr ⊲ queue)
+ do queue ← readTVar tQueue
+ writeTVar tQueue (toInteraction itr ⊲ queue)
projects / Lucu.git / blobdiff