- askForInput :: Interaction -> Resource ByteString
- askForInput itr
- = do let defaultLimit = cnfMaxEntityLength $ itrConfig itr
- actualLimit = if limit <= 0 then
- defaultLimit
- else
- limit
- when (actualLimit <= 0)
- $ fail ("inputBS: limit must be positive: " ++ show actualLimit)
- -- Reader にリクエスト
- liftIO $ atomically
- $ do chunkLen <- readItr itr itrReqChunkLength id
- writeItr itr itrWillReceiveBody True
- if fmap (> actualLimit) chunkLen == Just True then
- -- 受信前から多過ぎる事が分かってゐる
- tooLarge actualLimit
- else
- writeItr itr itrReqBodyWanted $ Just actualLimit
- -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
- chunk <- liftIO $ atomically
- $ do chunk <- readItr itr itrReceivedBody id
- chunkIsOver <- readItr itr itrReqChunkIsOver id
- if B.length chunk < fromIntegral actualLimit then
- -- 要求された量に滿たなくて、まだ殘り
- -- があるなら再試行。
- unless chunkIsOver
- $ retry
- else
- -- 制限値一杯まで讀むやうに指示したの
- -- にまだ殘ってゐるなら、それは多過ぎ
- -- る。
- unless chunkIsOver
- $ tooLarge actualLimit
- -- 成功。itr 内にチャンクを置いたままにす
- -- るとメモリの無駄になるので除去。
- writeItr itr itrReceivedBody B.empty
- return chunk
- driftTo DecidingHeader
- return chunk
-
- tooLarge :: Int -> STM ()
- tooLarge lim = abortSTM RequestEntityTooLarge []
- $ Just ("Request body must be smaller than "
- ++ show lim ++ " bytes.")
-
--- | Computation of @'inputChunk' limit@ attempts to read a part of
--- request body up to @limit@ bytes. You can read any large request by
--- repeating computation of this action. When you've read all the
--- request body, 'inputChunk' returns an empty string and then make
--- the 'Resource' transit to /Deciding Header/ state.
---
--- @limit@ may be less than or equal to zero. In this case, the
--- default limitation value
--- ('Network.HTTP.Lucu.Config.cnfMaxEntityLength') is used. See
--- 'defaultLimit'.
---
--- Note that 'inputChunkBS' is more efficient than 'inputChunk' so you
--- should use it whenever possible.
-inputChunk :: Int -> Resource String
-inputChunk limit = inputChunkBS limit >>= return . B.unpack
-
-
--- | This is mostly the same as 'inputChunk' but is more
--- efficient. See 'inputBS'.
-inputChunkBS :: Int -> Resource ByteString
-inputChunkBS limit
- = do driftTo GettingBody
- itr <- ask
- hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id
- chunk <- if hasBody then
- askForInput itr
- else
- do driftTo DecidingHeader
- return B.empty
- return chunk
- where
- askForInput :: Interaction -> Resource ByteString
- askForInput itr
- = do let defaultLimit = cnfMaxEntityLength $ itrConfig itr
- actualLimit = if limit < 0 then
- defaultLimit
- else
- limit
- when (actualLimit <= 0)
- $ fail ("inputChunkBS: limit must be positive: " ++ show actualLimit)
- -- Reader にリクエスト
- liftIO $ atomically
- $ do writeItr itr itrReqBodyWanted $ Just actualLimit
- writeItr itr itrWillReceiveBody True
- -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
- chunk <- liftIO $ atomically
- $ do chunk <- readItr itr itrReceivedBody id
- -- 要求された量に滿たなくて、まだ殘りがあ
- -- るなら再試行。
- when (B.length chunk < fromIntegral actualLimit)
- $ do chunkIsOver <- readItr itr itrReqChunkIsOver id
- unless chunkIsOver
- $ retry
- -- 成功
- writeItr itr itrReceivedBody B.empty
- return chunk
- when (B.null chunk)
- $ driftTo DecidingHeader
- return chunk
-
--- | Computation of @'inputForm' limit@ attempts to read the request
--- body with 'input' and parse it as
--- application\/x-www-form-urlencoded. If the request header
--- \"Content-Type\" is not application\/x-www-form-urlencoded,
--- 'inputForm' makes 'Resource' abort with status \"415 Unsupported
+ go ∷ Int → Seq Strict.ByteString → Resource Lazy.ByteString
+ go 0 _ = abort RequestEntityTooLarge []
+ (Just $ "Request body must be smaller than "
+ ⊕ T.pack (show limit) ⊕ " bytes.")
+ go n xs = do let n' = min n Lazy.defaultChunkSize
+ chunk ← getChunk n'
+ if Strict.null chunk then
+ -- Got EOF
+ return $ Lazy.fromChunks $ toList xs
+ else
+ do let n'' = n' - Strict.length chunk
+ xs' = xs ⊳ chunk
+ go n'' xs'
+
+-- |@'getForm' limit@ attempts to read the request body with
+-- 'getChunks' and parse it as @application\/x-www-form-urlencoded@ or
+-- @multipart\/form-data@. If the request header \"Content-Type\" is
+-- neither of them, 'getForm' aborts with status \"415 Unsupported