{-# LANGUAGE
- GeneralizedNewtypeDeriving
+ BangPatterns
+ , GeneralizedNewtypeDeriving
, DoAndIfThenElse
, OverloadedStrings
, RecordWildCards
, 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
-- |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
-- |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 ∘
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
Left _ → abort $ mkAbortion' BadRequest
$ "Unparsable Accept: " ⊕ A.toText accept
where
- p = do xs ← mimeTypeListP
+ p = do xs ← mimeTypeList
P.endOfInput
return xs
Left _ → abort $ mkAbortion' BadRequest
$ "Unparsable Accept-Encoding: " ⊕ A.toText ae
where
- p = do xs ← acceptEncodingListP
+ p = do xs ← acceptEncodingList
P.endOfInput
return xs
Left _ → abort $ mkAbortion' BadRequest
$ "Unparsable Content-Type: " ⊕ A.toText cType
where
- p = do t ← mimeTypeP
+ p = do t ← mimeType
P.endOfInput
return t
Right ac → return $ Just ac
Left _ → return Nothing
where
- p = do ac ← authCredentialP
+ p = do ac ← authCredential
P.endOfInput
return ac
driftTo ReceivingBody
where
- p = do xs ← eTagListP
+ p = do xs ← eTagList
P.endOfInput
return xs
{-# 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
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
-- 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
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
_ → 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
projects / Lucu.git / blobdiff