, GeneralizedNewtypeDeriving
, DoAndIfThenElse
, OverloadedStrings
+ , QuasiQuotes
, RecordWildCards
, UnicodeSyntax
#-}
-- 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.
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)
-- |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]
toPairWithFormData (name, value)
= let fd = FormData {
fdFileName = Nothing
- , fdMIMEType = parseMIMEType "text/plain"
+ , fdMIMEType = [mimeType| text/plain |]
, fdContent = Lazy.fromChunks [value]
}
in (name, fd)
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 $ mkAbortion' BadRequest
$ "Unparsable Accept: " ⊕ A.toText accept
- where
- p = do xs ← mimeTypeList
- P.endOfInput
- return xs
-- |Return the list of @(contentCoding, qvalue)@ enumerated on the
-- value of request header \"Accept-Encoding\". The list is sorted in
-- 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 $ mkAbortion' BadRequest
$ "Unparsable Accept-Encoding: " ⊕ A.toText ae
where
- p = do xs ← acceptEncodingList
- P.endOfInput
- return xs
-
toTuple (AcceptEncoding {..})
= (aeEncoding, aeQValue)
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 $ mkAbortion' BadRequest
$ "Unparsable Content-Type: " ⊕ A.toText cType
- where
- p = do t ← mimeType
- P.endOfInput
- return t
-- |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 ← authCredential
- 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
-- 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
- $ mkAbortion' PreconditionFailed
- $ "The entity tag doesn't match: " ⊕ A.toText value
- Left _
- → abort $ mkAbortion' BadRequest
- $ "Unparsable If-Match: " ⊕ A.toText value
+ 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 method ≡ GET ∨ method ≡ HEAD then
-- If-None-Match があればそれを見る。
ifNoneMatch ← getHeader "If-None-Match"
case ifNoneMatch of
- Nothing → return ()
- Just value → if value ≡ "*" then
- abort $ mkAbortion' statusForNoneMatch
- $ "The entity tag matches: *"
- else
- case P.parseOnly p (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
+ 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 ← eTagList
- P.endOfInput
- return xs
-- |Tell the system that the 'Resource' found an entity for the
-- request URI. The only difference from 'foundEntity' is that
-- with \"400 Bad Request\".
--
-- Note that there are currently a few limitations on parsing
--- @multipart/form-data@. See 'parseMultipartFormData'
+-- @multipart/form-data@. See: 'parseMultipartFormData'
getForm ∷ Maybe Int → Resource [(Strict.ByteString, FormData)]
getForm limit
= do cTypeM ← getContentType
$ A.toText
$ A.fromAsciiBuilder
$ A.toAsciiBuilder "Unsupported media type: "
- ⊕ printMIMEType cType
+ ⊕ MT.printMIMEType cType
where
readWWWFormURLEncoded
= (map toPairWithFormData ∘ parseWWWFormURLEncoded)
Just a → return a
Nothing → abort $ mkAbortion' BadRequest "Malformed x-www-form-urlencoded"
- readMultipartFormData params
- = case M.lookup "boundary" params of
+ readMultipartFormData (MIMEParams m)
+ = case M.lookup "boundary" m of
Nothing
→ abort $ mkAbortion' BadRequest "Missing boundary of multipart/form-data"
Just boundary
-- 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.
-- |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
-- 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