1 module Network.HTTP.Lucu.RequestReader
2 ( requestReader -- Config -> ResTree -> Handle -> HostName -> InteractionQueue -> IO ()
6 import Control.Concurrent.STM
7 import Control.Exception
9 import qualified Data.ByteString.Lazy.Char8 as B
10 import Data.ByteString.Lazy.Char8 (ByteString)
14 import qualified Data.Sequence as S
15 import Data.Sequence (Seq, (<|), ViewR(..))
17 import Network.HTTP.Lucu.Config
18 import Network.HTTP.Lucu.DefaultPage
19 import Network.HTTP.Lucu.HttpVersion
20 import Network.HTTP.Lucu.Interaction
21 import Network.HTTP.Lucu.Parser
22 import Network.HTTP.Lucu.Postprocess
23 import Network.HTTP.Lucu.Preprocess
24 import Network.HTTP.Lucu.Request
25 import Network.HTTP.Lucu.Response
26 import Network.HTTP.Lucu.Resource
27 import Prelude hiding (catch)
30 import GHC.Conc (unsafeIOToSTM)
32 requestReader :: Config -> ResTree -> Handle -> HostName -> InteractionQueue -> IO ()
33 requestReader cnf tree h host tQueue
34 = do catch (do input <- B.hGetContents h
35 acceptRequest input) $ \ exc ->
37 IOException _ -> return ()
38 AsyncException ThreadKilled -> return ()
39 BlockedIndefinitely -> putStrLn "requestReader: blocked indefinitely"
42 acceptRequest :: ByteString -> IO ()
44 -- キューに最大パイプライン深度以上のリクエストが溜まってゐる
46 = do atomically $ do queue <- readTVar tQueue
47 when (S.length queue >= cnfMaxPipelineDepth cnf)
50 -- リクエストを讀む。パースできない場合は直ちに 400 Bad
51 -- Request 應答を設定し、それを出力してから切斷するやう
52 -- に ResponseWriter に通知する。
53 case parse requestP input of
54 (Success req , input') -> acceptParsableRequest req input'
55 (IllegalInput, _ ) -> acceptNonparsableRequest BadRequest
56 (ReachedEOF , _ ) -> acceptNonparsableRequest BadRequest
58 acceptNonparsableRequest :: StatusCode -> IO ()
59 acceptNonparsableRequest status
60 = do itr <- newInteraction cnf host Nothing
62 resVersion = HttpVersion 1 1
67 atomically $ do writeItr itr itrResponse $ Just res
68 writeItr itr itrWillClose True
69 writeItr itr itrState Done
74 acceptParsableRequest :: Request -> ByteString -> IO ()
75 acceptParsableRequest req input
76 = do itr <- newInteraction cnf host (Just req)
80 isErr <- readItrF itr itrResponse (isError . resStatus)
81 if isErr == Just True then
82 acceptSemanticallyInvalidRequest itr input
84 case findResource tree $ (reqURI . fromJust . itrRequest) itr of
85 Nothing -- Resource が無かった
86 -> acceptRequestForNonexistentResource itr input
89 -> acceptRequestForExistentResource itr input rsrcDef
92 acceptSemanticallyInvalidRequest :: Interaction -> ByteString -> STM (IO ())
93 acceptSemanticallyInvalidRequest itr input
94 = do writeItr itr itrState Done
98 return $ acceptRequest input
100 acceptRequestForNonexistentResource :: Interaction -> ByteString -> STM (IO ())
101 acceptRequestForNonexistentResource itr input
102 = do let res = Response {
103 resVersion = HttpVersion 1 1
104 , resStatus = NotFound
107 writeItr itr itrResponse $ Just res
108 writeItr itr itrState Done
112 return $ acceptRequest input
114 acceptRequestForExistentResource :: Interaction -> ByteString -> ResourceDef -> STM (IO ())
115 acceptRequestForExistentResource itr input rsrcDef
116 = do requestHasBody <- readItr itr itrRequestHasBody id
117 writeItr itr itrState (if requestHasBody
121 return $ do runResource rsrcDef itr
122 if requestHasBody then
123 observeRequest itr input
127 observeRequest :: Interaction -> ByteString -> IO ()
128 observeRequest itr input
129 = do isChunked <- atomically $ readItr itr itrRequestIsChunked id
131 observeChunkedRequest itr input
133 observeNonChunkedRequest itr input
135 observeChunkedRequest :: Interaction -> ByteString -> IO ()
136 observeChunkedRequest itr input
137 = fail "FIXME: not implemented"
139 observeNonChunkedRequest :: Interaction -> ByteString -> IO ()
140 observeNonChunkedRequest itr input
143 do wantedM <- readItr itr itrReqBodyWanted id
144 if wantedM == Nothing then
145 do wasteAll <- readItr itr itrReqBodyWasteAll id
148 do remainingM <- readItr itr itrReqChunkRemaining id
150 let (_, input') = if remainingM == Nothing then
151 (B.takeWhile (\ _ -> True) input, B.empty)
153 B.splitAt (fromIntegral $ fromJust remainingM) input
155 writeItr itr itrReqChunkRemaining $ Just 0
156 writeItr itr itrReqChunkIsOver True
157 writeItr itr itrReqBodyWanted Nothing
158 writeItr itr itrReceivedBody B.empty
160 return $ acceptRequest input'
166 do remainingM <- readItr itr itrReqChunkRemaining id
168 let wanted = fromJust wantedM
169 expectedChunkLen = fromIntegral $ maybe wanted (min wanted) remainingM
170 (chunk, input') = B.splitAt expectedChunkLen input
172 (\ x -> x - (fromIntegral $ B.length chunk))
174 isOver = B.length chunk < expectedChunkLen
176 writeItr itr itrReqChunkRemaining newRemaining
177 writeItr itr itrReqChunkIsOver isOver
178 writeItr itr itrReqBodyWanted Nothing
179 writeItr itr itrReceivedBody chunk
182 return $ acceptRequest input'
184 return $ observeNonChunkedRequest itr input'
187 enqueue :: Interaction -> STM ()
188 enqueue itr = do queue <- readTVar tQueue
189 writeTVar tQueue (itr <| queue)