Network/HTTP/Lucu/RequestReader.hs

   1 module Network.HTTP.Lucu.RequestReader
   2     ( requestReader
   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.Maybe
  12 import qualified Data.Sequence as S
  13 import           Data.Sequence ((<|))
  14 import           GHC.Conc (unsafeIOToSTM)
  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 -> [FallbackHandler] -> Handle -> SockAddr -> InteractionQueue -> IO ()
  31 requestReader cnf tree fbs h addr tQueue
  32     = cnf `seq` tree `seq` fbs `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           = {-# SCC "acceptRequest" #-}
  46             do atomically $ do queue    <- readTVar tQueue
  47                                when (S.length queue >= cnfMaxPipelineDepth cnf)
  48                                     retry
  49
  50                -- リクエストを讀む。パースできない場合は直ちに 400 Bad
  51                -- Request 應答を設定し、それを出力してから切斷するやう
  52                -- に ResponseWriter に通知する。
  53                case parse requestP input of
  54                  (# Success req , input' #) -> acceptParsableRequest req input'
  55                  (# IllegalInput, _      #) -> acceptNonparsableRequest BadRequest
  56                  (# ReachedEOF  , _      #) -> acceptNonparsableRequest BadRequest
  57
  58       acceptNonparsableRequest :: StatusCode -> IO ()
  59       acceptNonparsableRequest status
  60           = {-# SCC "acceptNonparsableRequest" #-}
  61             do itr <- newInteraction cnf addr Nothing
  62                atomically $ do updateItr itr itrResponse
  63                                              $ \ res -> res {
  64                                                           resStatus = status
  65                                                         }
  66                                writeItr itr itrWillClose True
  67                                writeItr itr itrState     Done
  68                                writeDefaultPage itr
  69                                postprocess itr
  70                                enqueue itr
  71
  72       acceptParsableRequest :: Request -> ByteString -> IO ()
  73       acceptParsableRequest req input
  74           = {-# SCC "acceptParsableRequest" #-}
  75             do itr <- newInteraction cnf addr (Just req)
  76                action
  77                    <- atomically $
  78                       do preprocess itr
  79                          isErr <- readItr itr itrResponse (isError . resStatus)
  80                          if isErr then
  81                              acceptSemanticallyInvalidRequest itr input
  82                            else
  83                              do rsrcM <- unsafeIOToSTM $ findResource tree fbs $ reqURI req
  84                                 case rsrcM 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           = {-# SCC "acceptSemanticallyInvalidRequest" #-}
  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           = {-# SCC "acceptRequestForNonexistentResource" #-}
 104             do updateItr itr itrResponse
 105                              $ \res -> res {
 106                                          resStatus = NotFound
 107                                        }
 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           = {-# SCC "acceptRequestForExistentResource" #-}
 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           = {-# SCC "observeRequest" #-}
 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           = {-# SCC "observeChunkedRequest" #-}
 138             do action
 139                    <- atomically $
 140                       do isOver <- readItr itr itrReqChunkIsOver id
 141                          if isOver then
 142                              return $ acceptRequest input
 143                            else
 144                              do wantedM <- readItr itr itrReqBodyWanted id
 145                                 if wantedM == Nothing then
 146                                     do wasteAll <- readItr itr itrReqBodyWasteAll id
 147                                        if wasteAll then
 148                                            -- 破棄要求が來た
 149                                            do remainingM <- readItr itr itrReqChunkRemaining id
 150                                               if fmap (> 0) remainingM == Just True then
 151                                                   -- 現在のチャンクをまだ
 152                                                   -- 讀み終へてゐない
 153                                                   do let (_, input') = B.splitAt (fromIntegral
 154                                                                                   $ fromJust remainingM) input
 155                                                          (# footerR, input'' #) = parse chunkFooterP input'
 156
 157                                                      if footerR == Success () then
 158                                                          -- チャンクフッタを正常に讀めた
 159                                                          do writeItr itr itrReqChunkRemaining $ Just 0
 160
 161                                                             return $ observeChunkedRequest itr input''
 162                                                        else
 163                                                          return $ chunkWasMalformed itr
 164                                                 else
 165                                                   -- 次のチャンクを讀み始める
 166                                                   seekNextChunk itr input
 167                                          else
 168                                            -- 要求がまだ來ない
 169                                            retry
 170                                   else
 171                                     -- 受信要求が來た
 172                                     do remainingM <- readItr itr itrReqChunkRemaining id
 173                                        if fmap (> 0) remainingM == Just True then
 174                                            -- 現在のチャンクをまだ讀み
 175                                            -- 終へてゐない
 176                                            do let wanted             = fromJust wantedM
 177                                                   remaining          = fromJust remainingM
 178                                                   bytesToRead        = fromIntegral $ min wanted remaining
 179                                                   (chunk, input')    = B.splitAt bytesToRead input
 180                                                   actualReadBytes    = fromIntegral $ B.length chunk
 181                                                   newWanted          = case wanted - actualReadBytes of
 182                                                                          0 -> Nothing
 183                                                                          n -> Just n
 184                                                   newRemaining       = Just $ remaining - actualReadBytes
 185                                                   updateStates
 186                                                       = do writeItr itr itrReqChunkRemaining newRemaining
 187                                                            writeItr itr itrReqBodyWanted newWanted
 188                                                            updateItr itr itrReceivedBody $ flip B.append chunk
 189
 190                                               if newRemaining == Just 0 then
 191                                                   -- チャンクフッタを讀む
 192                                                   case parse chunkFooterP input' of
 193                                                     (# Success _, input'' #)
 194                                                         -> do updateStates
 195                                                               return $ observeChunkedRequest itr input''
 196                                                     (# _, _ #)
 197                                                         -> return $ chunkWasMalformed itr
 198                                                 else
 199                                                   -- まだチャンクの終はりに達してゐない
 200                                                   do updateStates
 201                                                      return $ observeChunkedRequest itr input'
 202                                          else
 203                                            -- 次のチャンクを讀み始める
 204                                            seekNextChunk itr input
 205                action
 206
 207       seekNextChunk :: Interaction -> ByteString -> STM (IO ())
 208       seekNextChunk itr input
 209           = {-# SCC "seekNextChunk" #-}
 210             case parse chunkHeaderP input of
 211               -- 最終チャンク (中身が空)
 212               (# Success 0, input' #)
 213                   -> case parse chunkTrailerP input' of
 214                        (# Success _, input'' #)
 215                            -> do writeItr itr itrReqChunkLength $ Nothing
 216                                  writeItr itr itrReqChunkRemaining $ Nothing
 217                                  writeItr itr itrReqChunkIsOver True
 218
 219                                  return $ acceptRequest input''
 220                        (# _, _ #)
 221                            -> return $ chunkWasMalformed itr
 222               -- 最終でないチャンク
 223               (# Success len, input' #)
 224                   -> do writeItr itr itrReqChunkLength $ Just len
 225                         writeItr itr itrReqChunkRemaining $ Just len
 226
 227                         return $ observeChunkedRequest itr input'
 228               -- チャンクヘッダがをかしい
 229               (# _, _ #)
 230                   -> return $ chunkWasMalformed itr
 231
 232       chunkWasMalformed :: Interaction -> IO ()
 233       chunkWasMalformed itr
 234           = {-# SCC "chunkWasMalformed" #-}
 235             atomically $ do updateItr itr itrResponse
 236                                           $ \ res -> res {
 237                                                        resStatus = BadRequest
 238                                                      }
 239                             writeItr itr itrWillClose True
 240                             writeItr itr itrState Done
 241                             writeDefaultPage itr
 242                             postprocess itr
 243
 244       observeNonChunkedRequest :: Interaction -> ByteString -> IO ()
 245       observeNonChunkedRequest itr input
 246           = {-# SCC "observeNonChunkedRequest" #-}
 247             do action
 248                    <- atomically $
 249                       do wantedM <- readItr itr itrReqBodyWanted id
 250                          if wantedM == Nothing then
 251                              do wasteAll <- readItr itr itrReqBodyWasteAll id
 252                                 if wasteAll then
 253                                     -- 破棄要求が來た
 254                                     do remainingM <- readItr itr itrReqChunkRemaining id
 255
 256                                        let (_, input') = if remainingM == Nothing then
 257                                                              (B.takeWhile (\ _ -> True) input, B.empty)
 258                                                          else
 259                                                              B.splitAt (fromIntegral $ fromJust remainingM) input
 260
 261                                        writeItr itr itrReqChunkRemaining $ Just 0
 262                                        writeItr itr itrReqChunkIsOver True
 263
 264                                        return $ acceptRequest input'
 265                                   else
 266                                     -- 要求がまだ来ない
 267                                     retry
 268                            else
 269                                -- 受信要求が來た
 270                                do remainingM <- readItr itr itrReqChunkRemaining id
 271
 272                                   let wanted          = fromJust wantedM
 273                                       bytesToRead     = fromIntegral $ maybe wanted (min wanted) remainingM
 274                                       (chunk, input') = B.splitAt bytesToRead input
 275                                       newRemaining    = fmap
 276                                                         (\ x -> x - (fromIntegral $ B.length chunk))
 277                                                         remainingM
 278                                       isOver          = B.length chunk < bytesToRead || newRemaining == Just 0
 279
 280                                   writeItr itr itrReqChunkRemaining newRemaining
 281                                   writeItr itr itrReqChunkIsOver isOver
 282                                   writeItr itr itrReqBodyWanted Nothing
 283                                   writeItr itr itrReceivedBody chunk
 284
 285                                   if isOver then
 286                                       return $ acceptRequest input'
 287                                     else
 288                                       return $ observeNonChunkedRequest itr input'
 289                action
 290
 291       enqueue :: Interaction -> STM ()
 292       enqueue itr = {-# SCC "enqueue" #-}
 293                     do queue <- readTVar tQueue
 294                        writeTVar tQueue (itr <| queue)