X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=aee29d56f95682c7550623176267f23e6230d23b;hb=9b2a30d14cbdb224d4c386a3bca45456dc336ce2;hp=314e1f55972c1ac40d26deaadeb64602fbb1df12;hpb=f402841101b4b84f263eea1a43c848f81c48ff93;p=Lucu.git diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index 314e1f5..aee29d5 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 @@ -54,7 +55,7 @@ -- automatically completes it depending on the status code. (To be -- exact, such completion only occurs when the 'Resource' transits -- to this state without even declaring the \"Content-Type\" header --- field. See 'setContentType'.) +-- field. See: 'setContentType') -- -- [/Done/] Everything is over. A 'Resource' can do nothing for the -- HTTP interaction anymore. @@ -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,36 +129,35 @@ 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.Arrow import Control.Monad import Control.Monad.IO.Class import Control.Monad.Unicode import Data.Ascii (Ascii, CIAscii) 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 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 import Data.Time import qualified Data.Time.HTTP as HTTP import Network.HTTP.Lucu.Abortion @@ -180,15 +181,17 @@ import Prelude.Unicode -- |Get the string representation of the address of remote host. If -- you want a 'SockAddr' instead of 'HostName', use 'getRemoteAddr'. getRemoteAddr' ∷ Resource HostName -getRemoteAddr' - = do sa ← getRemoteAddr - (fromJust ∘ fst) <$> (liftIO $ getNameInfo [NI_NUMERICHOST] True False sa) +getRemoteAddr' = liftIO ∘ toNM =≪ getRemoteAddr + where + toNM ∷ SockAddr → IO HostName + toNM = (fromJust ∘ fst <$>) ∘ getNameInfo [NI_NUMERICHOST] True False -- |Resolve an address to the remote host. getRemoteHost ∷ Resource (Maybe HostName) -getRemoteHost - = do sa ← getRemoteAddr - fst <$> (liftIO $ getNameInfo [] True False sa) +getRemoteHost = liftIO ∘ getHN =≪ getRemoteAddr + where + getHN ∷ SockAddr → IO (Maybe HostName) + getHN = (fst <$>) ∘ getNameInfo [] True False -- |Get the 'Method' value of the request. getMethod ∷ Resource Method @@ -204,8 +207,8 @@ getRequestVersion = reqVersion <$> getRequest -- |This is an analogy of CGI PATH_INFO. 'getPathInfo' always returns -- @[]@ if the corresponding --- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not greedy. See --- 'getResourcePath'. +-- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not greedy. See: +-- 'getResourcePath' -- -- Note that the returned path components are URI-decoded. getPathInfo ∷ Resource [Strict.ByteString] @@ -216,9 +219,8 @@ getPathInfo = do rsrcPath ← getResourcePath -- |Assume the query part of request URI as -- application\/x-www-form-urlencoded, and parse it into pairs of -- @(name, formData)@. This function doesn't read the request --- body. Field names are decoded in UTF-8 for an hardly avoidable --- reason. See 'getForm'. -getQueryForm ∷ Resource [(Text, FormData)] +-- body. +getQueryForm ∷ Resource [(Strict.ByteString, FormData)] getQueryForm = parse' <$> getRequestURI where parse' = map toPairWithFormData ∘ @@ -228,18 +230,19 @@ getQueryForm = parse' <$> getRequestURI drop 1 ∘ uriQuery -toPairWithFormData ∷ (ByteString, ByteString) → (Text, FormData) +toPairWithFormData ∷ (ByteString, ByteString) → (Strict.ByteString, FormData) toPairWithFormData (name, value) = let fd = FormData { fdFileName = Nothing + , fdMIMEType = parseMIMEType "text/plain" , fdContent = Lazy.fromChunks [value] } - in (T.decodeUtf8 name, fd) + in (name, fd) -- |@'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 @@ -258,7 +261,7 @@ getAccept Left _ → abort $ mkAbortion' BadRequest $ "Unparsable Accept: " ⊕ A.toText accept where - p = do xs ← mimeTypeListP + p = do xs ← mimeTypeList P.endOfInput return xs @@ -290,14 +293,15 @@ getAcceptEncoding Left _ → abort $ mkAbortion' BadRequest $ "Unparsable Accept-Encoding: " ⊕ A.toText ae where - p = do xs ← acceptEncodingListP + p = do xs ← acceptEncodingList P.endOfInput return xs 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 @@ -317,7 +321,7 @@ getContentType Left _ → abort $ mkAbortion' BadRequest $ "Unparsable Content-Type: " ⊕ A.toText cType where - p = do t ← mimeTypeP + p = do t ← mimeType P.endOfInput return t @@ -334,7 +338,7 @@ getAuthorization Right ac → return $ Just ac Left _ → return Nothing where - p = do ac ← authCredentialP + p = do ac ← authCredential P.endOfInput return ac @@ -433,7 +437,7 @@ foundETag tag driftTo ReceivingBody where - p = do xs ← eTagListP + p = do xs ← eTagList P.endOfInput return xs @@ -519,6 +523,10 @@ 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 @@ -570,13 +577,9 @@ getChunks' limit = go limit (∅) -- 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 character --- encodings for field names, so they'll always be decoded in --- UTF-8. (This could be a bad design, but I can't think of any better --- idea.) -getForm ∷ Maybe Int → Resource [(Text, FormData)] +-- Note that there are currently a few limitations on parsing +-- @multipart/form-data@. See: 'parseMultipartFormData' +getForm ∷ Maybe Int → Resource [(Strict.ByteString, FormData)] getForm limit = do cTypeM ← getContentType case cTypeM of @@ -613,14 +616,9 @@ getForm limit Just b → return b Nothing → abort $ mkAbortion' BadRequest $ "Malformed boundary: " ⊕ boundary - case LP.parse (p b) src of - LP.Done _ formList - → return formList - _ → abort $ mkAbortion' BadRequest "Unparsable multipart/form-data" - where - p b = do xs ← multipartFormP b - P.endOfInput - return xs + case parseMultipartFormData b src of + Right xs → return $ map (first A.toByteString) xs + Left err → abort $ mkAbortion' BadRequest $ T.pack err -- |@'redirect' code uri@ declares the response status as @code@ and -- \"Location\" header field as @uri@. The @code@ must satisfy @@ -666,7 +664,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 @@ -677,16 +678,15 @@ setWWWAuthenticate = setHeader "WWW-Authenticate" ∘ printAuthChallenge -- |Write a chunk in 'Strict.ByteString' to the response body. You -- must first declare the response header \"Content-Type\" before --- applying this function. See 'setContentType'. +-- applying this function. See: 'setContentType' 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 --- 'setContentType'. +-- \"Content-Type\" before applying this function. See: +-- 'setContentType' putChunks ∷ Lazy.ByteString → Resource () putChunks = putBuilder ∘ BB.fromLazyByteString