X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=aee29d56f95682c7550623176267f23e6230d23b;hb=9b2a30d;hp=d61f2f45ec3950505020c19c770559ecdd0a2d3b;hpb=9668dc27a02b59d7bfb1e9e40af3d2619700ad69;p=Lucu.git diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index d61f2f4..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 @@ -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. @@ -136,29 +137,27 @@ module Network.HTTP.Lucu.Resource , 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 @@ -182,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 @@ -206,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] @@ -218,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 ∘ @@ -230,13 +230,14 @@ 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 @@ -260,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 @@ -292,7 +293,7 @@ getAcceptEncoding Left _ → abort $ mkAbortion' BadRequest $ "Unparsable Accept-Encoding: " ⊕ A.toText ae where - p = do xs ← acceptEncodingListP + p = do xs ← acceptEncodingList P.endOfInput return xs @@ -320,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 @@ -337,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 @@ -436,7 +437,7 @@ foundETag tag driftTo ReceivingBody where - p = do xs ← eTagListP + p = do xs ← eTagList P.endOfInput return xs @@ -527,7 +528,6 @@ 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 -- /Deciding Header/ state. When the actual size of the body is larger @@ -552,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 @@ -578,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 @@ -621,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 @@ -674,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 @@ -685,7 +678,7 @@ 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 @@ -693,7 +686,7 @@ putChunk = putBuilder ∘ BB.fromByteString -- 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