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