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