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