X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=6463bc8fd7d0fc0ee12b50a8a3363891af894127;hb=a362be1c8664306b970c32e1df9b62081498feb1;hp=72b751709132b38b2ef66994d2d551d62a42b99c;hpb=7bc27fc4e86df6cb4d269b42252de735247f8c57;p=Lucu.git diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index 72b7517..6463bc8 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 @@ -69,6 +70,8 @@ module Network.HTTP.Lucu.Resource ( -- * Types Resource + , ResourceDef(..) + , emptyResource , FormData(..) -- * Getting request header @@ -101,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 @@ -125,40 +129,39 @@ 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 -import Network.HTTP.Lucu.Authorization +import Network.HTTP.Lucu.Authentication import Network.HTTP.Lucu.Config import Network.HTTP.Lucu.ContentCoding import Network.HTTP.Lucu.ETag @@ -178,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 @@ -214,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 ∘ @@ -226,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 @@ -253,10 +258,10 @@ getAccept Just accept → case P.parseOnly p (A.toByteString accept) of Right xs → return xs - Left _ → abort BadRequest [] - (Just $ "Unparsable Accept: " ⊕ A.toText accept) + Left _ → abort $ mkAbortion' BadRequest + $ "Unparsable Accept: " ⊕ A.toText accept where - p = do xs ← mimeTypeListP + p = do xs ← mimeTypeList P.endOfInput return xs @@ -276,8 +281,8 @@ getAcceptEncoding case ver of HttpVersion 1 0 → return [("identity", Nothing)] HttpVersion 1 1 → return [("*" , Nothing)] - _ → abort InternalServerError [] - (Just "getAcceptEncoding: unknown HTTP version") + _ → abort $ mkAbortion' InternalServerError + "getAcceptEncoding: unknown HTTP version" Just ae → if ae ≡ "" then -- identity のみが許される。 @@ -285,17 +290,18 @@ getAcceptEncoding else case P.parseOnly p (A.toByteString ae) of Right xs → return $ map toTuple $ reverse $ sort xs - Left _ → abort BadRequest [] - (Just $ "Unparsable Accept-Encoding: " ⊕ A.toText ae) + 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 @@ -312,10 +318,10 @@ getContentType Just cType → case P.parseOnly p (A.toByteString cType) of Right t → return $ Just t - Left _ → abort BadRequest [] - (Just $ "Unparsable Content-Type: " ⊕ A.toText cType) + Left _ → abort $ mkAbortion' BadRequest + $ "Unparsable Content-Type: " ⊕ A.toText cType where - p = do t ← mimeTypeP + p = do t ← mimeType P.endOfInput return t @@ -332,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 @@ -358,8 +364,9 @@ foundEntity tag timeStamp when (method ≡ GET ∨ method ≡ HEAD) $ setHeader "Last-Modified" (HTTP.toAscii timeStamp) when (method ≡ POST) - $ abort InternalServerError [] - (Just "foundEntity: this is a POST request.") + $ abort + $ mkAbortion' InternalServerError + "foundEntity: this is a POST request." foundETag tag driftTo ReceivingBody @@ -381,8 +388,9 @@ foundETag tag $ A.fromAsciiBuilder $ printETag tag when (method ≡ POST) - $ abort InternalServerError [] - $ Just "Illegal computation of foundETag for POST request." + $ abort + $ mkAbortion' InternalServerError + "Illegal computation of foundETag for POST request." -- If-Match があればそれを見る。 ifMatch ← getHeader "If-Match" @@ -396,13 +404,12 @@ foundETag tag -- tags の中に一致するものが無ければ -- PreconditionFailed で終了。 → when ((¬) (any (≡ tag) tags)) - $ abort PreconditionFailed [] - $ Just + $ abort + $ mkAbortion' PreconditionFailed $ "The entity tag doesn't match: " ⊕ A.toText value Left _ - → abort BadRequest [] - $ Just - $ "Unparsable If-Match: " ⊕ A.toText value + → abort $ mkAbortion' BadRequest + $ "Unparsable If-Match: " ⊕ A.toText value let statusForNoneMatch = if method ≡ GET ∨ method ≡ HEAD then @@ -415,22 +422,22 @@ foundETag tag case ifNoneMatch of Nothing → return () Just value → if value ≡ "*" then - abort statusForNoneMatch [] (Just "The entity tag matches: *") + abort $ mkAbortion' statusForNoneMatch + $ "The entity tag matches: *" else case P.parseOnly p (A.toByteString value) of Right tags → when (any (≡ tag) tags) - $ abort statusForNoneMatch [] - $ Just + $ abort + $ mkAbortion' statusForNoneMatch $ "The entity tag matches: " ⊕ A.toText value Left _ - → abort BadRequest [] - $ Just - $ "Unparsable If-None-Match: " ⊕ A.toText value + → abort $ mkAbortion' BadRequest + $ "Unparsable If-None-Match: " ⊕ A.toText value driftTo ReceivingBody where - p = do xs ← eTagListP + p = do xs ← eTagList P.endOfInput return xs @@ -452,8 +459,9 @@ foundTimeStamp timeStamp when (method ≡ GET ∨ method ≡ HEAD) $ setHeader "Last-Modified" (HTTP.toAscii timeStamp) when (method ≡ POST) - $ abort InternalServerError [] - (Just "Illegal computation of foundTimeStamp for POST request.") + $ abort + $ mkAbortion' InternalServerError + "Illegal computation of foundTimeStamp for POST request." let statusForIfModSince = if method ≡ GET ∨ method ≡ HEAD then @@ -467,8 +475,9 @@ foundTimeStamp timeStamp Just str → case HTTP.fromAscii str of Right lastTime → when (timeStamp ≤ lastTime) - $ abort statusForIfModSince [] - (Just $ "The entity has not been modified since " ⊕ A.toText str) + $ abort + $ mkAbortion' statusForIfModSince + $ "The entity has not been modified since " ⊕ A.toText str Left _ → return () -- 不正な時刻は無視 Nothing → return () @@ -479,8 +488,9 @@ foundTimeStamp timeStamp Just str → case HTTP.fromAscii str of Right lastTime → when (timeStamp > lastTime) - $ abort PreconditionFailed [] - (Just $ "The entity has not been modified since " ⊕ A.toText str) + $ abort + $ mkAbortion' PreconditionFailed + $ "The entity has not been modified since " ⊕ A.toText str Left _ → return () -- 不正な時刻は無視 Nothing → return () @@ -501,16 +511,22 @@ foundNoEntity msgM method ← getMethod when (method ≢ PUT) - $ abort NotFound [] msgM + $ abort + $ mkAbortion NotFound [] msgM -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな -- If-Match: 條件も滿たさない。 ifMatch ← getHeader "If-Match" when (ifMatch ≢ Nothing) - $ abort PreconditionFailed [] msgM + $ abort + $ mkAbortion PreconditionFailed [] 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 @@ -522,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) @@ -536,19 +552,23 @@ getChunks Nothing getChunks' ∷ Int → Resource Lazy.ByteString getChunks' limit = go limit (∅) where - 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' + 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 @@ -557,29 +577,24 @@ 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 Nothing - → abort BadRequest [] (Just "Missing Content-Type") + → abort $ mkAbortion' BadRequest "Missing Content-Type" Just (MIMEType "application" "x-www-form-urlencoded" _) → readWWWFormURLEncoded Just (MIMEType "multipart" "form-data" params) → readMultipartFormData params Just cType - → abort UnsupportedMediaType [] - $ Just - $ A.toText - $ A.fromAsciiBuilder - $ A.toAsciiBuilder "Unsupported media type: " - ⊕ printMIMEType cType + → abort $ mkAbortion' UnsupportedMediaType + $ A.toText + $ A.fromAsciiBuilder + $ A.toAsciiBuilder "Unsupported media type: " + ⊕ printMIMEType cType where readWWWFormURLEncoded = (map toPairWithFormData ∘ parseWWWFormURLEncoded) @@ -589,26 +604,21 @@ getForm limit bsToAscii bs = case A.fromByteString (Strict.concat (Lazy.toChunks bs)) of Just a → return a - Nothing → abort BadRequest [] (Just "Malformed x-www-form-urlencoded") + Nothing → abort $ mkAbortion' BadRequest "Malformed x-www-form-urlencoded" readMultipartFormData params - = do case M.lookup "boundary" params of - Nothing - → abort BadRequest [] (Just "Missing boundary of multipart/form-data") - Just boundary - → do src ← getChunks limit - b ← case A.fromText boundary of - Just b → return b - Nothing → abort BadRequest [] - (Just $ "Malformed boundary: " ⊕ boundary) - case LP.parse (p b) src of - LP.Done _ formList - → return formList - _ → abort BadRequest [] (Just "Unparsable multipart/form-data") - where - p b = do xs ← multipartFormP b - P.endOfInput - return xs + = case M.lookup "boundary" params of + Nothing + → abort $ mkAbortion' BadRequest "Missing boundary of multipart/form-data" + Just boundary + → do src ← getChunks limit + b ← case A.fromText boundary of + Just b → return b + Nothing → abort $ mkAbortion' BadRequest + $ "Malformed boundary: " ⊕ boundary + 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 @@ -616,8 +626,8 @@ getForm limit redirect ∷ StatusCode → URI → Resource () redirect code uri = do when (code ≡ NotModified ∨ not (isRedirection code)) - $ abort InternalServerError [] - $ Just + $ abort + $ mkAbortion' InternalServerError $ A.toText $ A.fromAsciiBuilder $ A.toAsciiBuilder "Attempted to redirect with status " @@ -638,8 +648,8 @@ setLocation ∷ URI → Resource () setLocation uri = case A.fromChars uriStr of Just a → setHeader "Location" a - Nothing → abort InternalServerError [] - (Just $ "Malformed URI: " ⊕ T.pack uriStr) + Nothing → abort $ mkAbortion' InternalServerError + $ "Malformed URI: " ⊕ T.pack uriStr where uriStr = uriToString id uri "" @@ -651,10 +661,13 @@ setContentEncoding codings tr ← case ver of HttpVersion 1 0 → return (toAB ∘ unnormalizeCoding) HttpVersion 1 1 → return toAB - _ → abort InternalServerError [] - (Just "setContentEncoding: Unknown HTTP version") + _ → 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 @@ -669,9 +682,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