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