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