{-# LANGUAGE DoAndIfThenElse , RecordWildCards , ScopedTypeVariables , UnicodeSyntax #-} module Network.HTTP.Lucu.RequestReader ( requestReader ) where import Control.Applicative import Control.Concurrent.STM import Control.Exception import Control.Monad import qualified Data.Attoparsec.Lazy as LP import qualified Data.ByteString.Lazy as Lazy import Data.Maybe import qualified Data.Sequence as S import Data.Sequence.Unicode import Network.HTTP.Lucu.Config import Network.HTTP.Lucu.Chunk import Network.HTTP.Lucu.DefaultPage 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.Tree import Network.Socket import Network.URI import Prelude.Unicode import System.IO (hPutStrLn, stderr) data Context h = Context { cConfig ∷ !Config , cResTree ∷ !ResTree , cFallbacks ∷ ![FallbackHandler] , cHandle ∷ !h , cPort ∷ !PortNumber , cAddr ∷ !SockAddr , cQueue ∷ !InteractionQueue } requestReader ∷ HandleLike h ⇒ Config → ResTree → [FallbackHandler] → h → PortNumber → SockAddr → InteractionQueue → IO () requestReader cnf tree fbs h port addr tQueue = do input ← hGetLBS h acceptRequest (Context cnf tree fbs h port addr tQueue) input `catches` [ Handler $ \ (_ ∷ IOException) → return () , Handler $ \ e → case e of ThreadKilled → return () _ → hPutStrLn stderr (show e) , Handler $ \ BlockedIndefinitelyOnSTM → hPutStrLn stderr "requestReader: blocked indefinitely" , Handler $ \ (e ∷ SomeException) → 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) $ retry -- リクエストを讀む。パースできない場合は直ちに 400 Bad -- Request 應答を設定し、それを出力してから切斷するやうに -- ResponseWriter に通知する。 case LP.parse requestP input of LP.Done input' req → acceptParsableRequest req input' LP.Fail _ _ _ → acceptNonparsableRequest ctx BadRequest acceptNonparsableRequest ∷ HandleLike h ⇒ Context h → StatusCode → IO () acceptNonparsableRequest (Context {..}) status = do itr ← newInteraction cConfig cPort cAddr Nothing Nothing atomically $ do setResponseStatus itr status writeTVar (itrWillClose itr) True writeTVar (itrState itr) Done writeDefaultPage itr postprocess itr enqueue itr acceptParsableRequest ∷ HandleLike h ⇒ Context h → Request → Lazy.ByteString → IO () acceptParsableRequest (Context {..}) req input = do cert ← hGetPeerCert cHandle itr ← newInteraction cConfig cPort cAddr cert (Right req) join $ atomically $ do preprocess itr isErr ← (isError ∘ resStatus) <$> readTVar (itrResponse itr) if isErr then acceptSemanticallyInvalidRequest itr input else acceptSemanticallyValidRequest itr (reqURI req) input acceptSemanticallyInvalidRequest ∷ Interaction → Lazy.ByteString → STM (IO ()) acceptSemanticallyInvalidRequest itr input = do writeTVar (itr itrState) Done writeDefaultPage itr postprocess itr enqueue itr return $ acceptRequest input acceptSemanticallyValidRequest ∷ HandleLike h ⇒ Context h → Interaction → URI → Lazy.ByteString → IO () acceptSemanticallyValidRequest (Context {..}) itr uri input = do rsrcM ← findResource cResTree cFallbacks uri case rsrcM of Nothing → acceptRequestForNonexistentResource itr input Just (rsrcPath, rsrcDef) → acceptRequestForExistentResource itr input rsrcPath rsrcDef acceptRequestForNonexistentResource ∷ Interaction → Lazy.ByteString → STM (IO ()) acceptRequestForNonexistentResource itr input = do setResponseStatus itr NotFound writeTVar (itrState itr) Done writeDefaultPage itr postprocess itr enqueue itr return $ acceptRequest input acceptRequestForExistentResource ∷ Interaction → Lazy.ByteString → [String] → ResourceDef → STM (IO ()) acceptRequestForExistentResource oldItr input rsrcPath rsrcDef = do let itr = oldItr { itrResourcePath = Just rsrcPath } enqueue itr return $ do _ ← runResource rsrcDef itr if reqHasBody $ fromJust $ itrRequest itr then observeRequest itr input else acceptRequest input observeRequest ∷ Interaction → Lazy.ByteString → IO () observeRequest itr input | itrReqBodyLength itr ≡ Just Chunked = observeChunkedRequest itr input | otherwise = observeNonChunkedRequest itr input observeChunkedRequest ∷ Interaction → Lazy.ByteString → IO () observeChunkedRequest itr input = join $ atomically $ do isOver ← readTVar $ itrReqChunkIsOver itr if isOver then return $ acceptRequest input else do wantedM ← readTVar $ itrReqBodyWanted itr if isNothing wantedM then do wasteAll ← readTVar $ itrReqBodyWasteAll itr if wasteAll then wasteCurrentChunk input else retry else readCurrentChunk (fromJust wantedM) wasteCurrentChunk ∷ Interaction → Lazy.ByteString → Int → IO () wasteCurrentChunk itr input len | len > 0 = let input' = Lazy.drop (fromIntegral len) input in case LP.parse chunkFooterP input' of LP.Done input'' _ → observeChunkedRequest itr input'' LP.Fail _ _ _ → chunkWasMalformed itr | otherwise = seekNextChunk itr input readCurrentChunk ∷ Interaction → Lazy.ByteString → Int → Int → IO () readCurrentChunk itr input wanted remaining | remaining > 0 = do let bytesToRead = fromIntegral $ min wanted remaining (chunk, input') = Lazy.splitAt bytesToRead input actualReadBytes = fromIntegral $ Lazy.length chunk newWanted = case wanted - actualReadBytes of 0 → Nothing n → Just n newRemaining = Just $ remaining - actualReadBytes updateStates = do writeTVar (itrReqBodyWanted itr) newWanted oldBody ← readTVar $ itrReceivedBody itr oldBodyLen ← readTVar $ itrReceivedBodyLen itr writeTVar (itrReceivedBody itr) $ oldBody ⊳ chunk writeTVar (itrReceivedBodyLen itr) $ oldBodyLen + actualReadBytes if newRemaining ≡ Just 0 then case LP.parse chunkFooterP input' of LP.Done input'' _ → do updateStates observeChunkedRequest itr input'' LP.Fail _ _ _ → chunkWasMalformed itr else do updateStates observeChunkedRequest itr input' | otherwise = seekNextChunk itr input seekNextChunk ∷ Interaction → Lazy.ByteString → IO () seekNextChunk itr input = case LP.parse chunkHeaderP input of LP.Done input' len | len ≡ 0 -- Final chunk → case LP.parse chunkTrailerP input' of LP.Done input'' _ → do writeTVar (itrReqChunkIsOver itr) True acceptRequest input'' LP.Fail _ _ _ → chunkWasMalformed itr | otherwise -- Non-final chunk → do observeChunkedRequest itr input' LP.Fail _ _ _ → chunkWasMalformed itr chunkWasMalformed ∷ Interaction → IO () chunkWasMalformed itr = atomically $ do setResponseStatus BadRequest writeTVar (itrWillClose itr) True writeTVar (itrState itr) Done writeDefaultPage itr postprocess itr observeNonChunkedRequest ∷ Interaction → Lazy.ByteString → IO () observeNonChunkedRequest itr input = join $ atomically $ do wantedM ← readTVar $ itrReqBodyWanted itr if isNothing wantedM then do wasteAll ← readTVar itr itrReqBodyWasteAll id if wasteAll then wasteNonChunkedRequestBody itr input else retry else readNonChunkedRequestBody itr input wasteNonChunkedRequestBody ∷ Interaction → Lazy.ByteString → Maybe Int → IO () wasteNonChunkedRequestBody itr input remaining = do let input' = case remaining of Just len → Lazy.drop len input Nothing → (∅) writeTVar (itrReqChunkIsOver itr) True acceptRequest input' readNonChunkedRequestBody ∷ Interaction → Lazy.ByteString → Int → Maybe Int → IO () readNonChunkedRequestBody itr input wanted remaining = do let bytesToRead = fromIntegral $ maybe wanted (min wanted) remaining (chunk, input') = Lazy.splitAt bytesToRead input actualReadBytes = fromIntegral $ Lazy.length chunk newRemaining = (- actualReadBytes) <$> remaining isOver = actualReadBytes < bytesToRead ∨ newRemaining ≡ Just 0 writeTVar (itrReqChunkIsOver itr) isOver writeTVar (itrReqBodyWanted itr) Nothing writeTVar (itrReceivedBody itr) chunk writeTVar (itrReceivedBodyLen itr) actualReadBytes if isOver then acceptRequest input' else observeNonChunkedRequest itr input' enqueue ∷ HandleLike h ⇒ Context h → Interaction → STM () enqueue (Context {..}) itr = do queue ← readTVar cQueue writeTVar cQueue (itr ⊲ queue)