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 input <- B.hGetContents h
35 catch (acceptRequest input) $ \ exc ->
37 IOException _ -> return ()
40 acceptRequest :: ByteString -> IO ()
42 -- キューに最大パイプライン深度以上のリクエストが溜まってゐる
46 do queue <- readTVar tQueue
47 when (S.length queue >= cnfMaxPipelineDepth cnf)
50 -- リクエストを讀む。パースできない場合は直ち
51 -- に 400 Bad Request 應答を設定し、それを出力
52 -- してから切斷するやうに ResponseWriter に通
54 case parse requestP input of
55 Nothing -> return acceptNonparsableRequest
56 Just (req, input') -> return $ acceptParsableRequest req input'
59 acceptNonparsableRequest :: IO ()
60 acceptNonparsableRequest
61 = do itr <- newInteraction host Nothing
63 resVersion = HttpVersion 1 1
64 , resStatus = BadRequest
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 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 = fail "FIXME: Not Implemented"
130 enqueue :: Interaction -> STM ()
131 enqueue itr = do queue <- readTVar tQueue
132 writeTVar tQueue (itr <| queue)