--- |Get a value of given request header. Comparison of header name is
--- case-insensitive. Note that this action is not intended to be used
--- so frequently: there should be an action like 'getContentType' for
--- every common headers.
-getHeader :: String -> Resource (Maybe String)
-getHeader name = do itr <- ask
- return $ H.getHeader name $ fromJust $ itrRequest itr
-
--- |Get a list of 'Network.HTTP.Lucu.MIMEType.MIMEType' enumerated on
--- header \"Accept\".
-getAccept :: Resource [MIMEType]
-getAccept = do accept <- getHeader "Accept"
- if accept == Nothing then
- return []
+-- |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)]
+getQueryForm = parse' <$> getRequestURI
+ where
+ parse' = map toPairWithFormData ∘
+ parseWWWFormURLEncoded ∘
+ fromJust ∘
+ A.fromChars ∘
+ drop 1 ∘
+ uriQuery
+
+toPairWithFormData ∷ (ByteString, ByteString) → (Text, FormData)
+toPairWithFormData (name, value)
+ = let fd = FormData {
+ fdFileName = Nothing
+ , fdContent = Lazy.fromChunks [value]
+ }
+ in (T.decodeUtf8 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 functions like 'getContentType' for every common headers.
+getHeader ∷ CIAscii → Resource (Maybe Ascii)
+getHeader name
+ = H.getHeader name <$> getRequest
+
+-- |Return the list of 'MIMEType' enumerated on the value of request
+-- header \"Accept\", or @[]@ if absent.
+getAccept ∷ Resource [MIMEType]
+getAccept
+ = do acceptM ← getHeader "Accept"
+ case acceptM of
+ Nothing
+ → return []
+ Just accept
+ → case P.parseOnly p (A.toByteString accept) of
+ Right xs → return xs
+ Left _ → abort $ mkAbortion' BadRequest
+ $ "Unparsable Accept: " ⊕ A.toText accept
+ where
+ p = do xs ← mimeTypeListP
+ P.endOfInput
+ return xs
+
+-- |Return the list of @(contentCoding, qvalue)@ enumerated on the
+-- value of request header \"Accept-Encoding\". The list is sorted in
+-- descending order by qvalue.
+getAcceptEncoding ∷ Resource [(CIAscii, Maybe Double)]
+getAcceptEncoding
+ = do accEncM ← getHeader "Accept-Encoding"
+ case accEncM of
+ Nothing
+ -- HTTP/1.0 には Accept-Encoding が無い場合の規定が無い
+ -- ので安全の爲 identity が指定された事にする。HTTP/1.1
+ -- の場合は何でも受け入れて良い事になってゐるので "*" が
+ -- 指定された事にする。
+ → do ver ← getRequestVersion
+ case ver of
+ HttpVersion 1 0 → return [("identity", Nothing)]
+ HttpVersion 1 1 → return [("*" , Nothing)]
+ _ → abort $ mkAbortion' InternalServerError
+ "getAcceptEncoding: unknown HTTP version"
+ Just ae
+ → if ae ≡ "" then
+ -- identity のみが許される。
+ return [("identity", Nothing)]