* 304 Not Modified 以外の 3xx なのに Location ヘッダが無ければ 500 に
する。
- * Content-Length があれば、それを削除する。
+ * Content-Length があれば、それを削除する。Transfer-Encoding があって
+ も削除する。
- * HTTP/1.1 であり、且つ body を持つ事が出來る時、Transfer-Encoding の
- 最後の要素が chunked でなければ 500 Internal Error にする。
- Transfer-Encoding が未設定であれば、chunked に設定する。
-
- * HTTP/1.0 なのに Transfer-Encoding が設定濟なら 500 Internal Server
- Error にする。但し identity だけは許す。
+ * HTTP/1.1 であり、body を持つ事が出來る時、Transfer-Encoding を
+ chunked に設定する。
* body を持つ事が出來る時、Content-Type が無ければデフォルト値にする。
出來ない時、HEAD でなければContent-Type, Etag, Last-Modified を削除
when (itrRequest itr /= Nothing)
$ relyOnRequest itr
- do newRes <- unsafeIOToSTM
- $ completeUnconditionalHeaders (itrConfig itr) res
+ -- itrResponse の内容は relyOnRequest によって變へられてゐる可
+ -- 能性が高い。
+ do oldRes <- readItr itr itrResponse id
+ newRes <- unsafeIOToSTM
+ $ completeUnconditionalHeaders (itrConfig itr) oldRes
writeItr itr itrResponse newRes
where
relyOnRequest :: Interaction -> STM ()
status == NotModified )
updateRes itr $ deleteHeader "Content-Length"
+ updateRes itr $ deleteHeader "Transfer-Encoding"
cType <- readHeader itr "Content-Type"
when (cType == Nothing)
$ updateRes itr $ setHeader "Content-Type" defaultPageContentType
if canHaveBody then
- do teM <- readHeader itr "Transfer-Encoding"
- if reqVer == HttpVersion 1 1 then
-
- do case teM of
- Nothing -> updateRes itr $ setHeader "Transfer-Encoding" "chunked"
- Just te -> let teList = [trim isWhiteSpace x
- | x <- splitBy (== ',') (map toLower te)]
- in
- when (teList == [] || last teList /= "chunked")
- $ abortSTM InternalServerError []
- $ Just ("Transfer-Encoding must end with `chunked' "
- ++ "because this is an HTTP/1.1 request: "
- ++ te)
-
- writeItr itr itrWillChunkBody True
- else
- case fmap (map toLower) teM of
- Nothing -> return ()
- Just "identity" -> return ()
- Just te -> abortSTM InternalServerError []
- $ Just ("Transfer-Encoding must be `identity' because "
- ++ "this is an HTTP/1.0 request: "
- ++ te)
+ when (reqVer == HttpVersion 1 1)
+ $ do updateRes itr $ setHeader "Transfer-Encoding" "chunked"
+ writeItr itr itrWillChunkBody True
else
-- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す
- do updateRes itr $ deleteHeader "Transfer-Encoding"
- when (reqMethod req /= HEAD)
- $ do updateRes itr $ deleteHeader "Content-Type"
- updateRes itr $ deleteHeader "Etag"
- updateRes itr $ deleteHeader "Last-Modified"
+ when (reqMethod req /= HEAD)
+ $ do updateRes itr $ deleteHeader "Content-Type"
+ updateRes itr $ deleteHeader "Etag"
+ updateRes itr $ deleteHeader "Last-Modified"
conn <- readHeader itr "Connection"
case fmap (map toLower) conn of
, setStatus
, setHeader
, redirect
- , setETag
- , setLastModified
, setContentType
-- ** Writing a response body
{- ExaminingRequest 時に使用するアクション群 -}
+-- |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
+-- a datum to be replied. If this is a PUT or DELETE request, it means
+-- a datum which was stored for the URI up to now. It is an error to
+-- compute 'foundEntity' if this is a POST request.
+--
+-- Computation of 'foundEntity' performs \"If-Match\" test or
+-- \"If-None-Match\" test if possible. When those tests fail, the
+-- computation of 'Resource' immediately aborts with status \"412
+-- Precondition Failed\" or \"304 Not Modified\" depending on the
+-- situation.
+--
+-- If this is a GET or HEAD request, 'foundEntity' automatically puts
+-- \"ETag\" and \"Last-Modified\" headers into the response.
foundEntity :: ETag -> ClockTime -> Resource ()
foundEntity tag timeStamp
= do driftTo ExaminingRequest
method <- getMethod
when (method == GET || method == HEAD)
$ setHeader' "Last-Modified" $ formatHTTPDateTime timeStamp
+ when (method == POST)
+ $ abort InternalServerError []
+ (Just "Illegal computation of foundEntity for POST request.")
foundETag tag
driftTo GettingBody
-
+-- |Tell the system that the 'Resource' found an entity for the
+-- request URI. The only difference from 'foundEntity' is that
+-- 'foundETag' doesn't (and can't) put \"Last-Modified\" header into
+-- the response.
+--
+-- This action is not preferred. You should use 'foundEntity' when
+-- possible.
foundETag :: ETag -> Resource ()
foundETag tag
= do driftTo ExaminingRequest
method <- getMethod
when (method == GET || method == HEAD)
$ setHeader' "ETag" $ show tag
+ when (method == POST)
+ $ abort InternalServerError []
+ (Just "Illegal computation of foundETag for POST request.")
-- If-Match があればそれを見る。
ifMatch <- getHeader "If-Match"
driftTo GettingBody
-
+-- |Tell the system that the 'Resource' found an entity for the
+-- request URI. The only difference from 'foundEntity' is that
+-- 'foundTimeStamp' performs \"If-Modified-Since\" test or
+-- \"If-Unmodified-Since\" test instead of \"If-Match\" test or
+-- \"If-None-Match\" test. Be aware that any tests based on last
+-- modification time are unsafe because it is possible to mess up such
+-- tests by modifying the entity twice in a second.
+--
+-- This action is not preferred. You should use 'foundEntity' when
+-- possible.
foundTimeStamp :: ClockTime -> Resource ()
foundTimeStamp timeStamp
= do driftTo ExaminingRequest
method <- getMethod
when (method == GET || method == HEAD)
$ setHeader' "Last-Modified" $ formatHTTPDateTime timeStamp
+ when (method == POST)
+ $ abort InternalServerError []
+ (Just "Illegal computation of foundTimeStamp for POST request.")
let statusForIfModSince = if method == GET || method == HEAD then
NotModified
driftTo GettingBody
-
+-- |Computation of @'foundNoEntity' mStr@ tell the system that the
+-- 'Resource' found no entity for the request URI. @mStr@ is an
+-- optional error message to be replied to the client.
+--
+-- If this is a PUT request, 'foundNoEntity' performs \"If-Match\"
+-- test and aborts with status \"412 Precondition Failed\" when it
+-- failed. If this is a GET, HEAD or DELETE request, 'foundNoEntity'
+-- always aborts with status \"404 Not Found\". It is an error to
+-- compute 'foundNoEntity' if this is a POST request.
foundNoEntity :: Maybe String -> Resource ()
foundNoEntity msgM
= do driftTo ExaminingRequest
method <- getMethod
+ when (method == POST)
+ $ abort InternalServerError []
+ (Just "Illegal computation of foundNoEntity for POST request.")
when (method /= PUT)
- $ abort NotFound [] msgM
+ $ abort NotFound [] msgM
-- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
-- If-Match: 條件も滿たさない。
resStatus = code
}
-
+-- | Set a value of given resource 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 'setContentType'
+-- for every common headers.
+--
+-- Some important headers (especially \"Content-Length\" and
+-- \"Transfer-Encoding\") may be silently deleted or overwritten by
+-- the system not to corrupt the interaction with client at the
+-- viewpoint of HTTP protocol. For instance, if we are keeping
+-- connection alive, for an obvious reason it causes a catastrophe to
+-- send header \"Content-Length: 10\" and actually sending body of 20
+-- bytes long.
setHeader :: String -> String -> Resource ()
setHeader name value
= driftTo DecidingHeader >> setHeader' name value
setHeader "Location" (uriToString id uri $ "")
-setETag :: ETag -> Resource ()
-setETag tag
- = setHeader "ETag" $ show tag
-
-
-setLastModified :: ClockTime -> Resource ()
-setLastModified lastmod
- = setHeader "Last-Modified" $ formatHTTPDateTime lastmod
-
-
setContentType :: MIMEType -> Resource ()
setContentType mType
= setHeader "Content-Type" $ show mType
projects / Lucu.git / commitdiff