X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=71ff4838c3945380d44f2dee36fddc2b3952d3d1;hb=ece223c516e66223ef1d5d8e6bbe4054a235d983;hp=314e1f55972c1ac40d26deaadeb64602fbb1df12;hpb=f402841101b4b84f263eea1a43c848f81c48ff93;p=Lucu.git diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index 314e1f5..71ff483 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -1,5 +1,6 @@ {-# LANGUAGE - GeneralizedNewtypeDeriving + BangPatterns + , GeneralizedNewtypeDeriving , DoAndIfThenElse , OverloadedStrings , RecordWildCards @@ -28,8 +29,8 @@ -- /Examining Request/ and the final state is /Done/. -- -- [/Examining Request/] In this state, a 'Resource' looks at the --- request header fields and thinks about a corresponding entity for --- it. If there is a suitable entity, the 'Resource' tells the +-- request header fields and thinks about the corresponding entity +-- for it. If there is a suitable entity, the 'Resource' tells the -- system an entity tag and its last modification time -- ('foundEntity'). If it found no entity, it tells the system so -- ('foundNoEntity'). In case it is impossible to decide the @@ -41,11 +42,11 @@ -- socket, the system sends \"100 Continue\" to the client if need -- be. When a 'Resource' transits to the next state without -- receiving all or part of a request body, the system automatically --- receives and discards it. +-- discards it. -- --- [/Deciding Header/] A 'Resource' makes a decision of status code --- and response header fields. When it transits to the next state, --- the system validates and completes the response header fields and +-- [/Deciding Header/] A 'Resource' makes a decision of response +-- status code and header fields. When it transits to the next +-- state, the system validates and completes the header fields and -- then sends them to the client. -- -- [/Sending Body/] In this state, a 'Resource' asks the system to @@ -103,6 +104,7 @@ module Network.HTTP.Lucu.Resource , foundETag , foundTimeStamp , foundNoEntity + , foundNoEntity' -- * Receiving a request body -- |These functions make the 'Resource' transit to the /Receiving @@ -127,14 +129,17 @@ module Network.HTTP.Lucu.Resource , deleteHeader -- * Sending a response body - -- |These functions make the 'Resource' transit to the /Sending - -- Body/ state. + + -- |These functions make the 'Resource' transit to the + -- /Sending Body/ state. , putChunk , putChunks , putBuilder ) where -import qualified Blaze.ByteString.Builder.ByteString as BB +import Blaze.ByteString.Builder (Builder) +import qualified Blaze.ByteString.Builder as BB +import qualified Blaze.ByteString.Builder.Internal as BB import Control.Applicative import Control.Monad import Control.Monad.IO.Class @@ -146,14 +151,11 @@ import qualified Data.Attoparsec.Lazy as LP import Data.ByteString (ByteString) import qualified Data.ByteString as Strict import qualified Data.ByteString.Lazy as Lazy -import qualified Data.ByteString.Lazy.Internal 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 Data.Sequence (Seq) -import Data.Sequence.Unicode hiding ((∅)) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -239,7 +241,7 @@ toPairWithFormData (name, value) -- |@'getHeader' name@ returns the value of the request header field -- @name@. Comparison of header name is case-insensitive. Note that -- this function is not intended to be used so frequently: there --- should be actions like 'getContentType' for every common headers. +-- should be functions like 'getContentType' for every common headers. getHeader ∷ CIAscii → Resource (Maybe Ascii) getHeader name = H.getHeader name <$> getRequest @@ -297,7 +299,8 @@ getAcceptEncoding toTuple (AcceptEncoding {..}) = (aeEncoding, aeQValue) --- |Return 'True' iff a given content-coding is acceptable. +-- |Return 'True' iff a given content-coding is acceptable by the +-- client. isEncodingAcceptable ∷ CIAscii → Resource Bool isEncodingAcceptable encoding = any doesMatch <$> getAcceptEncoding where @@ -519,6 +522,11 @@ foundNoEntity msgM driftTo ReceivingBody +-- |'foundNoEntity'' is the same as @'foundNoEntity' 'Nothing'@. +foundNoEntity' ∷ Resource () +{-# INLINE foundNoEntity' #-} +foundNoEntity' = foundNoEntity Nothing + -- |@'getChunks' limit@ attemts to read the entire request body up to -- @limit@ bytes, and then make the 'Resource' transit to the @@ -530,8 +538,8 @@ foundNoEntity msgM -- When the @limit@ is 'Nothing', 'getChunks' uses the default -- limitation value ('cnfMaxEntityLength') instead. -- --- 'getChunks' returns a 'Lazy.ByteString' but it's not really lazy: --- reading from the socket just happens at the computation of +-- 'getChunks' returns a lazy 'Lazy.ByteString' but it's not really +-- lazy: reading from the socket just happens at the computation of -- 'getChunks', not at the evaluation of the 'Lazy.ByteString'. getChunks ∷ Maybe Int → Resource Lazy.ByteString getChunks (Just n) @@ -544,24 +552,23 @@ getChunks Nothing getChunks' ∷ Int → Resource Lazy.ByteString getChunks' limit = go limit (∅) where - go ∷ Int → Seq Strict.ByteString → Resource Lazy.ByteString - go 0 _ = do chunk ← getChunk 1 - if Strict.null chunk then - return (∅) - else - abort $ mkAbortion' RequestEntityTooLarge - $ "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' + go ∷ Int → Builder → Resource Lazy.ByteString + go 0 _ = do chunk ← getChunk 1 + if Strict.null chunk then + return (∅) + else + abort $ mkAbortion' RequestEntityTooLarge + $ "Request body must be smaller than " + ⊕ T.pack (show limit) + ⊕ " bytes." + go !n !b = do c ← getChunk $ min n BB.defaultBufferSize + if Strict.null c then + -- Got EOF + return $ BB.toLazyByteString b + else + do let n' = n - Strict.length c + xs' = b ⊕ BB.fromByteString c + go n' xs' -- |@'getForm' limit@ attempts to read the request body with -- 'getChunks' and parse it as @application\/x-www-form-urlencoded@ or @@ -616,7 +623,12 @@ getForm limit case LP.parse (p b) src of LP.Done _ formList → return formList - _ → abort $ mkAbortion' BadRequest "Unparsable multipart/form-data" + LP.Fail _ eCtx e + → abort $ mkAbortion' BadRequest + $ "Unparsable multipart/form-data: " + ⊕ T.pack (intercalate ", " eCtx) + ⊕ ": " + ⊕ T.pack e where p b = do xs ← multipartFormP b P.endOfInput @@ -666,7 +678,10 @@ setContentEncoding codings _ → abort $ mkAbortion' InternalServerError "setContentEncoding: Unknown HTTP version" setHeader "Content-Encoding" - (A.fromAsciiBuilder $ joinWith ", " $ map tr codings) + $ A.fromAsciiBuilder + $ mconcat + $ intersperse (A.toAsciiBuilder ", ") + $ map tr codings where toAB = A.toAsciiBuilder ∘ A.fromCIAscii @@ -681,9 +696,8 @@ setWWWAuthenticate = setHeader "WWW-Authenticate" ∘ printAuthChallenge putChunk ∷ Strict.ByteString → Resource () putChunk = putBuilder ∘ BB.fromByteString --- |Write a chunk in 'Lazy.ByteString' to the response body. It is --- safe to apply this function to an infinitely long --- 'Lazy.ByteString'. +-- |Write a chunk in lazy 'Lazy.ByteString' to the response body. It +-- can be safely applied to an infinitely long 'Lazy.ByteString'. -- -- Note that you must first declare the response header -- \"Content-Type\" before applying this function. See