- askForInput ∷ Interaction → Resource Lazy.ByteString
- askForInput itr
- = do let confLimit = cnfMaxEntityLength $ itrConfig itr
- actualLimit = if limit ≤ 0 then
- confLimit
- else
- limit
- when (actualLimit ≤ 0)
- $ fail ("inputLBS: limit must be positive: " ⧺ show actualLimit)
- -- Reader にリクエスト
- liftIO $ atomically
- $ do chunkLen ← readItr itrReqChunkLength itr
- writeItr itrWillReceiveBody True itr
- if ((> actualLimit) <$> chunkLen) ≡ Just True then
- -- 受信前から多過ぎる事が分かってゐる
- tooLarge actualLimit
- else
- writeItr itrReqBodyWanted (Just actualLimit) itr
- -- 應答を待つ。トランザクションを分けなければ當然デッドロックする。
- chunk ← liftIO $ atomically
- $ do chunkLen ← readItr itrReceivedBodyLen itr
- chunkIsOver ← readItr itrReqChunkIsOver itr
- if chunkLen < actualLimit then
- -- 要求された量に滿たなくて、まだ殘りが
- -- あるなら再試行。
- unless chunkIsOver
- $ retry
- else
- -- 制限値一杯まで讀むやうに指示したのに
- -- まだ殘ってゐるなら、それは多過ぎる。
- unless chunkIsOver
- $ tooLarge actualLimit
- -- 成功。itr 内にチャンクを置いたままにする
- -- とメモリの無駄になるので除去。
- chunk ← seqToLBS <$> readItr itrReceivedBody itr
- writeItr itrReceivedBody (∅) itr
- writeItr itrReceivedBodyLen 0 itr
- return chunk
-
- driftTo DecidingHeader
- return chunk
-
- tooLarge ∷ Int → STM ()
- tooLarge lim = abortSTM RequestEntityTooLarge []
- (Just $ "Request body must be smaller than "
- ⊕ T.pack (show lim) ⊕ " bytes.")
-
-seqToLBS ∷ Seq ByteString → Lazy.ByteString
-{-# INLINE seqToLBS #-}
-seqToLBS = Lazy.fromChunks ∘ toList
-
--- | 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 ('cnfMaxEntityLength') is used. See
--- 'defaultLimit'.
---
--- Note that 'inputChunkLBS' is more efficient than 'inputChunk' so you
--- should use it whenever possible.
-inputChunk ∷ Int → Resource Lazy.ByteString
-inputChunk limit
- = do driftTo GettingBody
- itr ← getInteraction
- hasBody ← liftIO $ atomically $ readItr itrRequestHasBody itr
- chunk ← if hasBody then
- askForInput itr
- else
- do driftTo DecidingHeader
- return (∅)
- return chunk
- where
- askForInput ∷ Interaction → Resource Lazy.ByteString
- askForInput itr
- = do let confLimit = cnfMaxEntityLength $ itrConfig itr
- actualLimit = if limit < 0 then
- confLimit
- else
- limit
- when (actualLimit <= 0)
- $ fail ("inputChunkLBS: limit must be positive: " ++ show actualLimit)
- -- Reader にリクエスト
- liftIO $ atomically
- $ do writeItr itrReqBodyWanted (Just actualLimit) itr
- writeItr itrWillReceiveBody True itr
- -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
- chunk ← liftIO $ atomically
- $ do chunkLen ← readItr itrReceivedBodyLen itr
- -- 要求された量に滿たなくて、まだ殘りがある
- -- なら再試行。
- when (chunkLen < actualLimit)
- $ do chunkIsOver ← readItr itrReqChunkIsOver itr
- unless chunkIsOver
- $ retry
- -- 成功
- chunk ← seqToLBS <$> readItr itrReceivedBody itr
- writeItr itrReceivedBody (∅) itr
- writeItr itrReceivedBodyLen 0 itr
- return chunk
- when (Lazy.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@ or @multipart\/form-data@. If
--- the request header \"Content-Type\" is neither of them, 'inputForm'
--- makes 'Resource' abort with status \"415 Unsupported Media
--- Type\". If the request has no \"Content-Type\", it aborts with
--- \"400 Bad Request\".
+ 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
+-- Media Type\". If the request has no \"Content-Type\", it aborts
+-- with \"400 Bad Request\".