7 module Network.HTTP.Lucu.RequestReader
11 import Control.Applicative
12 import Control.Concurrent.STM
13 import Control.Exception
15 import qualified Data.Attoparsec.Lazy as LP
16 import qualified Data.ByteString.Lazy as Lazy
18 import qualified Data.Sequence as S
19 import Data.Sequence.Unicode
20 import Network.HTTP.Lucu.Config
21 import Network.HTTP.Lucu.Chunk
22 import Network.HTTP.Lucu.DefaultPage
23 import Network.HTTP.Lucu.HandleLike
24 import Network.HTTP.Lucu.Interaction
25 import Network.HTTP.Lucu.Postprocess
26 import Network.HTTP.Lucu.Preprocess
27 import Network.HTTP.Lucu.Request
28 import Network.HTTP.Lucu.Response
29 import Network.HTTP.Lucu.Resource.Tree
32 import Prelude.Unicode
33 import System.IO (hPutStrLn, stderr)
39 , cFallbacks ∷ ![FallbackHandler]
43 , cQueue ∷ !InteractionQueue
46 requestReader ∷ HandleLike h
55 requestReader cnf tree fbs h port addr tQueue
56 = do input ← hGetLBS h
57 acceptRequest (Context cnf tree fbs h port addr tQueue) input
59 [ Handler $ \ (_ ∷ IOException) → return ()
60 , Handler $ \ e → case e of
61 ThreadKilled → return ()
62 _ → hPutStrLn stderr (show e)
63 , Handler $ \ BlockedIndefinitelyOnSTM → hPutStrLn stderr "requestReader: blocked indefinitely"
64 , Handler $ \ (e ∷ SomeException) → hPutStrLn stderr (show e)
67 acceptRequest ∷ HandleLike h ⇒ Context h → Lazy.ByteString → IO ()
68 acceptRequest ctx@(Context {..}) input
69 -- キューに最大パイプライン深度以上のリクエストが溜まってゐる時は、
72 do queue ← readTVar cQueue
73 when (S.length queue ≥ cnfMaxPipelineDepth cConfig) $
75 -- リクエストを讀む。パースできない場合は直ちに 400 Bad
76 -- Request 應答を設定し、それを出力してから切斷するやうに
77 -- ResponseWriter に通知する。
78 case LP.parse requestP input of
79 LP.Done input' req → acceptParsableRequest req input'
80 LP.Fail _ _ _ → acceptNonparsableRequest ctx BadRequest
82 acceptNonparsableRequest ∷ HandleLike h ⇒ Context h → StatusCode → IO ()
83 acceptNonparsableRequest (Context {..}) status
84 = do itr ← newInteraction cConfig cPort cAddr Nothing Nothing
86 do setResponseStatus itr status
87 writeTVar (itrWillClose itr) True
88 writeTVar (itrState itr) Done
93 acceptParsableRequest ∷ HandleLike h
98 acceptParsableRequest (Context {..}) req input
99 = do cert ← hGetPeerCert cHandle
100 itr ← newInteraction cConfig cPort cAddr cert (Right req)
103 isErr ← (isError ∘ resStatus) <$> readTVar (itrResponse itr)
105 acceptSemanticallyInvalidRequest itr input
107 acceptSemanticallyValidRequest itr (reqURI req) input
109 acceptSemanticallyInvalidRequest ∷ Interaction → Lazy.ByteString → STM (IO ())
110 acceptSemanticallyInvalidRequest itr input
111 = do writeTVar (itr itrState) Done
115 return $ acceptRequest input
117 acceptSemanticallyValidRequest ∷ HandleLike h
123 acceptSemanticallyValidRequest (Context {..}) itr uri input
124 = do rsrcM ← findResource cResTree cFallbacks uri
127 → acceptRequestForNonexistentResource itr input
128 Just (rsrcPath, rsrcDef)
129 → acceptRequestForExistentResource itr input rsrcPath rsrcDef
131 acceptRequestForNonexistentResource ∷ Interaction → Lazy.ByteString → STM (IO ())
132 acceptRequestForNonexistentResource itr input
133 = do setResponseStatus itr NotFound
134 writeTVar (itrState itr) Done
138 return $ acceptRequest input
140 acceptRequestForExistentResource ∷ Interaction → Lazy.ByteString → [String] → ResourceDef → STM (IO ())
141 acceptRequestForExistentResource oldItr input rsrcPath rsrcDef
142 = do let itr = oldItr { itrResourcePath = Just rsrcPath }
144 return $ do _ ← runResource rsrcDef itr
145 if reqHasBody $ fromJust $ itrRequest itr then
146 observeRequest itr input
150 observeRequest ∷ Interaction → Lazy.ByteString → IO ()
151 observeRequest itr input
152 | itrReqBodyLength itr ≡ Just Chunked
153 = observeChunkedRequest itr input
155 = observeNonChunkedRequest itr input
157 observeChunkedRequest ∷ Interaction → Lazy.ByteString → IO ()
158 observeChunkedRequest itr input
161 do isOver ← readTVar $ itrReqChunkIsOver itr
163 return $ acceptRequest input
165 do wantedM ← readTVar $ itrReqBodyWanted itr
166 if isNothing wantedM then
167 do wasteAll ← readTVar $ itrReqBodyWasteAll itr
169 wasteCurrentChunk input
173 readCurrentChunk (fromJust wantedM)
175 wasteCurrentChunk ∷ Interaction → Lazy.ByteString → Int → IO ()
176 wasteCurrentChunk itr input len
178 = let input' = Lazy.drop (fromIntegral len) input
180 case LP.parse chunkFooterP input' of
182 → observeChunkedRequest itr input''
184 → chunkWasMalformed itr
186 = seekNextChunk itr input
188 readCurrentChunk ∷ Interaction → Lazy.ByteString → Int → Int → IO ()
189 readCurrentChunk itr input wanted remaining
191 = do let bytesToRead = fromIntegral $ min wanted remaining
192 (chunk, input') = Lazy.splitAt bytesToRead input
193 actualReadBytes = fromIntegral $ Lazy.length chunk
194 newWanted = case wanted - actualReadBytes of
197 newRemaining = Just $ remaining - actualReadBytes
198 updateStates = do writeTVar (itrReqBodyWanted itr) newWanted
199 oldBody ← readTVar $ itrReceivedBody itr
200 oldBodyLen ← readTVar $ itrReceivedBodyLen itr
201 writeTVar (itrReceivedBody itr) $ oldBody ⊳ chunk
202 writeTVar (itrReceivedBodyLen itr) $ oldBodyLen + actualReadBytes
203 if newRemaining ≡ Just 0 then
204 case LP.parse chunkFooterP input' of
207 observeChunkedRequest itr input''
209 → chunkWasMalformed itr
212 observeChunkedRequest itr input'
214 = seekNextChunk itr input
216 seekNextChunk ∷ Interaction → Lazy.ByteString → IO ()
217 seekNextChunk itr input
218 = case LP.parse chunkHeaderP input of
220 | len ≡ 0 -- Final chunk
221 → case LP.parse chunkTrailerP input' of
223 → do writeTVar (itrReqChunkIsOver itr) True
224 acceptRequest input''
226 → chunkWasMalformed itr
227 | otherwise -- Non-final chunk
228 → do observeChunkedRequest itr input'
230 → chunkWasMalformed itr
232 chunkWasMalformed ∷ Interaction → IO ()
233 chunkWasMalformed itr
235 do setResponseStatus BadRequest
236 writeTVar (itrWillClose itr) True
237 writeTVar (itrState itr) Done
241 observeNonChunkedRequest ∷ Interaction → Lazy.ByteString → IO ()
242 observeNonChunkedRequest itr input
245 do wantedM ← readTVar $ itrReqBodyWanted itr
246 if isNothing wantedM then
247 do wasteAll ← readTVar itr itrReqBodyWasteAll id
249 wasteNonChunkedRequestBody itr input
253 readNonChunkedRequestBody itr input
255 wasteNonChunkedRequestBody ∷ Interaction → Lazy.ByteString → Maybe Int → IO ()
256 wasteNonChunkedRequestBody itr input remaining
257 = do let input' = case remaining of
258 Just len → Lazy.drop len input
260 writeTVar (itrReqChunkIsOver itr) True
263 readNonChunkedRequestBody ∷ Interaction → Lazy.ByteString → Int → Maybe Int → IO ()
264 readNonChunkedRequestBody itr input wanted remaining
265 = do let bytesToRead = fromIntegral $ maybe wanted (min wanted) remaining
266 (chunk, input') = Lazy.splitAt bytesToRead input
267 actualReadBytes = fromIntegral $ Lazy.length chunk
268 newRemaining = (- actualReadBytes) <$> remaining
269 isOver = actualReadBytes < bytesToRead ∨ newRemaining ≡ Just 0
270 writeTVar (itrReqChunkIsOver itr) isOver
271 writeTVar (itrReqBodyWanted itr) Nothing
272 writeTVar (itrReceivedBody itr) chunk
273 writeTVar (itrReceivedBodyLen itr) actualReadBytes
277 observeNonChunkedRequest itr input'
279 enqueue ∷ HandleLike h ⇒ Context h → Interaction → STM ()
280 enqueue (Context {..}) itr
281 = do queue ← readTVar cQueue
282 writeTVar cQueue (itr ⊲ queue)