X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=0dd73c96113971e2aa20d41f71eff4045bc1e6e6;hb=cc55fb9a095c9c583ed6fe2ded3eaf6401fb760f;hp=2672399bf7a249102d2368d387bc529dcfdae017;hpb=db4b61223e0d8b34079d3b190fb3e3644b0b4866;p=Lucu.git diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index 2672399..0dd73c9 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -139,6 +139,8 @@ module Network.HTTP.Lucu.Resource , driftTo -- private ) where +import Blaze.ByteString.Builder (Builder) +import qualified Blaze.ByteString.Builder.ByteString as BB import Control.Applicative import Control.Concurrent.STM import Control.Monad.Reader @@ -148,18 +150,18 @@ import qualified Data.Ascii as A import qualified Data.Attoparsec.Char8 as P import qualified Data.Attoparsec.Lazy as LP import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as C8 -import qualified Data.ByteString.Lazy as Lazy -import qualified Data.ByteString.Lazy.Char8 as L8 +import qualified Data.ByteString as Strict +import qualified Data.ByteString.Lazy as Lazy +import Data.Foldable (toList) import Data.List import qualified Data.Map as M import Data.Maybe +import Data.Monoid import Data.Monoid.Unicode -import qualified Data.Sequence as S +import Data.Sequence (Seq) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T -import qualified Data.Text.Encoding.Error as T import Data.Time import qualified Data.Time.HTTP as HTTP import Network.HTTP.Lucu.Abortion @@ -237,7 +239,7 @@ getRemoteCertificate = itrRemoteCert <$> getInteraction getRequest ∷ Resource Request getRequest = do itr ← getInteraction - liftIO $ atomically $ readItr itrRequest fromJust itr + liftIO $ atomically $ fromJust <$> readItr itrRequest itr -- |Get the 'Method' value of the request. getMethod ∷ Resource Method @@ -273,24 +275,24 @@ getRequestVersion = reqVersion <$> getRequest -- > ... -- > , ... -- > } -getResourcePath ∷ Resource [Ascii] +getResourcePath ∷ Resource [Text] getResourcePath = (fromJust ∘ itrResourcePath) <$> getInteraction -- |This is an analogy of CGI PATH_INFO. The result is -- URI-unescaped. It is always @[]@ if the -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not greedy. See -- 'getResourcePath'. -getPathInfo ∷ Resource [ByteString] +-- +-- Note that the returned path is URI-decoded and then UTF-8 decoded. +getPathInfo ∷ Resource [Text] getPathInfo = do rsrcPath ← getResourcePath - uri ← getRequestURI - let reqPathStr = uriPath uri - reqPath = [unEscapeString x | x ← splitBy (≡ '/') reqPathStr, (¬) (null x)] + reqPath ← splitPathInfo <$> getRequestURI -- rsrcPath と reqPath の共通する先頭部分を reqPath か -- ら全部取り除くと、それは PATH_INFO のやうなものにな -- る。rsrcPath は全部一致してゐるに決まってゐる（でな -- ければこの Resource が撰ばれた筈が無い）ので、 -- rsrcPath の長さの分だけ削除すれば良い。 - return $ map C8.pack $ drop (length rsrcPath) reqPath + return $ drop (length rsrcPath) reqPath -- |Assume the query part of request URI as -- application\/x-www-form-urlencoded, and parse it to pairs of @@ -310,9 +312,9 @@ toPairWithFormData ∷ (ByteString, ByteString) → (Text, FormData) toPairWithFormData (name, value) = let fd = FormData { fdFileName = Nothing - , fdContent = L8.fromChunks [value] + , fdContent = Lazy.fromChunks [value] } - in (T.decodeUtf8With T.lenientDecode name, fd) + in (T.decodeUtf8 name, fd) -- |Get a value of given request header. Comparison of header name is -- case-insensitive. Note that this action is not intended to be used @@ -607,12 +609,12 @@ input ∷ Int → Resource Lazy.ByteString input limit = do driftTo GettingBody itr ← getInteraction - hasBody ← liftIO $ atomically $ readItr itrRequestHasBody id itr + hasBody ← liftIO $ atomically $ readItr itrRequestHasBody itr chunk ← if hasBody then askForInput itr else do driftTo DecidingHeader - return L8.empty + return (∅) return chunk where askForInput ∷ Interaction → Resource Lazy.ByteString @@ -626,18 +628,18 @@ input limit $ fail ("inputLBS: limit must be positive: " ⧺ show actualLimit) -- Reader にリクエスト liftIO $ atomically - $ do chunkLen ← readItr itrReqChunkLength id itr + $ do chunkLen ← readItr itrReqChunkLength itr writeItr itrWillReceiveBody True itr - if fmap (> actualLimit) chunkLen ≡ Just True then + if ((> actualLimit) <$> chunkLen) ≡ Just True then -- 受信前から多過ぎる事が分かってゐる tooLarge actualLimit else writeItr itrReqBodyWanted (Just actualLimit) itr -- 應答を待つ。トランザクションを分けなければ當然デッドロックする。 chunk ← liftIO $ atomically - $ do chunk ← readItr itrReceivedBody chunksToLBS itr - chunkIsOver ← readItr itrReqChunkIsOver id itr - if L8.length chunk < fromIntegral actualLimit then + $ do chunkLen ← readItr itrReceivedBodyLen itr + chunkIsOver ← readItr itrReqChunkIsOver itr + if chunkLen < actualLimit then -- 要求された量に滿たなくて、まだ殘りが -- あるなら再試行。 unless chunkIsOver @@ -649,8 +651,11 @@ input limit $ tooLarge actualLimit -- 成功。itr 内にチャンクを置いたままにする -- とメモリの無駄になるので除去。 - writeItr itrReceivedBody (∅) itr + chunk ← seqToLBS <$> readItr itrReceivedBody itr + writeItr itrReceivedBody (∅) itr + writeItr itrReceivedBodyLen 0 itr return chunk + driftTo DecidingHeader return chunk @@ -658,6 +663,10 @@ input limit 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 @@ -675,12 +684,12 @@ inputChunk ∷ Int → Resource Lazy.ByteString inputChunk limit = do driftTo GettingBody itr ← getInteraction - hasBody ← liftIO $ atomically $ readItr itrRequestHasBody id itr + hasBody ← liftIO $ atomically $ readItr itrRequestHasBody itr chunk ← if hasBody then askForInput itr else do driftTo DecidingHeader - return L8.empty + return (∅) return chunk where askForInput ∷ Interaction → Resource Lazy.ByteString @@ -694,31 +703,38 @@ inputChunk limit $ fail ("inputChunkLBS: limit must be positive: " ++ show actualLimit) -- Reader にリクエスト liftIO $ atomically - $ do writeItr itrReqBodyWanted (Just actualLimit) itr - writeItr itrWillReceiveBody True itr + $ do writeItr itrReqBodyWanted (Just actualLimit) itr + writeItr itrWillReceiveBody True itr -- 應答を待つ。トランザクションを分けなければ當然デッドロック。 chunk ← liftIO $ atomically - $ do chunk ← readItr itrReceivedBody chunksToLBS itr - -- 要求された量に滿たなくて、まだ殘りがあ - -- るなら再試行。 - when (L8.length chunk < fromIntegral actualLimit) - $ do chunkIsOver ← readItr itrReqChunkIsOver id itr - unless chunkIsOver - $ retry - -- 成功 - writeItr itrReceivedBody (∅) itr - return chunk - when (L8.null chunk) + $ 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' +-- @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\". +-- +-- Field names in @multipart\/form-data@ will be precisely decoded in +-- accordance with RFC 2231. On the other hand, +-- @application\/x-www-form-urlencoded@ says nothing about the +-- encoding of field names, so they'll always be decoded in UTF-8. inputForm ∷ Int → Resource [(Text, FormData)] inputForm limit = do cTypeM ← getContentType @@ -731,7 +747,11 @@ inputForm limit → readMultipartFormData params Just cType → abort UnsupportedMediaType [] - (Just $ "Unsupported media type: " ⊕ A.toText (printMIMEType cType)) + $ Just + $ A.toText + $ A.fromAsciiBuilder + $ A.toAsciiBuilder "Unsupported media type: " + ⊕ printMIMEType cType where readWWWFormURLEncoded = (map toPairWithFormData ∘ parseWWWFormURLEncoded) @@ -739,7 +759,7 @@ inputForm limit (bsToAscii =≪ input limit) bsToAscii bs - = case A.fromByteString (C8.concat (L8.toChunks bs)) of + = case A.fromByteString (Strict.concat (Lazy.toChunks bs)) of Just a → return a Nothing → abort BadRequest [] (Just "Malformed x-www-form-urlencoded") @@ -814,15 +834,19 @@ redirect ∷ StatusCode → URI → Resource () redirect code uri = do when (code ≡ NotModified ∨ not (isRedirection code)) $ abort InternalServerError [] - (Just $ "Attempted to redirect with status " ⊕ A.toText (printStatusCode code)) + $ Just + $ A.toText + $ A.fromAsciiBuilder + $ A.toAsciiBuilder "Attempted to redirect with status " + ⊕ printStatusCode code setStatus code setLocation uri -- | Computation of @'setContentType' mType@ sets the response header -- \"Content-Type\" to @mType@. setContentType ∷ MIMEType → Resource () -setContentType mType - = setHeader "Content-Type" (printMIMEType mType) +setContentType + = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType -- | Computation of @'setLocation' uri@ sets the response header -- \"Location\" to @uri@. @@ -865,8 +889,7 @@ setWWWAuthenticate challenge -- \/dev\/random. output ∷ Lazy.ByteString → Resource () {-# INLINE output #-} -output str = do outputChunk str - driftTo Done +output str = outputChunk str *> driftTo Done -- | Computation of @'outputChunk' str@ writes @str@ as a part of -- response body. You can compute this action multiple times to write @@ -883,35 +906,26 @@ outputChunk wholeChunk (Just $ "cnfMaxOutputChunkLength must be positive: " ⊕ T.pack (show limit)) discardBody ← liftIO $ atomically $ - readItr itrWillDiscardBody id itr + readItr itrWillDiscardBody itr unless (discardBody) $ sendChunks wholeChunk limit - unless (L8.null wholeChunk) + unless (Lazy.null wholeChunk) $ liftIO $ atomically $ - writeItr itrBodyIsNull False itr + writeItr itrSentNoBody False itr where - -- チャンクの大きさは Config で制限されてゐる。もし例へば - -- "/dev/zero" を L8.readFile して作った Lazy.ByteString をそのまま - -- ResponseWriter に渡したりすると大變な事が起こる。何故なら - -- ResponseWriter は Transfer-Encoding: chunked の時、ヘッダを書 - -- く爲にチャンクの大きさを測るからだ。 sendChunks ∷ Lazy.ByteString → Int → Resource () sendChunks str limit - | L8.null str = return () - | otherwise = do let (chunk, remaining) = L8.splitAt (fromIntegral limit) str - itr ← getInteraction - liftIO $ atomically $ - do buf ← readItr itrBodyToSend id itr - if S.null buf then - -- バッファが消化された - writeItr itrBodyToSend (chunksFromLBS chunk) itr - else - -- 消化されるのを待つ - retry - -- 殘りのチャンクについて繰り返す - sendChunks remaining limit + | Lazy.null str = return () + | otherwise = do let (chunk, remaining) = Lazy.splitAt (fromIntegral limit) str + itr ← getInteraction + liftIO $ atomically + $ putTMVar (itrBodyToSend itr) (chunkToBuilder chunk) + sendChunks remaining limit + + chunkToBuilder ∷ Lazy.ByteString → Builder + chunkToBuilder = mconcat ∘ map BB.fromByteString ∘ Lazy.toChunks {- @@ -935,7 +949,7 @@ outputChunk wholeChunk driftTo ∷ InteractionState → Resource () driftTo newState = do itr ← getInteraction - liftIO $ atomically $ do oldState ← readItr itrState id itr + liftIO $ atomically $ do oldState ← readItr itrState itr if newState < oldState then throwStateError oldState newState else @@ -963,9 +977,9 @@ driftTo newState = postprocess itr drift itr _ Done - = do bodyIsNull ← readItr itrBodyIsNull id itr + = do bodyIsNull ← readItr itrSentNoBody itr when bodyIsNull - $ writeDefaultPage itr + $ writeDefaultPage itr drift _ _ _ = return ()