X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=6463bc8fd7d0fc0ee12b50a8a3363891af894127;hp=71ff4838c3945380d44f2dee36fddc2b3952d3d1;hb=a362be1c8664306b970c32e1df9b62081498feb1;hpb=45e3770f440c9fa8668f7e33063d630d73bcbe55 diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index 71ff483..6463bc8 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -141,13 +141,13 @@ 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 @@ -158,7 +158,6 @@ import Data.Monoid import Data.Monoid.Unicode 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 @@ -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 @@ -577,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 @@ -620,19 +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 - 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 - 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