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                writeItr itr itrState (if requestHasBody
 118                                       then ExaminingHeader
 119                                       else DecidingHeader)
 120                enqueue itr
 121                return $ do runResource rsrcDef itr
 122                            if requestHasBody then
 123                                observeRequest itr input
 124                              else
 125                                acceptRequest input
 126
 127       observeRequest :: Interaction -> ByteString -> IO ()
 128       observeRequest itr input
 129           = do isChunked <- atomically $ readItr itr itrRequestIsChunked id
 130                if isChunked then
 131                    observeChunkedRequest itr input
 132                  else
 133                    observeNonChunkedRequest itr input
 134
 135       observeChunkedRequest :: Interaction -> ByteString -> IO ()
 136       observeChunkedRequest itr input
 137           = do action
 138                    <- atomically $
 139                       do isOver <- readItr itr itrReqChunkIsOver id
 140                          if isOver then
 141                              return $ acceptRequest input
 142                            else
 143                              do wantedM <- readItr itr itrReqBodyWanted id
 144                                 if wantedM == Nothing then
 145                                     do wasteAll <- readItr itr itrReqBodyWasteAll id
 146                                        if wasteAll then
 147                                            -- 破棄要求が來た
 148                                            do remainingM <- readItr itr itrReqChunkRemaining id
 149                                               if fmap (> 0) remainingM == Just True then
 150                                                   -- 現在のチャンクをまだ
 151                                                   -- 讀み終へてゐない
 152                                                   do let (_, input') = B.splitAt (fromIntegral
 153                                                                                   $ fromJust remainingM) input
 154                                                          (footerR, input'') = parse chunkFooterP input'
 155
 156                                                      if footerR == Success () then
 157                                                          -- チャンクフッタを正常に讀めた
 158                                                          do writeItr itr itrReqChunkRemaining $ Just 0
 159
 160                                                             return $ observeChunkedRequest itr input''
 161                                                        else
 162                                                          return $ chunkWasMalformed itr
 163                                                 else
 164                                                   -- 次のチャンクを讀み始める
 165                                                   seekNextChunk itr input
 166                                          else
 167                                            -- 要求がまだ來ない
 168                                            retry
 169                                   else
 170                                     -- 受信要求が來た
 171                                     do remainingM <- readItr itr itrReqChunkRemaining id
 172                                        if fmap (> 0) remainingM == Just True then
 173                                            -- 現在のチャンクをまだ讀み
 174                                            -- 終へてゐない
 175                                            do let wanted             = fromJust wantedM
 176                                                   remaining          = fromJust remainingM
 177                                                   bytesToRead        = fromIntegral $ min wanted remaining
 178                                                   (chunk, input')    = B.splitAt bytesToRead input
 179                                                   actualReadBytes    = fromIntegral $ B.length chunk
 180                                                   newWanted          = case wanted - actualReadBytes of
 181                                                                          0 -> Nothing
 182                                                                          n -> Just n
 183                                                   newRemaining       = Just $ remaining - actualReadBytes
 184                                                   updateStates
 185                                                       = do writeItr itr itrReqChunkRemaining newRemaining
 186                                                            writeItr itr itrReqBodyWanted newWanted
 187                                                            updateItr itr itrReceivedBody $ flip B.append chunk
 188
 189                                               if newRemaining == Just 0 then
 190                                                   -- チャンクフッタを讀む
 191                                                   case parse chunkFooterP input' of
 192                                                     (Success _, input'')
 193                                                         -> do updateStates
 194                                                               return $ observeChunkedRequest itr input''
 195                                                     _   -> return $ chunkWasMalformed itr
 196                                                 else
 197                                                   -- まだチャンクの終はりに達してゐない
 198                                                   do updateStates
 199                                                      return $ observeChunkedRequest itr input'
 200                                          else
 201                                            -- 次のチャンクを讀み始める
 202                                            seekNextChunk itr input
 203                action
 204
 205       seekNextChunk :: Interaction -> ByteString -> STM (IO ())
 206       seekNextChunk itr input
 207           = case parse chunkHeaderP input of
 208               -- 最終チャンク (中身が空)
 209               (Success 0, input')
 210                   -> case parse chunkTrailerP input' of
 211                        (Success _, input'')
 212                            -> do writeItr itr itrReqChunkLength $ Nothing
 213                                  writeItr itr itrReqChunkRemaining $ Nothing
 214                                  writeItr itr itrReqChunkIsOver True
 215
 216                                  return $ acceptRequest input''
 217                        _   -> return $ chunkWasMalformed itr
 218               -- 最終でないチャンク
 219               (Success len, input')
 220                   -> do writeItr itr itrReqChunkLength $ Just len
 221                         writeItr itr itrReqChunkRemaining $ Just len
 222
 223                         return $ observeChunkedRequest itr input'
 224               -- チャンクヘッダがをかしい
 225               _   -> return $ chunkWasMalformed itr
 226
 227       chunkWasMalformed :: Interaction -> IO ()
 228       chunkWasMalformed itr
 229           = let res = Response {
 230                         resVersion = HttpVersion 1 1
 231                       , resStatus  = BadRequest
 232                       , resHeaders = []
 233                       }
 234             in
 235               atomically $ do writeItr itr itrResponse $ Just res
 236                               writeItr itr itrWillClose True
 237                               writeItr itr itrState Done
 238                               writeDefaultPage itr
 239                               postprocess itr
 240
 241       observeNonChunkedRequest :: Interaction -> ByteString -> IO ()
 242       observeNonChunkedRequest itr input
 243           = do action
 244                    <- atomically $
 245                       do wantedM <- readItr itr itrReqBodyWanted id
 246                          if wantedM == Nothing then
 247                              do wasteAll <- readItr itr itrReqBodyWasteAll id
 248                                 if wasteAll then
 249                                     -- 破棄要求が來た
 250                                     do remainingM <- readItr itr itrReqChunkRemaining id
 251
 252                                        let (_, input') = if remainingM == Nothing then
 253                                                              (B.takeWhile (\ _ -> True) input, B.empty)
 254                                                          else
 255                                                              B.splitAt (fromIntegral $ fromJust remainingM) input
 256
 257                                        writeItr itr itrReqChunkRemaining $ Just 0
 258                                        writeItr itr itrReqChunkIsOver True
 259
 260                                        return $ acceptRequest input'
 261                                   else
 262                                     -- 要求がまだ来ない
 263                                     retry
 264                            else
 265                                -- 受信要求が來た
 266                                do remainingM <- readItr itr itrReqChunkRemaining id
 267
 268                                   let wanted          = fromJust wantedM
 269                                       bytesToRead     = fromIntegral $ maybe wanted (min wanted) remainingM
 270                                       (chunk, input') = B.splitAt bytesToRead input
 271                                       newRemaining    = fmap
 272                                                         (\ x -> x - (fromIntegral $ B.length chunk))
 273                                                         remainingM
 274                                       isOver          = B.length chunk < bytesToRead || newRemaining == Just 0
 275
 276                                   writeItr itr itrReqChunkRemaining newRemaining
 277                                   writeItr itr itrReqChunkIsOver isOver
 278                                   writeItr itr itrReqBodyWanted Nothing
 279                                   writeItr itr itrReceivedBody chunk
 280
 281                                   if isOver then
 282                                       return $ acceptRequest input'
 283                                     else
 284                                       return $ observeNonChunkedRequest itr input'
 285                action
 286
 287       enqueue :: Interaction -> STM ()
 288       enqueue itr = do queue <- readTVar tQueue
 289                        writeTVar tQueue (itr <| queue)