Network/HTTP/Lucu/RequestReader.hs

   1 module Network.HTTP.Lucu.RequestReader
   2     ( requestReader -- Config -> ResTree -> Handle -> HostName -> InteractionQueue -> IO ()
   3     )
   4     where
   5
   6 import           Control.Concurrent.STM
   7 import           Control.Exception
   8 import           Control.Monad
   9 import qualified Data.ByteString.Lazy.Char8 as B
  10 import           Data.ByteString.Lazy.Char8 (ByteString)
  11 import           Data.Map as M
  12 import           Data.Map (Map)
  13 import           Data.Maybe
  14 import qualified Data.Sequence as S
  15 import           Data.Sequence (Seq, (<|), ViewR(..))
  16 import           Network
  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)
  27 import           System.IO
  28
  29 import GHC.Conc (unsafeIOToSTM)
  30
  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 ->
  35              case exc of
  36                IOException _ -> return ()
  37                _             -> print exc
  38     where
  39       acceptRequest :: ByteString -> IO ()
  40       acceptRequest input
  41           -- キューに最大パイプライン深度以上のリクエストが溜まってゐる
  42           -- 時は、それが限度以下になるまで待つ。
  43           = do action
  44                    <- atomically $
  45                       do queue    <- readTVar tQueue
  46                          when (S.length queue >= cnfMaxPipelineDepth cnf)
  47                               retry
  48
  49                          -- リクエストを讀む。パースできない場合は直ち
  50                          -- に 400 Bad Request 應答を設定し、それを出力
  51                          -- してから切斷するやうに ResponseWriter に通
  52                          -- 知する。
  53                          case parse requestP input of
  54                            Nothing            -> return acceptNonparsableRequest
  55                            Just (req, input') -> return $ acceptParsableRequest req input'
  56                action
  57
  58       acceptNonparsableRequest :: IO ()
  59       acceptNonparsableRequest
  60           = do itr <- newInteraction host Nothing
  61                let res = Response {
  62                            resVersion = HttpVersion 1 1
  63                          , resStatus  = BadRequest
  64                          , resHeaders = []
  65                          }
  66                atomically $ do writeTVar (itrResponse  itr) $ Just res
  67                                writeTVar (itrWillClose itr) True
  68                                writeTVar (itrState     itr) Done
  69                                postprocess itr
  70                                enqueue itr
  71
  72       acceptParsableRequest :: Request -> ByteString -> IO ()
  73       acceptParsableRequest req input'
  74           = do itr <- newInteraction host (Just req)
  75                action
  76                    <- atomically $
  77                       do preprocess itr
  78                          res <- readTVar (itrResponse itr)
  79                          if fmap isError (fmap resStatus res) == Just True then
  80                              acceptSemanticallyInvalidRequest itr input'
  81                            else
  82                              case findResource tree $ (reqURI . fromJust . itrRequest) itr of
  83                                Nothing -- Resource が無かった
  84                                    -> acceptRequestForNonexistentResource itr input'
  85
  86                                Just rsrcDef -- あった
  87                                    -> acceptRequestForExistentResource itr input' rsrcDef
  88                action
  89
  90       acceptSemanticallyInvalidRequest :: Interaction -> ByteString -> STM (IO ())
  91       acceptSemanticallyInvalidRequest itr input
  92           = do writeTVar (itrState itr) Done
  93                postprocess itr
  94                enqueue itr
  95                return $ acceptRequest input
  96
  97       acceptRequestForNonexistentResource :: Interaction -> ByteString -> STM (IO ())
  98       acceptRequestForNonexistentResource itr input
  99           = do let res = Response {
 100                            resVersion = HttpVersion 1 1
 101                          , resStatus  = NotFound
 102                          , resHeaders = []
 103                          }
 104                writeTVar (itrResponse  itr) $ Just res
 105                writeTVar (itrState     itr) Done
 106                postprocess itr
 107                enqueue itr
 108                return $ acceptRequest input
 109
 110       acceptRequestForExistentResource :: Interaction -> ByteString -> ResourceDef -> STM (IO ())
 111       acceptRequestForExistentResource itr input rsrcDef
 112           = do requestHasBody <- readTVar (itrRequestHasBody itr)
 113                writeTVar (itrState itr) (if requestHasBody
 114                                          then ExaminingHeader
 115                                          else DecidingHeader)
 116                enqueue itr
 117                return $ do runResource rsrcDef itr
 118                            if requestHasBody then
 119                                observeRequest itr input
 120                              else
 121                                acceptRequest input
 122
 123       observeRequest :: Interaction -> ByteString -> IO ()
 124       observeRequest itr input = fail "FIXME: Not Implemented"
 125
 126       enqueue :: Interaction -> STM ()
 127       enqueue itr = do queue <- readTVar tQueue
 128                        writeTVar tQueue (itr <| queue)