Network/HTTP/Lucu/RequestReader.hs

   1 -- #hide
   2 module Network.HTTP.Lucu.RequestReader
   3     ( requestReader
   4     )
   5     where
   6
   7 import           Control.Concurrent.STM
   8 import           Control.Exception
   9 import           Control.Monad
  10 import qualified Data.ByteString.Lazy.Char8 as B
  11 import           Data.ByteString.Lazy.Char8 (ByteString)
  12 import           Data.Map as M
  13 import           Data.Map (Map)
  14 import           Data.Maybe
  15 import qualified Data.Sequence as S
  16 import           Data.Sequence (Seq, (<|), ViewR(..))
  17 import           Network
  18 import           Network.HTTP.Lucu.Config
  19 import           Network.HTTP.Lucu.Chunk
  20 import           Network.HTTP.Lucu.DefaultPage
  21 import           Network.HTTP.Lucu.HttpVersion
  22 import           Network.HTTP.Lucu.Interaction
  23 import           Network.HTTP.Lucu.Parser
  24 import           Network.HTTP.Lucu.Postprocess
  25 import           Network.HTTP.Lucu.Preprocess
  26 import           Network.HTTP.Lucu.Request
  27 import           Network.HTTP.Lucu.Response
  28 import           Network.HTTP.Lucu.Resource
  29 import           Network.HTTP.Lucu.Resource.Tree
  30 import           Prelude hiding (catch)
  31 import           System.IO
  32
  33
  34 requestReader :: Config -> ResTree -> Handle -> HostName -> InteractionQueue -> IO ()
  35 requestReader cnf tree h host tQueue
  36     = do catch (do input <- B.hGetContents h
  37                    acceptRequest input) $ \ exc ->
  38              case exc of
  39                IOException _               -> return ()
  40                AsyncException ThreadKilled -> return ()
  41                BlockedIndefinitely         -> putStrLn "requestReader: blocked indefinitely"
  42                _                           -> print exc
  43     where
  44       acceptRequest :: ByteString -> IO ()
  45       acceptRequest input
  46           -- キューに最大パイプライン深度以上のリクエストが溜まってゐる
  47           -- 時は、それが限度以下になるまで待つ。
  48           = do atomically $ do queue    <- readTVar tQueue
  49                                when (S.length queue >= cnfMaxPipelineDepth cnf)
  50                                     retry
  51
  52                -- リクエストを讀む。パースできない場合は直ちに 400 Bad
  53                -- Request 應答を設定し、それを出力してから切斷するやう
  54                -- に ResponseWriter に通知する。
  55                case parse requestP input of
  56                  (Success req , input') -> acceptParsableRequest req input'
  57                  (IllegalInput, _     ) -> acceptNonparsableRequest BadRequest
  58                  (ReachedEOF  , _     ) -> acceptNonparsableRequest BadRequest
  59
  60       acceptNonparsableRequest :: StatusCode -> IO ()
  61       acceptNonparsableRequest status
  62           = do itr <- newInteraction cnf host Nothing
  63                atomically $ do updateItr itr itrResponse
  64                                              $ \ res -> res {
  65                                                           resStatus = status
  66                                                         }
  67                                writeItr itr itrWillClose True
  68                                writeItr itr itrState     Done
  69                                writeDefaultPage itr
  70                                postprocess itr
  71                                enqueue itr
  72
  73       acceptParsableRequest :: Request -> ByteString -> IO ()
  74       acceptParsableRequest req input
  75           = do itr <- newInteraction cnf host (Just req)
  76                action
  77                    <- atomically $
  78                       do preprocess itr
  79                          isErr <- readItr itr itrResponse (isError . resStatus)
  80                          if isErr then
  81                              acceptSemanticallyInvalidRequest itr input
  82                            else
  83                              case findResource tree $ reqURI req of
  84                                Nothing -- Resource が無かった
  85                                    -> acceptRequestForNonexistentResource itr input
  86
  87                                Just (rsrcPath, rsrcDef) -- あった
  88                                    -> acceptRequestForExistentResource itr input rsrcPath rsrcDef
  89                action
  90
  91       acceptSemanticallyInvalidRequest :: Interaction -> ByteString -> STM (IO ())
  92       acceptSemanticallyInvalidRequest itr input
  93           = do writeItr itr itrState Done
  94                writeDefaultPage itr
  95                postprocess itr
  96                enqueue itr
  97                return $ acceptRequest input
  98
  99       acceptRequestForNonexistentResource :: Interaction -> ByteString -> STM (IO ())
 100       acceptRequestForNonexistentResource itr input
 101           = do updateItr itr itrResponse
 102                              $ \res -> res {
 103                                          resStatus = NotFound
 104                                        }
 105                writeItr itr itrState Done
 106                writeDefaultPage itr
 107                postprocess itr
 108                enqueue itr
 109                return $ acceptRequest input
 110
 111       acceptRequestForExistentResource :: Interaction -> ByteString -> [String] -> ResourceDef -> STM (IO ())
 112       acceptRequestForExistentResource oldItr input rsrcPath rsrcDef
 113           = do let itr = oldItr { itrResourcePath = Just rsrcPath }
 114                requestHasBody <- readItr itr itrRequestHasBody id
 115                enqueue itr
 116                return $ do runResource rsrcDef itr
 117                            if requestHasBody then
 118                                observeRequest itr input
 119                              else
 120                                acceptRequest input
 121
 122       observeRequest :: Interaction -> ByteString -> IO ()
 123       observeRequest itr input
 124           = do isChunked <- atomically $ readItr itr itrRequestIsChunked id
 125                if isChunked then
 126                    observeChunkedRequest itr input
 127                  else
 128                    observeNonChunkedRequest itr input
 129
 130       observeChunkedRequest :: Interaction -> ByteString -> IO ()
 131       observeChunkedRequest itr input
 132           = do action
 133                    <- atomically $
 134                       do isOver <- readItr itr itrReqChunkIsOver id
 135                          if isOver then
 136                              return $ acceptRequest input
 137                            else
 138                              do wantedM <- readItr itr itrReqBodyWanted id
 139                                 if wantedM == Nothing then
 140                                     do wasteAll <- readItr itr itrReqBodyWasteAll id
 141                                        if wasteAll then
 142                                            -- 破棄要求が來た
 143                                            do remainingM <- readItr itr itrReqChunkRemaining id
 144                                               if fmap (> 0) remainingM == Just True then
 145                                                   -- 現在のチャンクをまだ
 146                                                   -- 讀み終へてゐない
 147                                                   do let (_, input') = B.splitAt (fromIntegral
 148                                                                                   $ fromJust remainingM) input
 149                                                          (footerR, input'') = parse chunkFooterP input'
 150
 151                                                      if footerR == Success () then
 152                                                          -- チャンクフッタを正常に讀めた
 153                                                          do writeItr itr itrReqChunkRemaining $ Just 0
 154
 155                                                             return $ observeChunkedRequest itr input''
 156                                                        else
 157                                                          return $ chunkWasMalformed itr
 158                                                 else
 159                                                   -- 次のチャンクを讀み始める
 160                                                   seekNextChunk itr input
 161                                          else
 162                                            -- 要求がまだ來ない
 163                                            retry
 164                                   else
 165                                     -- 受信要求が來た
 166                                     do remainingM <- readItr itr itrReqChunkRemaining id
 167                                        if fmap (> 0) remainingM == Just True then
 168                                            -- 現在のチャンクをまだ讀み
 169                                            -- 終へてゐない
 170                                            do let wanted             = fromJust wantedM
 171                                                   remaining          = fromJust remainingM
 172                                                   bytesToRead        = fromIntegral $ min wanted remaining
 173                                                   (chunk, input')    = B.splitAt bytesToRead input
 174                                                   actualReadBytes    = fromIntegral $ B.length chunk
 175                                                   newWanted          = case wanted - actualReadBytes of
 176                                                                          0 -> Nothing
 177                                                                          n -> Just n
 178                                                   newRemaining       = Just $ remaining - actualReadBytes
 179                                                   updateStates
 180                                                       = do writeItr itr itrReqChunkRemaining newRemaining
 181                                                            writeItr itr itrReqBodyWanted newWanted
 182                                                            updateItr itr itrReceivedBody $ flip B.append chunk
 183
 184                                               if newRemaining == Just 0 then
 185                                                   -- チャンクフッタを讀む
 186                                                   case parse chunkFooterP input' of
 187                                                     (Success _, input'')
 188                                                         -> do updateStates
 189                                                               return $ observeChunkedRequest itr input''
 190                                                     _   -> return $ chunkWasMalformed itr
 191                                                 else
 192                                                   -- まだチャンクの終はりに達してゐない
 193                                                   do updateStates
 194                                                      return $ observeChunkedRequest itr input'
 195                                          else
 196                                            -- 次のチャンクを讀み始める
 197                                            seekNextChunk itr input
 198                action
 199
 200       seekNextChunk :: Interaction -> ByteString -> STM (IO ())
 201       seekNextChunk itr input
 202           = case parse chunkHeaderP input of
 203               -- 最終チャンク (中身が空)
 204               (Success 0, input')
 205                   -> case parse chunkTrailerP input' of
 206                        (Success _, input'')
 207                            -> do writeItr itr itrReqChunkLength $ Nothing
 208                                  writeItr itr itrReqChunkRemaining $ Nothing
 209                                  writeItr itr itrReqChunkIsOver True
 210
 211                                  return $ acceptRequest input''
 212                        _   -> return $ chunkWasMalformed itr
 213               -- 最終でないチャンク
 214               (Success len, input')
 215                   -> do writeItr itr itrReqChunkLength $ Just len
 216                         writeItr itr itrReqChunkRemaining $ Just len
 217
 218                         return $ observeChunkedRequest itr input'
 219               -- チャンクヘッダがをかしい
 220               _   -> return $ chunkWasMalformed itr
 221
 222       chunkWasMalformed :: Interaction -> IO ()
 223       chunkWasMalformed itr
 224           = atomically $ do updateItr itr itrResponse
 225                                           $ \ res -> res {
 226                                                        resStatus = BadRequest
 227                                                      }
 228                             writeItr itr itrWillClose True
 229                             writeItr itr itrState Done
 230                             writeDefaultPage itr
 231                             postprocess itr
 232
 233       observeNonChunkedRequest :: Interaction -> ByteString -> IO ()
 234       observeNonChunkedRequest itr input
 235           = do action
 236                    <- atomically $
 237                       do wantedM <- readItr itr itrReqBodyWanted id
 238                          if wantedM == Nothing then
 239                              do wasteAll <- readItr itr itrReqBodyWasteAll id
 240                                 if wasteAll then
 241                                     -- 破棄要求が來た
 242                                     do remainingM <- readItr itr itrReqChunkRemaining id
 243
 244                                        let (_, input') = if remainingM == Nothing then
 245                                                              (B.takeWhile (\ _ -> True) input, B.empty)
 246                                                          else
 247                                                              B.splitAt (fromIntegral $ fromJust remainingM) input
 248
 249                                        writeItr itr itrReqChunkRemaining $ Just 0
 250                                        writeItr itr itrReqChunkIsOver True
 251
 252                                        return $ acceptRequest input'
 253                                   else
 254                                     -- 要求がまだ来ない
 255                                     retry
 256                            else
 257                                -- 受信要求が來た
 258                                do remainingM <- readItr itr itrReqChunkRemaining id
 259
 260                                   let wanted          = fromJust wantedM
 261                                       bytesToRead     = fromIntegral $ maybe wanted (min wanted) remainingM
 262                                       (chunk, input') = B.splitAt bytesToRead input
 263                                       newRemaining    = fmap
 264                                                         (\ x -> x - (fromIntegral $ B.length chunk))
 265                                                         remainingM
 266                                       isOver          = B.length chunk < bytesToRead || newRemaining == Just 0
 267
 268                                   writeItr itr itrReqChunkRemaining newRemaining
 269                                   writeItr itr itrReqChunkIsOver isOver
 270                                   writeItr itr itrReqBodyWanted Nothing
 271                                   writeItr itr itrReceivedBody chunk
 272
 273                                   if isOver then
 274                                       return $ acceptRequest input'
 275                                     else
 276                                       return $ observeNonChunkedRequest itr input'
 277                action
 278
 279       enqueue :: Interaction -> STM ()
 280       enqueue itr = do queue <- readTVar tQueue
 281                        writeTVar tQueue (itr <| queue)