{-# LANGUAGE
- GeneralizedNewtypeDeriving
+ BangPatterns
+ , GeneralizedNewtypeDeriving
, DoAndIfThenElse
, OverloadedStrings
+ , QuasiQuotes
, RecordWildCards
, UnicodeSyntax
#-}
-- /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
-- 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
-- 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.
(
-- * Types
Resource
+ , ResourceDef(..)
+ , emptyResource
, FormData(..)
-- * Getting request header
, foundETag
, foundTimeStamp
, foundNoEntity
+ , foundNoEntity'
-- * Receiving a request body
-- |These functions make the 'Resource' transit to the /Receiving
, 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
import Network.HTTP.Lucu.HttpVersion
import Network.HTTP.Lucu.Interaction
import Network.HTTP.Lucu.MultipartForm
+import Network.HTTP.Lucu.Parser
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Resource.Internal
import Network.HTTP.Lucu.Response
-import Network.HTTP.Lucu.MIMEType
+import Network.HTTP.Lucu.MIMEParams
+import Network.HTTP.Lucu.MIMEType (MIMEType(..))
+import qualified Network.HTTP.Lucu.MIMEType as MT
+import Network.HTTP.Lucu.MIMEType.TH
import Network.HTTP.Lucu.Utils
import Network.Socket hiding (accept)
import Network.URI hiding (path)
-- |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
-- |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]
-- |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 = [mimeType| 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
Nothing
→ return []
Just accept
- → case P.parseOnly p (A.toByteString accept) of
+ → case P.parseOnly (finishOff MT.mimeTypeList) (A.toByteString accept) of
Right xs → return xs
- Left _ → abort BadRequest []
- (Just $ "Unparsable Accept: " ⊕ A.toText accept)
- where
- p = do xs ← mimeTypeListP
- P.endOfInput
- return xs
+ Left _ → abort $ mkAbortion' BadRequest
+ $ "Unparsable Accept: " ⊕ A.toText accept
-- |Return the list of @(contentCoding, qvalue)@ enumerated on the
-- value of request header \"Accept-Encoding\". The list is sorted in
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 のみが許される。
return [("identity", Nothing)]
else
- case P.parseOnly p (A.toByteString ae) of
+ case P.parseOnly (finishOff acceptEncodingList) (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.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
Nothing
→ return Nothing
Just cType
- → case P.parseOnly p (A.toByteString cType) of
+ → case P.parseOnly (finishOff MT.mimeType) (A.toByteString cType) of
Right t → return $ Just t
- Left _ → abort BadRequest []
- (Just $ "Unparsable Content-Type: " ⊕ A.toText cType)
- where
- p = do t ← mimeTypeP
- P.endOfInput
- return t
+ Left _ → abort $ mkAbortion' BadRequest
+ $ "Unparsable Content-Type: " ⊕ A.toText cType
-- |Return the value of request header \"Authorization\" as
-- 'AuthCredential'.
Nothing
→ return Nothing
Just auth
- → case P.parseOnly p (A.toByteString auth) of
+ → case P.parseOnly (finishOff authCredential) (A.toByteString auth) of
Right ac → return $ Just ac
Left _ → return Nothing
- where
- p = do ac ← authCredentialP
- P.endOfInput
- return ac
-- |Tell the system that the 'Resource' found an entity for the
-- request URI. If this is a GET or HEAD request, a found entity means
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
$ 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"
case ifMatch of
- Nothing → return ()
- Just value → if value ≡ "*" then
- return ()
- else
- case P.parseOnly p (A.toByteString value) of
- Right tags
- -- tags の中に一致するものが無ければ
- -- PreconditionFailed で終了。
- → when ((¬) (any (≡ tag) tags))
- $ abort PreconditionFailed []
- $ Just
- $ "The entity tag doesn't match: " ⊕ A.toText value
- Left _
- → abort BadRequest []
- $ Just
+ Nothing
+ → return ()
+ Just value
+ → if value ≡ "*" then
+ return ()
+ else
+ case P.parseOnly (finishOff eTagList) (A.toByteString value) of
+ Right tags
+ -- tags の中に一致するものが無ければ
+ -- PreconditionFailed で終了。
+ → when ((¬) (any (≡ tag) tags))
+ $ abort
+ $ mkAbortion' PreconditionFailed
+ $ "The entity tag doesn't match: " ⊕ A.toText value
+ Left _
+ → abort $ mkAbortion' BadRequest
$ "Unparsable If-Match: " ⊕ A.toText value
let statusForNoneMatch
-- If-None-Match があればそれを見る。
ifNoneMatch ← getHeader "If-None-Match"
case ifNoneMatch of
- Nothing → return ()
- Just value → if value ≡ "*" then
- abort statusForNoneMatch [] (Just "The entity tag matches: *")
- else
- case P.parseOnly p (A.toByteString value) of
- Right tags
- → when (any (≡ tag) tags)
- $ abort statusForNoneMatch []
- $ Just
- $ "The entity tag matches: " ⊕ A.toText value
- Left _
- → abort BadRequest []
- $ Just
+ Nothing
+ → return ()
+ Just value
+ → if value ≡ "*" then
+ abort $ mkAbortion' statusForNoneMatch
+ $ "The entity tag matches: *"
+ else
+ case P.parseOnly (finishOff eTagList) (A.toByteString value) of
+ Right tags
+ → when (any (≡ tag) tags)
+ $ abort
+ $ mkAbortion' statusForNoneMatch
+ $ "The entity tag matches: " ⊕ A.toText value
+ Left _
+ → abort $ mkAbortion' BadRequest
$ "Unparsable If-None-Match: " ⊕ A.toText value
driftTo ReceivingBody
- where
- p = do xs ← eTagListP
- P.endOfInput
- return xs
-- |Tell the system that the 'Resource' found an entity for the
-- request URI. The only difference from 'foundEntity' is that
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
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 ()
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 ()
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
-- 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)
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
-- 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: "
+ ⊕ MT.printMIMEType cType
where
readWWWFormURLEncoded
= (map toPairWithFormData ∘ parseWWWFormURLEncoded)
bsToAscii bs
= case A.fromByteString (Strict.concat (Lazy.toChunks bs)) of
Just a → return a
- Nothing → abort BadRequest [] (Just "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
+ Nothing → abort $ mkAbortion' BadRequest "Malformed x-www-form-urlencoded"
+
+ readMultipartFormData (MIMEParams m)
+ = case M.lookup "boundary" m 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
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 "
-- mandatory for sending a response body.
setContentType ∷ MIMEType → Resource ()
setContentType
- = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType
+ = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ MT.printMIMEType
-- |@'setLocation' uri@ declares the response header \"Location\" as
-- @uri@. You usually don't need to call this function directly.
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 ""
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
-- |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
projects / Lucu.git / blobdiff