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                let res = Response {
  64                            resVersion = HttpVersion 1 1
  65                          , resStatus  = status
  66                          , resHeaders = []
  67                          }
  68                atomically $ do writeItr itr itrResponse $ Just res
  69                                writeItr itr itrWillClose True
  70                                writeItr itr itrState     Done
  71                                writeDefaultPage itr
  72                                postprocess itr
  73                                enqueue itr
  74
  75       acceptParsableRequest :: Request -> ByteString -> IO ()
  76       acceptParsableRequest req input
  77           = do itr <- newInteraction cnf host (Just req)
  78                action
  79                    <- atomically $
  80                       do preprocess itr
  81                          isErr <- readItrF itr itrResponse (isError . resStatus)
  82                          if isErr == Just True then
  83                              acceptSemanticallyInvalidRequest itr input
  84                            else
  85                              case findResource tree $ (reqURI . fromJust . itrRequest) itr of
  86                                Nothing -- Resource が無かった
  87                                    -> acceptRequestForNonexistentResource itr input
  88
  89                                Just (rsrcPath, rsrcDef) -- あった
  90                                    -> acceptRequestForExistentResource itr input rsrcPath rsrcDef
  91                action
  92
  93       acceptSemanticallyInvalidRequest :: Interaction -> ByteString -> STM (IO ())
  94       acceptSemanticallyInvalidRequest itr input
  95           = do writeItr itr itrState Done
  96                writeDefaultPage itr
  97                postprocess itr
  98                enqueue itr
  99                return $ acceptRequest input
 100
 101       acceptRequestForNonexistentResource :: Interaction -> ByteString -> STM (IO ())
 102       acceptRequestForNonexistentResource itr input
 103           = do let res = Response {
 104                            resVersion = HttpVersion 1 1
 105                          , resStatus  = NotFound
 106                          , resHeaders = []
 107                          }
 108                writeItr itr itrResponse $ Just res
 109                writeItr itr itrState Done
 110                writeDefaultPage itr
 111                postprocess itr
 112                enqueue itr
 113                return $ acceptRequest input
 114
 115       acceptRequestForExistentResource :: Interaction -> ByteString -> [String] -> ResourceDef -> STM (IO ())
 116       acceptRequestForExistentResource oldItr input rsrcPath rsrcDef
 117           = do let itr = oldItr { itrResourcePath = Just rsrcPath }
 118                requestHasBody <- readItr itr itrRequestHasBody id
 119                enqueue itr
 120                return $ do runResource rsrcDef itr
 121                            if requestHasBody then
 122                                observeRequest itr input
 123                              else
 124                                acceptRequest input
 125
 126       observeRequest :: Interaction -> ByteString -> IO ()
 127       observeRequest itr input
 128           = do isChunked <- atomically $ readItr itr itrRequestIsChunked id
 129                if isChunked then
 130                    observeChunkedRequest itr input
 131                  else
 132                    observeNonChunkedRequest itr input
 133
 134       observeChunkedRequest :: Interaction -> ByteString -> IO ()
 135       observeChunkedRequest itr input
 136           = do action
 137                    <- atomically $
 138                       do isOver <- readItr itr itrReqChunkIsOver id
 139                          if isOver then
 140                              return $ acceptRequest input
 141                            else
 142                              do wantedM <- readItr itr itrReqBodyWanted id
 143                                 if wantedM == Nothing then
 144                                     do wasteAll <- readItr itr itrReqBodyWasteAll id
 145                                        if wasteAll then
 146                                            -- 破棄要求が來た
 147                                            do remainingM <- readItr itr itrReqChunkRemaining id
 148                                               if fmap (> 0) remainingM == Just True then
 149                                                   -- 現在のチャンクをまだ
 150                                                   -- 讀み終へてゐない
 151                                                   do let (_, input') = B.splitAt (fromIntegral
 152                                                                                   $ fromJust remainingM) input
 153                                                          (footerR, input'') = parse chunkFooterP input'
 154
 155                                                      if footerR == Success () then
 156                                                          -- チャンクフッタを正常に讀めた
 157                                                          do writeItr itr itrReqChunkRemaining $ Just 0
 158
 159                                                             return $ observeChunkedRequest itr input''
 160                                                        else
 161                                                          return $ chunkWasMalformed itr
 162                                                 else
 163                                                   -- 次のチャンクを讀み始める
 164                                                   seekNextChunk itr input
 165                                          else
 166                                            -- 要求がまだ來ない
 167                                            retry
 168                                   else
 169                                     -- 受信要求が來た
 170                                     do remainingM <- readItr itr itrReqChunkRemaining id
 171                                        if fmap (> 0) remainingM == Just True then
 172                                            -- 現在のチャンクをまだ讀み
 173                                            -- 終へてゐない
 174                                            do let wanted             = fromJust wantedM
 175                                                   remaining          = fromJust remainingM
 176                                                   bytesToRead        = fromIntegral $ min wanted remaining
 177                                                   (chunk, input')    = B.splitAt bytesToRead input
 178                                                   actualReadBytes    = fromIntegral $ B.length chunk
 179                                                   newWanted          = case wanted - actualReadBytes of
 180                                                                          0 -> Nothing
 181                                                                          n -> Just n
 182                                                   newRemaining       = Just $ remaining - actualReadBytes
 183                                                   updateStates
 184                                                       = do writeItr itr itrReqChunkRemaining newRemaining
 185                                                            writeItr itr itrReqBodyWanted newWanted
 186                                                            updateItr itr itrReceivedBody $ flip B.append chunk
 187
 188                                               if newRemaining == Just 0 then
 189                                                   -- チャンクフッタを讀む
 190                                                   case parse chunkFooterP input' of
 191                                                     (Success _, input'')
 192                                                         -> do updateStates
 193                                                               return $ observeChunkedRequest itr input''
 194                                                     _   -> return $ chunkWasMalformed itr
 195                                                 else
 196                                                   -- まだチャンクの終はりに達してゐない
 197                                                   do updateStates
 198                                                      return $ observeChunkedRequest itr input'
 199                                          else
 200                                            -- 次のチャンクを讀み始める
 201                                            seekNextChunk itr input
 202                action
 203
 204       seekNextChunk :: Interaction -> ByteString -> STM (IO ())
 205       seekNextChunk itr input
 206           = case parse chunkHeaderP input of
 207               -- 最終チャンク (中身が空)
 208               (Success 0, input')
 209                   -> case parse chunkTrailerP input' of
 210                        (Success _, input'')
 211                            -> do writeItr itr itrReqChunkLength $ Nothing
 212                                  writeItr itr itrReqChunkRemaining $ Nothing
 213                                  writeItr itr itrReqChunkIsOver True
 214
 215                                  return $ acceptRequest input''
 216                        _   -> return $ chunkWasMalformed itr
 217               -- 最終でないチャンク
 218               (Success len, input')
 219                   -> do writeItr itr itrReqChunkLength $ Just len
 220                         writeItr itr itrReqChunkRemaining $ Just len
 221
 222                         return $ observeChunkedRequest itr input'
 223               -- チャンクヘッダがをかしい
 224               _   -> return $ chunkWasMalformed itr
 225
 226       chunkWasMalformed :: Interaction -> IO ()
 227       chunkWasMalformed itr
 228           = let res = Response {
 229                         resVersion = HttpVersion 1 1
 230                       , resStatus  = BadRequest
 231                       , resHeaders = []
 232                       }
 233             in
 234               atomically $ do writeItr itr itrResponse $ Just res
 235                               writeItr itr itrWillClose True
 236                               writeItr itr itrState Done
 237                               writeDefaultPage itr
 238                               postprocess itr
 239
 240       observeNonChunkedRequest :: Interaction -> ByteString -> IO ()
 241       observeNonChunkedRequest itr input
 242           = do action
 243                    <- atomically $
 244                       do wantedM <- readItr itr itrReqBodyWanted id
 245                          if wantedM == Nothing then
 246                              do wasteAll <- readItr itr itrReqBodyWasteAll id
 247                                 if wasteAll then
 248                                     -- 破棄要求が來た
 249                                     do remainingM <- readItr itr itrReqChunkRemaining id
 250
 251                                        let (_, input') = if remainingM == Nothing then
 252                                                              (B.takeWhile (\ _ -> True) input, B.empty)
 253                                                          else
 254                                                              B.splitAt (fromIntegral $ fromJust remainingM) input
 255
 256                                        writeItr itr itrReqChunkRemaining $ Just 0
 257                                        writeItr itr itrReqChunkIsOver True
 258
 259                                        return $ acceptRequest input'
 260                                   else
 261                                     -- 要求がまだ来ない
 262                                     retry
 263                            else
 264                                -- 受信要求が來た
 265                                do remainingM <- readItr itr itrReqChunkRemaining id
 266
 267                                   let wanted          = fromJust wantedM
 268                                       bytesToRead     = fromIntegral $ maybe wanted (min wanted) remainingM
 269                                       (chunk, input') = B.splitAt bytesToRead input
 270                                       newRemaining    = fmap
 271                                                         (\ x -> x - (fromIntegral $ B.length chunk))
 272                                                         remainingM
 273                                       isOver          = B.length chunk < bytesToRead || newRemaining == Just 0
 274
 275                                   writeItr itr itrReqChunkRemaining newRemaining
 276                                   writeItr itr itrReqChunkIsOver isOver
 277                                   writeItr itr itrReqBodyWanted Nothing
 278                                   writeItr itr itrReceivedBody chunk
 279
 280                                   if isOver then
 281                                       return $ acceptRequest input'
 282                                     else
 283                                       return $ observeNonChunkedRequest itr input'
 284                action
 285
 286       enqueue :: Interaction -> STM ()
 287       enqueue itr = do queue <- readTVar tQueue
 288                        writeTVar tQueue (itr <| queue)