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