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           Network.Socket
  15 import           Network.HTTP.Lucu.Config
  16 import           Network.HTTP.Lucu.Chunk
  17 import           Network.HTTP.Lucu.DefaultPage
  18 import           Network.HTTP.Lucu.Interaction
  19 import           Network.HTTP.Lucu.Parser
  20 import           Network.HTTP.Lucu.Postprocess
  21 import           Network.HTTP.Lucu.Preprocess
  22 import           Network.HTTP.Lucu.Request
  23 import           Network.HTTP.Lucu.Response
  24 import           Network.HTTP.Lucu.Resource.Tree
  25 import           Prelude hiding (catch)
  26 import           System.IO
  27
  28
  29 requestReader :: Config -> ResTree -> Handle -> SockAddr -> InteractionQueue -> IO ()
  30 requestReader cnf tree h addr tQueue
  31     = cnf `seq` tree `seq` h `seq` addr `seq` tQueue `seq`
  32       do catch (do input <- B.hGetContents h
  33                    acceptRequest input) $ \ exc ->
  34              case exc of
  35                IOException _               -> return ()
  36                AsyncException ThreadKilled -> return ()
  37                BlockedIndefinitely         -> putStrLn "requestReader: blocked indefinitely"
  38                _                           -> print exc
  39     where
  40       acceptRequest :: ByteString -> IO ()
  41       acceptRequest input
  42           -- キューに最大パイプライン深度以上のリクエストが溜まってゐる
  43           -- 時は、それが限度以下になるまで待つ。
  44           = {-# SCC "acceptRequest" #-}
  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           = {-# SCC "acceptNonparsableRequest" #-}
  60             do itr <- newInteraction cnf addr Nothing
  61                atomically $ do updateItr itr itrResponse
  62                                              $ \ res -> res {
  63                                                           resStatus = status
  64                                                         }
  65                                writeItr itr itrWillClose True
  66                                writeItr itr itrState     Done
  67                                writeDefaultPage itr
  68                                postprocess itr
  69                                enqueue itr
  70
  71       acceptParsableRequest :: Request -> ByteString -> IO ()
  72       acceptParsableRequest req input
  73           = {-# SCC "acceptParsableRequest" #-}
  74             do itr <- newInteraction cnf addr (Just req)
  75                action
  76                    <- atomically $
  77                       do preprocess itr
  78                          isErr <- readItr itr itrResponse (isError . resStatus)
  79                          if isErr then
  80                              acceptSemanticallyInvalidRequest itr input
  81                            else
  82                              case findResource tree $ reqURI req of
  83                                Nothing -- Resource が無かった
  84                                    -> acceptRequestForNonexistentResource itr input
  85
  86                                Just (rsrcPath, rsrcDef) -- あった
  87                                    -> acceptRequestForExistentResource itr input rsrcPath rsrcDef
  88                action
  89
  90       acceptSemanticallyInvalidRequest :: Interaction -> ByteString -> STM (IO ())
  91       acceptSemanticallyInvalidRequest itr input
  92           = {-# SCC "acceptSemanticallyInvalidRequest" #-}
  93             do writeItr itr itrState Done
  94                writeDefaultPage itr
  95                postprocess itr
  96                enqueue itr
  97                return $ acceptRequest input
  98
  99       acceptRequestForNonexistentResource :: Interaction -> ByteString -> STM (IO ())
 100       acceptRequestForNonexistentResource itr input
 101           = {-# SCC "acceptRequestForNonexistentResource" #-}
 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           = {-# SCC "acceptRequestForExistentResource" #-}
 115             do let itr = oldItr { itrResourcePath = Just rsrcPath }
 116                requestHasBody <- readItr itr itrRequestHasBody id
 117                enqueue itr
 118                return $ do runResource rsrcDef itr
 119                            if requestHasBody then
 120                                observeRequest itr input
 121                              else
 122                                acceptRequest input
 123
 124       observeRequest :: Interaction -> ByteString -> IO ()
 125       observeRequest itr input
 126           = {-# SCC "observeRequest" #-}
 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           = {-# SCC "observeChunkedRequest" #-}
 136             do action
 137                    <- atomically $
 138                       do isOver <- readItr itr itrReqChunkIsOver id
 139                          if isOver then
 140                              return $ acceptRequest input
 141                            else
 142                              do wantedM <- readItr itr itrReqBodyWanted id
 143                                 if wantedM == Nothing then
 144                                     do wasteAll <- readItr itr itrReqBodyWasteAll id
 145                                        if wasteAll then
 146                                            -- 破棄要求が來た
 147                                            do remainingM <- readItr itr itrReqChunkRemaining id
 148                                               if fmap (> 0) remainingM == Just True then
 149                                                   -- 現在のチャンクをまだ
 150                                                   -- 讀み終へてゐない
 151                                                   do let (_, input') = B.splitAt (fromIntegral
 152                                                                                   $ fromJust remainingM) input
 153                                                          (# footerR, input'' #) = parse chunkFooterP input'
 154
 155                                                      if footerR == Success () then
 156                                                          -- チャンクフッタを正常に讀めた
 157                                                          do writeItr itr itrReqChunkRemaining $ Just 0
 158
 159                                                             return $ observeChunkedRequest itr input''
 160                                                        else
 161                                                          return $ chunkWasMalformed itr
 162                                                 else
 163                                                   -- 次のチャンクを讀み始める
 164                                                   seekNextChunk itr input
 165                                          else
 166                                            -- 要求がまだ來ない
 167                                            retry
 168                                   else
 169                                     -- 受信要求が來た
 170                                     do remainingM <- readItr itr itrReqChunkRemaining id
 171                                        if fmap (> 0) remainingM == Just True then
 172                                            -- 現在のチャンクをまだ讀み
 173                                            -- 終へてゐない
 174                                            do let wanted             = fromJust wantedM
 175                                                   remaining          = fromJust remainingM
 176                                                   bytesToRead        = fromIntegral $ min wanted remaining
 177                                                   (chunk, input')    = B.splitAt bytesToRead input
 178                                                   actualReadBytes    = fromIntegral $ B.length chunk
 179                                                   newWanted          = case wanted - actualReadBytes of
 180                                                                          0 -> Nothing
 181                                                                          n -> Just n
 182                                                   newRemaining       = Just $ remaining - actualReadBytes
 183                                                   updateStates
 184                                                       = do writeItr itr itrReqChunkRemaining newRemaining
 185                                                            writeItr itr itrReqBodyWanted newWanted
 186                                                            updateItr itr itrReceivedBody $ flip B.append chunk
 187
 188                                               if newRemaining == Just 0 then
 189                                                   -- チャンクフッタを讀む
 190                                                   case parse chunkFooterP input' of
 191                                                     (# Success _, input'' #)
 192                                                         -> do updateStates
 193                                                               return $ observeChunkedRequest itr input''
 194                                                     (# _, _ #)
 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           = {-# SCC "seekNextChunk" #-}
 208             case parse chunkHeaderP input of
 209               -- 最終チャンク (中身が空)
 210               (# Success 0, input' #)
 211                   -> case parse chunkTrailerP input' of
 212                        (# Success _, input'' #)
 213                            -> do writeItr itr itrReqChunkLength $ Nothing
 214                                  writeItr itr itrReqChunkRemaining $ Nothing
 215                                  writeItr itr itrReqChunkIsOver True
 216
 217                                  return $ acceptRequest input''
 218                        (# _, _ #)
 219                            -> return $ chunkWasMalformed itr
 220               -- 最終でないチャンク
 221               (# Success len, input' #)
 222                   -> do writeItr itr itrReqChunkLength $ Just len
 223                         writeItr itr itrReqChunkRemaining $ Just len
 224
 225                         return $ observeChunkedRequest itr input'
 226               -- チャンクヘッダがをかしい
 227               (# _, _ #)
 228                   -> return $ chunkWasMalformed itr
 229
 230       chunkWasMalformed :: Interaction -> IO ()
 231       chunkWasMalformed itr
 232           = {-# SCC "chunkWasMalformed" #-}
 233             atomically $ do updateItr itr itrResponse
 234                                           $ \ res -> res {
 235                                                        resStatus = BadRequest
 236                                                      }
 237                             writeItr itr itrWillClose True
 238                             writeItr itr itrState Done
 239                             writeDefaultPage itr
 240                             postprocess itr
 241
 242       observeNonChunkedRequest :: Interaction -> ByteString -> IO ()
 243       observeNonChunkedRequest itr input
 244           = {-# SCC "observeNonChunkedRequest" #-}
 245             do action
 246                    <- atomically $
 247                       do wantedM <- readItr itr itrReqBodyWanted id
 248                          if wantedM == Nothing then
 249                              do wasteAll <- readItr itr itrReqBodyWasteAll id
 250                                 if wasteAll then
 251                                     -- 破棄要求が來た
 252                                     do remainingM <- readItr itr itrReqChunkRemaining id
 253
 254                                        let (_, input') = if remainingM == Nothing then
 255                                                              (B.takeWhile (\ _ -> True) input, B.empty)
 256                                                          else
 257                                                              B.splitAt (fromIntegral $ fromJust remainingM) input
 258
 259                                        writeItr itr itrReqChunkRemaining $ Just 0
 260                                        writeItr itr itrReqChunkIsOver True
 261
 262                                        return $ acceptRequest input'
 263                                   else
 264                                     -- 要求がまだ来ない
 265                                     retry
 266                            else
 267                                -- 受信要求が來た
 268                                do remainingM <- readItr itr itrReqChunkRemaining id
 269
 270                                   let wanted          = fromJust wantedM
 271                                       bytesToRead     = fromIntegral $ maybe wanted (min wanted) remainingM
 272                                       (chunk, input') = B.splitAt bytesToRead input
 273                                       newRemaining    = fmap
 274                                                         (\ x -> x - (fromIntegral $ B.length chunk))
 275                                                         remainingM
 276                                       isOver          = B.length chunk < bytesToRead || newRemaining == Just 0
 277
 278                                   writeItr itr itrReqChunkRemaining newRemaining
 279                                   writeItr itr itrReqChunkIsOver isOver
 280                                   writeItr itr itrReqBodyWanted Nothing
 281                                   writeItr itr itrReceivedBody chunk
 282
 283                                   if isOver then
 284                                       return $ acceptRequest input'
 285                                     else
 286                                       return $ observeNonChunkedRequest itr input'
 287                action
 288
 289       enqueue :: Interaction -> STM ()
 290       enqueue itr = {-# SCC "enqueue" #-}
 291                     do queue <- readTVar tQueue
 292                        writeTVar tQueue (itr <| queue)