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