{-# LANGUAGE
- DoAndIfThenElse
+ CPP
+ , DoAndIfThenElse
+ , OverloadedStrings
, RecordWildCards
, ScopedTypeVariables
, UnicodeSyntax
( requestReader
)
where
-import Control.Applicative
+import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception hiding (block)
import Control.Monad
import qualified Data.Attoparsec.Lazy as LP
import qualified Data.ByteString as Strict
import qualified Data.ByteString.Lazy as Lazy
+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.Chunk
import Network.HTTP.Lucu.HandleLike
import Network.HTTP.Lucu.Interaction
-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.Internal
import Network.HTTP.Lucu.Resource.Tree
+import Network.HTTP.Lucu.Utils
import Network.Socket
-import Network.URI
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 BadRequest
+ 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 → StatusCode → IO ()
-acceptNonparsableRequest ctx@(Context {..}) sc
- = do itr ← newInteraction cConfig cPort cAddr Nothing (Left sc)
- atomically $
- do writeTVar (itrState itr) Done
- postprocess itr
- enqueue ctx itr
+acceptNonparsableRequest ∷ HandleLike h ⇒ Context h → IO ()
+acceptNonparsableRequest ctx@(Context {..})
+ = do syi ← mkSyntacticallyInvalidInteraction cConfig
+ enqueue ctx syi
acceptParsableRequest ∷ HandleLike h
⇒ Context h
→ Lazy.ByteString
→ IO ()
acceptParsableRequest ctx@(Context {..}) req input
- = do cert ← hGetPeerCert cHandle
- itr ← newInteraction cConfig cPort cAddr cert (Right req)
- join $ atomically
- $ do isErr ← (isError ∘ resStatus) <$> readTVar (itrResponse itr)
- if isErr then
- acceptSemanticallyInvalidRequest ctx itr input
- else
- return $ acceptSemanticallyValidRequest ctx itr (reqURI req) input
+ = do let ar = preprocess (cnfServerHost cConfig) cPort req
+ if isError $ arInitialStatus ar then
+ acceptSemanticallyInvalidRequest ctx ar input
+ else
+ do rsrc ← findResource cResTree cFallbacks $ reqURI $ arRequest ar
+ case rsrc of
+ Nothing
+ → do let ar' = ar {
+ arInitialStatus = fromStatusCode NotFound
+ }
+ acceptSemanticallyInvalidRequest ctx ar' input
+ Just (path, def)
+ → acceptRequestForResource ctx ar input path def
acceptSemanticallyInvalidRequest ∷ HandleLike h
⇒ Context h
- → Interaction
+ → AugmentedRequest
→ Lazy.ByteString
- → STM (IO ())
-acceptSemanticallyInvalidRequest ctx itr input
- = do writeTVar (itrState itr) Done
- postprocess itr
- enqueue ctx itr
- return $ acceptRequest ctx input
-
-acceptSemanticallyValidRequest ∷ HandleLike h
- ⇒ Context h
- → Interaction
- → URI
- → Lazy.ByteString
- → IO ()
-acceptSemanticallyValidRequest ctx@(Context {..}) itr uri input
- = do rsrcM ← findResource cResTree cFallbacks uri
- case rsrcM of
- Nothing
- → acceptRequestForNonexistentResource ctx itr input
- Just (rsrcPath, rsrcDef)
- → acceptRequestForExistentResource ctx itr input rsrcPath rsrcDef
-
-acceptRequestForNonexistentResource ∷ HandleLike h
- ⇒ Context h
- → Interaction
- → Lazy.ByteString
- → IO ()
-acceptRequestForNonexistentResource ctx itr input
- = do atomically $
- do setResponseStatus itr NotFound
- writeTVar (itrState itr) Done
- postprocess itr
- enqueue ctx itr
+ → IO ()
+acceptSemanticallyInvalidRequest ctx@(Context {..}) ar input
+ = do sei ← mkSemanticallyInvalidInteraction cConfig ar
+ enqueue ctx sei
acceptRequest ctx input
-acceptRequestForExistentResource ∷ HandleLike h
- ⇒ Context h
- → Interaction
- → Lazy.ByteString
- → [Strict.ByteString]
- → ResourceDef
- → IO ()
-acceptRequestForExistentResource ctx oldItr input rsrcPath rsrcDef
- = do let itr = oldItr { itrResourcePath = Just rsrcPath }
- atomically $ enqueue ctx itr
- do _ ← spawnResource rsrcDef itr
- if reqMustHaveBody $ fromJust $ itrRequest itr then
- waitForReceiveBodyReq ctx itr input
- else
- acceptRequest ctx input
+acceptRequestForResource ∷ HandleLike h
+ ⇒ Context h
+ → AugmentedRequest
+ → Lazy.ByteString
+ → [Strict.ByteString]
+ → Resource
+ → IO ()
+acceptRequestForResource ctx@(Context {..}) ar@(AugmentedRequest {..}) input rsrcPath rsrcDef
+ = do
+#if defined(HAVE_SSL)
+ cert ← hGetPeerCert cHandle
+ ni ← mkNormalInteraction cConfig cAddr cert ar rsrcPath
+#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
+ acceptRequest ctx input
waitForReceiveBodyReq ∷ HandleLike h
⇒ Context h
- → Interaction
+ → NormalInteraction
+ → ThreadId
→ Lazy.ByteString
→ IO ()
-waitForReceiveBodyReq ctx itr input
- = case fromJust $ itrReqBodyLength itr of
+waitForReceiveBodyReq ctx ni@(NI {..}) rsrcTid input
+ = case fromJust niReqBodyLength of
Chunked
- → waitForReceiveChunkedBodyReqForTheFirstTime ctx itr input
+ → waitForReceiveChunkedBodyReqForTheFirstTime ctx ni rsrcTid input
Fixed len
- → waitForReceiveNonChunkedBodyReqForTheFirstTime ctx itr input len
+ → waitForReceiveNonChunkedBodyReqForTheFirstTime ctx ni input len
-- Toooooo long name for a function...
waitForReceiveChunkedBodyReqForTheFirstTime ∷ HandleLike h
⇒ Context h
- → Interaction
+ → NormalInteraction
+ → ThreadId
→ Lazy.ByteString
→ IO ()
-waitForReceiveChunkedBodyReqForTheFirstTime ctx itr@(Interaction {..}) input
+waitForReceiveChunkedBodyReqForTheFirstTime ctx ni@(NI {..}) rsrcTid input
= join $
atomically $
- do req ← takeTMVar itrReceiveBodyReq
+ do req ← takeTMVar niReceiveBodyReq
case req of
ReceiveBody wanted
- → do putTMVar itrSendContinue $ fromJust itrExpectedContinue
- return $ readCurrentChunk ctx itr input Initial wanted
+ → do putTMVar niSendContinue niExpectedContinue
+ return $ readCurrentChunk ctx ni rsrcTid wanted input Initial
WasteAll
- → do putTMVar itrSendContinue False
- return $ wasteAllChunks ctx itr input Initial
+ → do putTMVar niSendContinue False
+ return $ wasteAllChunks ctx rsrcTid input Initial
waitForReceiveChunkedBodyReq ∷ HandleLike h
⇒ Context h
- → Interaction
+ → NormalInteraction
+ → ThreadId
→ Lazy.ByteString
→ ChunkReceivingState
→ IO ()
-waitForReceiveChunkedBodyReq ctx itr@(Interaction {..}) input st
- = do req ← atomically $ takeTMVar itrReceiveBodyReq
+waitForReceiveChunkedBodyReq ctx ni@(NI {..}) rsrcTid input st
+ = do req ← atomically $ takeTMVar niReceiveBodyReq
case req of
ReceiveBody wanted
- → readCurrentChunk ctx itr input st wanted
+ → readCurrentChunk ctx ni rsrcTid wanted input st
WasteAll
- → wasteAllChunks ctx itr input st
+ → wasteAllChunks ctx rsrcTid input st
wasteAllChunks ∷ HandleLike h
⇒ Context h
- → Interaction
+ → ThreadId
→ Lazy.ByteString
→ ChunkReceivingState
→ IO ()
-wasteAllChunks ctx itr = go
+wasteAllChunks ctx rsrcTid = go
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 _ _ _
- → chunkWasMalformed itr
+ 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 _ _ _
- → chunkWasMalformed itr
+ LP.Fail _ eCtx e
+ → chunkWasMalformed rsrcTid eCtx e
+ "wasteAllChunks: chunkFooter"
gotFinalChunk ∷ Lazy.ByteString → IO ()
gotFinalChunk input
- = case LP.parse chunkFooterP input of
+ = case LP.parse chunkTrailer input of
LP.Done input' _
- → case LP.parse chunkTrailerP input' of
- LP.Done input'' _
- → acceptRequest ctx input''
- LP.Fail _ _ _
- → chunkWasMalformed itr
- LP.Fail _ _ _
- → chunkWasMalformed itr
+ → acceptRequest ctx input'
+ LP.Fail _ eCtx e
+ → chunkWasMalformed rsrcTid eCtx e
+ "wasteAllChunks: chunkTrailer"
readCurrentChunk ∷ HandleLike h
⇒ Context h
- → Interaction
+ → NormalInteraction
+ → ThreadId
+ → Int
→ Lazy.ByteString
→ ChunkReceivingState
- → Int
→ IO ()
-readCurrentChunk ctx itr@(Interaction {..}) input0 st0 wanted
- = go input0 st0
+readCurrentChunk ctx ni@(NI {..}) rsrcTid wanted = go
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 _ _ _
- → chunkWasMalformed itr
+ LP.Fail _ eCtx e
+ → chunkWasMalformed rsrcTid eCtx e
+ "readCurrentChunk: chunkHeader"
go input (InChunk chunkLen)
= gotChunk input chunkLen
block' = Strict.concat $ Lazy.toChunks block
actualReadBytes = Strict.length block'
chunkLen' = chunkLen - actualReadBytes
- atomically $ putTMVar itrReceivedBody block'
+ 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 itr input'' Initial
- LP.Fail _ _ _
- → chunkWasMalformed itr
+ → waitForReceiveChunkedBodyReq ctx ni rsrcTid input'' Initial
+ LP.Fail _ eCtx e
+ → chunkWasMalformed rsrcTid eCtx e
+ "readCurrentChunk: chunkFooter"
else
- waitForReceiveChunkedBodyReq ctx itr input' $ InChunk chunkLen'
+ waitForReceiveChunkedBodyReq ctx ni rsrcTid input' $ InChunk chunkLen'
gotFinalChunk ∷ Lazy.ByteString → IO ()
gotFinalChunk input
- = do atomically $ putTMVar itrReceivedBody (∅)
- case LP.parse chunkFooterP input of
+ = do atomically $ putTMVar niReceivedBody (∅)
+ case LP.parse chunkTrailer input of
LP.Done input' _
- → case LP.parse chunkTrailerP input' of
- LP.Done input'' _
- → acceptRequest ctx input''
- LP.Fail _ _ _
- → chunkWasMalformed itr
- LP.Fail _ _ _
- → chunkWasMalformed itr
+ → acceptRequest ctx input'
+ LP.Fail _ eCtx e
+ → chunkWasMalformed rsrcTid eCtx e
+ "readCurrentChunk: chunkTrailer"
-chunkWasMalformed ∷ Interaction → IO ()
-chunkWasMalformed itr
- -- FIXME: This is a totally wrong way to abort!
- = atomically $
- do setResponseStatus itr BadRequest
- writeTVar (itrWillClose itr) True
- writeTVar (itrState itr) Done
- postprocess itr
+chunkWasMalformed ∷ ThreadId → [String] → String → String → IO ()
+chunkWasMalformed tid eCtx e msg
+ = let abo = mkAbortion BadRequest [("Connection", "close")]
+ $ Just
+ $ "chunkWasMalformed: "
+ ⊕ T.pack msg
+ ⊕ ": "
+ ⊕ T.pack (intercalate ", " eCtx)
+ ⊕ ": "
+ ⊕ T.pack e
+ in
+ throwTo tid abo
waitForReceiveNonChunkedBodyReqForTheFirstTime ∷ HandleLike h
⇒ Context h
- → Interaction
+ → NormalInteraction
→ Lazy.ByteString
→ Int
→ IO ()
-waitForReceiveNonChunkedBodyReqForTheFirstTime ctx itr@(Interaction {..}) input bodyLen
+waitForReceiveNonChunkedBodyReqForTheFirstTime ctx ni@(NI {..}) input bodyLen
= join $
atomically $
- do req ← takeTMVar itrReceiveBodyReq
+ do req ← takeTMVar niReceiveBodyReq
case req of
ReceiveBody wanted
- → do putTMVar itrSendContinue $ fromJust itrExpectedContinue
- return $ readNonChunkedRequestBody ctx itr input bodyLen wanted
+ → do putTMVar niSendContinue niExpectedContinue
+ return $ readNonChunkedRequestBody ctx ni input bodyLen wanted
WasteAll
- → do putTMVar itrSendContinue False
+ → do putTMVar niSendContinue False
return $ wasteNonChunkedRequestBody ctx input bodyLen
waitForReceiveNonChunkedBodyReq ∷ HandleLike h
⇒ Context h
- → Interaction
+ → NormalInteraction
→ Lazy.ByteString
→ Int
→ IO ()
-waitForReceiveNonChunkedBodyReq ctx itr@(Interaction {..}) input bodyLen
- = do req ← atomically $ takeTMVar itrReceiveBodyReq
+waitForReceiveNonChunkedBodyReq ctx ni@(NI {..}) input bodyLen
+ = do req ← atomically $ takeTMVar niReceiveBodyReq
case req of
ReceiveBody wanted
- → readNonChunkedRequestBody ctx itr input bodyLen wanted
+ → readNonChunkedRequestBody ctx ni input bodyLen wanted
WasteAll
→ wasteNonChunkedRequestBody ctx input bodyLen
readNonChunkedRequestBody ∷ HandleLike h
⇒ Context h
- → Interaction
+ → NormalInteraction
→ Lazy.ByteString
→ Int
→ Int
→ IO ()
-readNonChunkedRequestBody ctx itr@(Interaction {..}) input bodyLen wanted
+readNonChunkedRequestBody ctx ni@(NI {..}) input bodyLen wanted
| bodyLen ≡ 0 = gotEndOfRequest
| otherwise = gotBody
where
block' = Strict.concat $ Lazy.toChunks block
actualReadBytes = Strict.length block'
bodyLen' = bodyLen - actualReadBytes
- atomically $ putTMVar itrReceivedBody block'
- waitForReceiveNonChunkedBodyReq ctx itr input' bodyLen'
+ atomically $ putTMVar niReceivedBody block'
+ waitForReceiveNonChunkedBodyReq ctx ni input' bodyLen'
gotEndOfRequest ∷ IO ()
gotEndOfRequest
- = do atomically $ putTMVar itrReceivedBody (∅)
+ = do atomically $ putTMVar niReceivedBody (∅)
acceptRequest ctx input
-enqueue ∷ HandleLike h ⇒ Context h → Interaction → STM ()
-enqueue (Context {..}) itr
- = do queue ← readTVar cQueue
- writeTVar cQueue (itr ⊲ queue)
+enqueue ∷ (HandleLike h, Interaction i) ⇒ Context h → i → IO ()
+enqueue (Context {..}) = enqueue' cQueue
+
+enqueue' ∷ Interaction i ⇒ InteractionQueue → i → IO ()
+enqueue' tQueue itr
+ = atomically $
+ do queue ← readTVar tQueue
+ writeTVar tQueue (toInteraction itr ⊲ queue)
projects / Lucu.git / blobdiff