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.HttpVersion
19 import Network.HTTP.Lucu.Interaction
20 import Network.HTTP.Lucu.Parser
21 import Network.HTTP.Lucu.Postprocess
22 import Network.HTTP.Lucu.Preprocess
23 import Network.HTTP.Lucu.Request
24 import Network.HTTP.Lucu.Response
25 import Network.HTTP.Lucu.Resource
26 import Prelude hiding (catch)
29 import GHC.Conc (unsafeIOToSTM)
31 requestReader :: Config -> ResTree -> Handle -> HostName -> InteractionQueue -> IO ()
32 requestReader cnf tree h host tQueue
33 = do input <- B.hGetContents h
34 catch (acceptRequest input) $ \ exc ->
36 IOException _ -> return ()
39 acceptRequest :: ByteString -> IO ()
41 -- キューに最大パイプライン深度以上のリクエストが溜まってゐる
45 do queue <- readTVar tQueue
46 when (S.length queue >= cnfMaxPipelineDepth cnf)
49 -- リクエストを讀む。パースできない場合は直ち
50 -- に 400 Bad Request 應答を設定し、それを出力
51 -- してから切斷するやうに ResponseWriter に通
53 case parse requestP input of
54 Nothing -> return acceptNonparsableRequest
55 Just (req, input') -> return $ acceptParsableRequest req input'
58 acceptNonparsableRequest :: IO ()
59 acceptNonparsableRequest
60 = do itr <- newInteraction host Nothing
62 resVersion = HttpVersion 1 1
63 , resStatus = BadRequest
66 atomically $ do writeTVar (itrResponse itr) $ Just res
67 writeTVar (itrWillClose itr) True
68 writeTVar (itrState itr) Done
72 acceptParsableRequest :: Request -> ByteString -> IO ()
73 acceptParsableRequest req input'
74 = do itr <- newInteraction host (Just req)
78 res <- readTVar (itrResponse itr)
79 if fmap isError (fmap resStatus res) == Just True then
80 acceptSemanticallyInvalidRequest itr input'
82 case findResource tree $ (reqURI . fromJust . itrRequest) itr of
83 Nothing -- Resource が無かった
84 -> acceptRequestForNonexistentResource itr input'
87 -> acceptRequestForExistentResource itr input' rsrcDef
90 acceptSemanticallyInvalidRequest :: Interaction -> ByteString -> STM (IO ())
91 acceptSemanticallyInvalidRequest itr input
92 = do writeTVar (itrState itr) Done
95 return $ acceptRequest input
97 acceptRequestForNonexistentResource :: Interaction -> ByteString -> STM (IO ())
98 acceptRequestForNonexistentResource itr input
99 = do let res = Response {
100 resVersion = HttpVersion 1 1
101 , resStatus = NotFound
104 writeTVar (itrResponse itr) $ Just res
105 writeTVar (itrState itr) Done
108 return $ acceptRequest input
110 acceptRequestForExistentResource :: Interaction -> ByteString -> ResourceDef -> STM (IO ())
111 acceptRequestForExistentResource itr input rsrcDef
112 = do requestHasBody <- readTVar (itrRequestHasBody itr)
113 writeTVar (itrState itr) (if requestHasBody
117 return $ do runResource rsrcDef itr
118 if requestHasBody then
119 observeRequest itr input
123 observeRequest :: Interaction -> ByteString -> IO ()
124 observeRequest itr input = fail "FIXME: Not Implemented"
126 enqueue :: Interaction -> STM ()
127 enqueue itr = do queue <- readTVar tQueue
128 writeTVar tQueue (itr <| queue)