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.Chunk
  19 import           Network.HTTP.Lucu.DefaultPage
  20 import           Network.HTTP.Lucu.HttpVersion
  21 import           Network.HTTP.Lucu.Interaction
  22 import           Network.HTTP.Lucu.Parser
  23 import           Network.HTTP.Lucu.Postprocess
  24 import           Network.HTTP.Lucu.Preprocess
  25 import           Network.HTTP.Lucu.Request
  26 import           Network.HTTP.Lucu.Response
  27 import           Network.HTTP.Lucu.Resource
  28 import           Prelude hiding (catch)
  29 import           System.IO
  30
  31 import GHC.Conc (unsafeIOToSTM)
  32
  33 requestReader :: Config -> ResTree -> Handle -> HostName -> InteractionQueue -> IO ()
  34 requestReader cnf tree h host tQueue
  35     = do catch (do input <- B.hGetContents h
  36                    acceptRequest input) $ \ exc ->
  37              case exc of
  38                IOException _               -> return ()
  39                AsyncException ThreadKilled -> return ()
  40                BlockedIndefinitely         -> putStrLn "requestReader: blocked indefinitely"
  41                _                           -> print exc
  42     where
  43       acceptRequest :: ByteString -> IO ()
  44       acceptRequest input
  45           -- キューに最大パイプライン深度以上のリクエストが溜まってゐる
  46           -- 時は、それが限度以下になるまで待つ。
  47           = do atomically $ do queue    <- readTVar tQueue
  48                                when (S.length queue >= cnfMaxPipelineDepth cnf)
  49                                     retry
  50
  51                -- リクエストを讀む。パースできない場合は直ちに 400 Bad
  52                -- Request 應答を設定し、それを出力してから切斷するやう
  53                -- に ResponseWriter に通知する。
  54                case parse requestP input of
  55                  (Success req , input') -> acceptParsableRequest req input'
  56                  (IllegalInput, _     ) -> acceptNonparsableRequest BadRequest
  57                  (ReachedEOF  , _     ) -> acceptNonparsableRequest BadRequest
  58
  59       acceptNonparsableRequest :: StatusCode -> IO ()
  60       acceptNonparsableRequest status
  61           = do itr <- newInteraction cnf host Nothing
  62                let res = Response {
  63                            resVersion = HttpVersion 1 1
  64                          , resStatus  = status
  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 cnf 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                enqueue itr
 118                return $ do runResource rsrcDef itr
 119                            if requestHasBody then
 120                                observeRequest itr input
 121                              else
 122                                acceptRequest input
 123
 124       observeRequest :: Interaction -> ByteString -> IO ()
 125       observeRequest itr input
 126           = do isChunked <- atomically $ readItr itr itrRequestIsChunked id
 127                if isChunked then
 128                    observeChunkedRequest itr input
 129                  else
 130                    observeNonChunkedRequest itr input
 131
 132       observeChunkedRequest :: Interaction -> ByteString -> IO ()
 133       observeChunkedRequest itr input
 134           = do action
 135                    <- atomically $
 136                       do isOver <- readItr itr itrReqChunkIsOver id
 137                          if isOver then
 138                              return $ acceptRequest input
 139                            else
 140                              do wantedM <- readItr itr itrReqBodyWanted id
 141                                 if wantedM == Nothing then
 142                                     do wasteAll <- readItr itr itrReqBodyWasteAll id
 143                                        if wasteAll then
 144                                            -- 破棄要求が來た
 145                                            do remainingM <- readItr itr itrReqChunkRemaining id
 146                                               if fmap (> 0) remainingM == Just True then
 147                                                   -- 現在のチャンクをまだ
 148                                                   -- 讀み終へてゐない
 149                                                   do let (_, input') = B.splitAt (fromIntegral
 150                                                                                   $ fromJust remainingM) input
 151                                                          (footerR, input'') = parse chunkFooterP input'
 152
 153                                                      if footerR == Success () then
 154                                                          -- チャンクフッタを正常に讀めた
 155                                                          do writeItr itr itrReqChunkRemaining $ Just 0
 156
 157                                                             return $ observeChunkedRequest itr input''
 158                                                        else
 159                                                          return $ chunkWasMalformed itr
 160                                                 else
 161                                                   -- 次のチャンクを讀み始める
 162                                                   seekNextChunk itr input
 163                                          else
 164                                            -- 要求がまだ來ない
 165                                            retry
 166                                   else
 167                                     -- 受信要求が來た
 168                                     do remainingM <- readItr itr itrReqChunkRemaining id
 169                                        if fmap (> 0) remainingM == Just True then
 170                                            -- 現在のチャンクをまだ讀み
 171                                            -- 終へてゐない
 172                                            do let wanted             = fromJust wantedM
 173                                                   remaining          = fromJust remainingM
 174                                                   bytesToRead        = fromIntegral $ min wanted remaining
 175                                                   (chunk, input')    = B.splitAt bytesToRead input
 176                                                   actualReadBytes    = fromIntegral $ B.length chunk
 177                                                   newWanted          = case wanted - actualReadBytes of
 178                                                                          0 -> Nothing
 179                                                                          n -> Just n
 180                                                   newRemaining       = Just $ remaining - actualReadBytes
 181                                                   updateStates
 182                                                       = do writeItr itr itrReqChunkRemaining newRemaining
 183                                                            writeItr itr itrReqBodyWanted newWanted
 184                                                            updateItr itr itrReceivedBody $ flip B.append chunk
 185
 186                                               if newRemaining == Just 0 then
 187                                                   -- チャンクフッタを讀む
 188                                                   case parse chunkFooterP input' of
 189                                                     (Success _, input'')
 190                                                         -> do updateStates
 191                                                               return $ observeChunkedRequest itr input''
 192                                                     _   -> return $ chunkWasMalformed itr
 193                                                 else
 194                                                   -- まだチャンクの終はりに達してゐない
 195                                                   do updateStates
 196                                                      return $ observeChunkedRequest itr input'
 197                                          else
 198                                            -- 次のチャンクを讀み始める
 199                                            seekNextChunk itr input
 200                action
 201
 202       seekNextChunk :: Interaction -> ByteString -> STM (IO ())
 203       seekNextChunk itr input
 204           = case parse chunkHeaderP input of
 205               -- 最終チャンク (中身が空)
 206               (Success 0, input')
 207                   -> case parse chunkTrailerP input' of
 208                        (Success _, input'')
 209                            -> do writeItr itr itrReqChunkLength $ Nothing
 210                                  writeItr itr itrReqChunkRemaining $ Nothing
 211                                  writeItr itr itrReqChunkIsOver True
 212
 213                                  return $ acceptRequest input''
 214                        _   -> return $ chunkWasMalformed itr
 215               -- 最終でないチャンク
 216               (Success len, input')
 217                   -> do writeItr itr itrReqChunkLength $ Just len
 218                         writeItr itr itrReqChunkRemaining $ Just len
 219
 220                         return $ observeChunkedRequest itr input'
 221               -- チャンクヘッダがをかしい
 222               _   -> return $ chunkWasMalformed itr
 223
 224       chunkWasMalformed :: Interaction -> IO ()
 225       chunkWasMalformed itr
 226           = let res = Response {
 227                         resVersion = HttpVersion 1 1
 228                       , resStatus  = BadRequest
 229                       , resHeaders = []
 230                       }
 231             in
 232               atomically $ do writeItr itr itrResponse $ Just res
 233                               writeItr itr itrWillClose True
 234                               writeItr itr itrState Done
 235                               writeDefaultPage itr
 236                               postprocess itr
 237
 238       observeNonChunkedRequest :: Interaction -> ByteString -> IO ()
 239       observeNonChunkedRequest itr input
 240           = do action
 241                    <- atomically $
 242                       do wantedM <- readItr itr itrReqBodyWanted id
 243                          if wantedM == Nothing then
 244                              do wasteAll <- readItr itr itrReqBodyWasteAll id
 245                                 if wasteAll then
 246                                     -- 破棄要求が來た
 247                                     do remainingM <- readItr itr itrReqChunkRemaining id
 248
 249                                        let (_, input') = if remainingM == Nothing then
 250                                                              (B.takeWhile (\ _ -> True) input, B.empty)
 251                                                          else
 252                                                              B.splitAt (fromIntegral $ fromJust remainingM) input
 253
 254                                        writeItr itr itrReqChunkRemaining $ Just 0
 255                                        writeItr itr itrReqChunkIsOver True
 256
 257                                        return $ acceptRequest input'
 258                                   else
 259                                     -- 要求がまだ来ない
 260                                     retry
 261                            else
 262                                -- 受信要求が來た
 263                                do remainingM <- readItr itr itrReqChunkRemaining id
 264
 265                                   let wanted          = fromJust wantedM
 266                                       bytesToRead     = fromIntegral $ maybe wanted (min wanted) remainingM
 267                                       (chunk, input') = B.splitAt bytesToRead input
 268                                       newRemaining    = fmap
 269                                                         (\ x -> x - (fromIntegral $ B.length chunk))
 270                                                         remainingM
 271                                       isOver          = B.length chunk < bytesToRead || newRemaining == Just 0
 272
 273                                   writeItr itr itrReqChunkRemaining newRemaining
 274                                   writeItr itr itrReqChunkIsOver isOver
 275                                   writeItr itr itrReqBodyWanted Nothing
 276                                   writeItr itr itrReceivedBody chunk
 277
 278                                   if isOver then
 279                                       return $ acceptRequest input'
 280                                     else
 281                                       return $ observeNonChunkedRequest itr input'
 282                action
 283
 284       enqueue :: Interaction -> STM ()
 285       enqueue itr = do queue <- readTVar tQueue
 286                        writeTVar tQueue (itr <| queue)