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 BadRequest
  59                  (ReachedEOF  , _     ) -> if B.length input >= 1024 * 1024 then
  60                                                -- ヘッダ長過ぎ
  61                                                acceptNonparsableRequest RequestEntityTooLarge
  62                                            else
  63                                                acceptRequest input
  64
  65       acceptNonparsableRequest :: StatusCode -> IO ()
  66       acceptNonparsableRequest status
  67           = do itr <- newInteraction cnf host Nothing
  68                let res = Response {
  69                            resVersion = HttpVersion 1 1
  70                          , resStatus  = status
  71                          , resHeaders = []
  72                          }
  73                atomically $ do writeItr itr itrResponse $ Just res
  74                                writeItr itr itrWillClose True
  75                                writeItr itr itrState     Done
  76                                writeDefaultPage itr
  77                                postprocess itr
  78                                enqueue itr
  79
  80       acceptParsableRequest :: Request -> ByteString -> IO ()
  81       acceptParsableRequest req soFar
  82           = do itr <- newInteraction cnf host (Just req)
  83                action
  84                    <- atomically $
  85                       do preprocess itr
  86                          isErr <- readItrF itr itrResponse (isError . resStatus)
  87                          if isErr == Just True then
  88                              acceptSemanticallyInvalidRequest itr soFar
  89                            else
  90                              case findResource tree $ (reqURI . fromJust . itrRequest) itr of
  91                                Nothing -- Resource が無かった
  92                                    -> acceptRequestForNonexistentResource itr soFar
  93
  94                                Just rsrcDef -- あった
  95                                    -> acceptRequestForExistentResource itr soFar rsrcDef
  96                action
  97
  98       acceptSemanticallyInvalidRequest :: Interaction -> ByteString -> STM (IO ())
  99       acceptSemanticallyInvalidRequest itr soFar
 100           = do writeItr itr itrState Done
 101                writeDefaultPage itr
 102                postprocess itr
 103                enqueue itr
 104                return $ acceptRequest soFar
 105
 106       acceptRequestForNonexistentResource :: Interaction -> ByteString -> STM (IO ())
 107       acceptRequestForNonexistentResource itr soFar
 108           = do let res = Response {
 109                            resVersion = HttpVersion 1 1
 110                          , resStatus  = NotFound
 111                          , resHeaders = []
 112                          }
 113                writeItr itr itrResponse $ Just res
 114                writeItr itr itrState Done
 115                writeDefaultPage itr
 116                postprocess itr
 117                enqueue itr
 118                return $ acceptRequest soFar
 119
 120       acceptRequestForExistentResource :: Interaction -> ByteString -> ResourceDef -> STM (IO ())
 121       acceptRequestForExistentResource itr soFar rsrcDef
 122           = do requestHasBody <- readItr itr itrRequestHasBody id
 123                writeItr itr itrState (if requestHasBody
 124                                       then ExaminingHeader
 125                                       else DecidingHeader)
 126                enqueue itr
 127                return $ do runResource rsrcDef itr
 128                            if requestHasBody then
 129                                observeRequest itr soFar
 130                              else
 131                                acceptRequest soFar
 132
 133       observeRequest :: Interaction -> ByteString -> IO ()
 134       observeRequest itr soFar
 135           = do isChunked <- atomically $ readItr itr itrRequestIsChunked id
 136                if isChunked then
 137                    observeChunkedRequest itr soFar
 138                  else
 139                    observeNonChunkedRequest itr soFar
 140
 141       observeChunkedRequest :: Interaction -> ByteString -> IO ()
 142       observeChunkedRequest itr soFar
 143           = fail "FIXME: not implemented"
 144
 145       observeNonChunkedRequest :: Interaction -> ByteString -> IO ()
 146       observeNonChunkedRequest itr soFar
 147           = fail "FIXME: not implemented"
 148 {-
 149           = do action
 150                    <- atomically $
 151                       do wantedM <- readItr itr itrReqBodyWanted id
 152                          if wantedM == Nothing then
 153                              do wasteAll <- readItr itr itrReqBodyWasteAll id
 154                                 if wasteAll then
 155                                     return $ wasteAllReqBody itr soFar
 156                                   else
 157                                     retry
 158                            else
 159                              -- 受信要求が來た。
 160                              if B.empty soFar then
 161                                  return $ receiveNonChunkedReqBody itr
 162                              else
 163                                  do remaining <- readItr itr itrReqChunkRemaining fromJust
 164
 165                                     let wanted = fromJust wanted
 166                                         (chunk, input') = B.splitAt (min wanted remaining) soFar
 167                                         newRemaining    = remaining - B.length chunk
 168                                         isOver          = newRemaining == 0
 169
 170                                     writeItr itr itrReqChunkRemaining newRemaining
 171                                     writeItr itr itrReqChunkIsOver isOver
 172                                     writeItr itr itrReqBodyWanted (if isOver then
 173                                                                        Nothing
 174                                                                    else
 175                                                                        Just wanted)
 176                                     writeItr itr itrReceivedBody chunk
 177
 178                                     if isOver then
 179                                         return $ acceptRequest input'
 180                                       else
 181                                         return $ observeNonChunkedRequest itr input'
 182                action
 183
 184       receiveNonChunkedReqBody :: Interaction -> IO ()
 185       receiveNonChunkedReqBody itr
 186           = do wanted    <- atomically $ readItr itr itrReqBodyWanted fromJust
 187                remaining <- atomically $ readItr itr itrReqChunkRemaining fromJust
 188
 189                hWaitForInput h (-1)
 190                chunk <- B.hGetNonBlocking h (min wanted remaining)
 191
 192                let newRemaining = remaining - B.length chunk
 193                    isOver       = newRemaining == 0
 194
 195                atomically $ do writeItr itr itrReqChunkRemaining newRemaining
 196                                writeItr itr itrReqChunkIsOver isOver
 197                                writeItr itr itrReqBodyWanted (if isOver then
 198                                                                   Nothing
 199                                                               else
 200                                                                   Just wanted)
 201                                writeItr itr itrReceivedBody chunk
 202
 203                if isOver then
 204                    return $ acceptRequest B.empty
 205                  else
 206                    return $ observeNonChunkedRequest itr B.empty
 207
 208
 209       wasteAllReqBody :: Interaction -> ByteString -> IO ()
 210       wasteAllReqBody itr soFar
 211           =
 212
 213 -}
 214
 215       enqueue :: Interaction -> STM ()
 216       enqueue itr = do queue <- readTVar tQueue
 217                        writeTVar tQueue (itr <| queue)