module Network.HTTP.Lucu.Resource
( Resource
- , getMethod -- Resource Method
- , getHeader -- String -> Resource (Maybe String)
- , getAccept -- Resource [MIMEType]
+ , getConfig -- Resource Config
+ , getRequest -- Resource Request
+ , getMethod -- Resource Method
+ , getRequestURI -- Resource URI
+ , getResourcePath -- Resource [String]
+ , getPathInfo -- Resource [String]
+
+ , getHeader -- String -> Resource (Maybe String)
+ , getAccept -- Resource [MIMEType]
, getContentType -- Resource (Maybe MIMEType)
, foundEntity -- ETag -> ClockTime -> Resource ()
type Resource a = ReaderT Interaction IO a
+getConfig :: Resource Config
+getConfig = do itr <- ask
+ return $ itrConfig itr
+
+
+getRequest :: Resource Request
+getRequest = do itr <- ask
+ return $ fromJust $ itrRequest itr
+
+
getMethod :: Resource Method
-getMethod = do itr <- ask
- return $ reqMethod $ fromJust $ itrRequest itr
+getMethod = do req <- getRequest
+ return $ reqMethod req
+
+
+getRequestURI :: Resource URI
+getRequestURI = do req <- getRequest
+ return $ reqURI req
+
+
+getResourcePath :: Resource [String]
+getResourcePath = do itr <- ask
+ return $ fromJust $ itrResourcePath itr
+
+
+getPathInfo :: Resource [String]
+getPathInfo = do rsrcPath <- getResourcePath
+ reqURI <- getRequestURI
+ let reqPathStr = uriPath reqURI
+ reqPath = [x | x <- splitBy (== '/') reqPathStr, x /= ""]
+ -- rsrcPath と reqPath の共通する先頭部分を reqPath か
+ -- ら全部取り除くと、それは PATH_INFO のやうなものにな
+ -- る。rsrcPath は全部一致してゐるに決まってゐる（でな
+ -- ければこの Resource が撰ばれた筈が無い）ので、
+ -- rsrcPath の長さの分だけ削除すれば良い。
+ return $ drop (length rsrcPath) reqPath
getHeader :: String -> Resource (Maybe String)
-- tags の中に一致するものが無ければ
-- PreconditionFailed で終了。
-> when (not $ any (== tag) tags)
- $ abort PreconditionFailed [] ("The entity tag doesn't match: " ++ list)
- _ -> abort BadRequest [] ("Unparsable If-Match: " ++ fromJust ifMatch)
+ $ abort PreconditionFailed []
+ $ Just ("The entity tag doesn't match: " ++ list)
+ _ -> abort BadRequest [] $ Just ("Unparsable If-Match: " ++ fromJust ifMatch)
let statusForNoneMatch = if method == GET || method == HEAD then
NotModified
ifNoneMatch <- getHeader "If-None-Match"
case ifNoneMatch of
Nothing -> return ()
- Just "*" -> abort statusForNoneMatch [] ("The entity tag matches: *")
+ Just "*" -> abort statusForNoneMatch [] $ Just ("The entity tag matches: *")
Just list -> case parseStr eTagListP list of
(Success tags, _)
-> when (any (== tag) tags)
- $ abort statusForNoneMatch [] ("The entity tag matches: " ++ list)
- _ -> abort BadRequest [] ("Unparsable If-None-Match: " ++ list)
+ $ abort statusForNoneMatch [] $ Just ("The entity tag matches: " ++ list)
+ _ -> abort BadRequest [] $ Just ("Unparsable If-None-Match: " ++ list)
driftTo GettingBody
Just str -> case parseHTTPDateTime str of
Just lastTime
-> when (timeStamp <= lastTime)
- $ abort statusForIfModSince [] ("The entity has not been modified since " ++ str)
+ $ abort statusForIfModSince []
+ $ Just ("The entity has not been modified since " ++ str)
Nothing
-> return () -- 不正な時刻は無視
Nothing -> return ()
Just str -> case parseHTTPDateTime str of
Just lastTime
-> when (timeStamp > lastTime)
- $ abort PreconditionFailed [] ("The entity has not been modified since " ++ str)
+ $ abort PreconditionFailed []
+ $ Just ("The entity has not been modified since " ++ str)
Nothing
-> return () -- 不正な時刻は無視
Nothing -> return ()
foundNoEntity msgM
= do driftTo ExaminingRequest
- let msg = fromMaybe "The requested entity was not found in this server." msgM
-
method <- getMethod
when (method /= PUT)
- $ abort NotFound [] msg
+ $ abort NotFound [] msgM
-- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
-- If-Match: 條件も滿たさない。
ifMatch <- getHeader "If-Match"
when (ifMatch /= Nothing)
- $ abort PreconditionFailed [] msg
+ $ abort PreconditionFailed [] msgM
driftTo GettingBody
tooLarge :: Int -> STM ()
tooLarge lim = abortSTM RequestEntityTooLarge []
- ("Request body must be smaller than "
- ++ show lim ++ " bytes.")
+ $ Just ("Request body must be smaller than "
+ ++ show lim ++ " bytes.")
inputChunk :: Int -> Resource String
redirect code uri
= do when (code == NotModified || not (isRedirection code))
$ abort InternalServerError []
- $ "Attempted to redirect with status " ++ show code
+ $ Just ("Attempted to redirect with status " ++ show code)
setStatus code
setHeader "Location" (uriToString id uri $ "")
outputChunk = outputChunkBS . B.pack
+{- チャンクの大きさは Config で制限されてゐる。もし例へば /dev/zero を
+ B.readFile して作った ByteString をそのまま ResponseWriter に渡した
+ りすると大變な事が起こる。何故なら ResponseWriter は
+ Transfer-Encoding: chunked の時、ヘッダを書く爲にチャンクの大きさを
+ 測るから、その時に起こるであらう事は言ふまでも無い。 -}
+
outputChunkBS :: ByteString -> Resource ()
-outputChunkBS str = do driftTo DecidingBody
- itr <- ask
- liftIO $ atomically $
- do updateItr itr itrBodyToSend (flip B.append str)
- unless (B.null str)
- $ writeItr itr itrBodyIsNull False
+outputChunkBS str
+ = do driftTo DecidingBody
+ itr <- ask
+
+ let limit = cnfMaxOutputChunkLength $ itrConfig itr
+ when (limit <= 0)
+ $ fail ("cnfMaxOutputChunkLength must be positive: "
+ ++ show limit)
+
+ discardBody <- liftIO $ atomically $
+ readItr itr itrWillDiscardBody id
+ unless (discardBody)
+ $ sendChunks str limit
+
+ unless (B.null str)
+ $ liftIO $ atomically $
+ writeItr itr itrBodyIsNull False
+ where
+ sendChunks :: ByteString -> Int -> Resource ()
+ sendChunks str limit
+ | B.null str = return ()
+ | otherwise = do let (chunk, remaining) = B.splitAt (fromIntegral limit) str
+ itr <- ask
+ liftIO $ atomically $
+ do buf <- readItr itr itrBodyToSend id
+ if B.null buf then
+ -- バッファが消化された
+ writeItr itr itrBodyToSend chunk
+ else
+ -- 消化されるのを待つ
+ retry
+ -- 殘りのチャンクについて繰り返す
+ sendChunks remaining limit
{-
projects / Lucu.git / blobdiff