-- exception for parse error.
parseMIMEType :: String -> MIMEType
parseMIMEType str = case parseStr mimeTypeP str of
- (Success t, r) -> if B.null r then
- t
- else
- error ("unparsable MIME Type: " ++ str)
- _ -> error ("unparsable MIME Type: " ++ str)
+ (# Success t, r #) -> if B.null r
+ then t
+ else error ("unparsable MIME Type: " ++ str)
+ (# _ , _ #) -> error ("unparsable MIME Type: " ++ str)
mimeTypeP :: Parser MIMEType
= fpath `seq`
do file <- B.readFile fpath
case parse (allowEOF extMapP) file of
- (Success xs, _) -> return $ compile xs
- (_, input') -> let near = B.unpack $ B.take 100 input'
- in
- fail ("Failed to parse: " ++ fpath ++ " (near: " ++ near ++ ")")
+ (# Success xs, _ #)
+ -> return $ compile xs
+
+ (# _, input' #)
+ -> let near = B.unpack $ B.take 100 input'
+ in
+ fail ("Failed to parse: " ++ fpath ++ " (near: " ++ near ++ ")")
extMapP :: Parser [ (MIMEType, [String]) ]
-- |@'parse' p bstr@ parses @bstr@ with @p@ and returns @(result,
-- remaining)@.
-parse :: Parser a -> LazyByteString -> (ParserResult a, LazyByteString)
+parse :: Parser a -> LazyByteString -> (# ParserResult a, LazyByteString #)
parse p input -- input は lazy である必要有り。
= p `seq`
let (result, state') = runState (runParser p) (PST input True)
in
- result `seq` (result, pstInput state') -- pstInput state' も lazy である必要有り。
+ result `seq` (# result, pstInput state' #) -- pstInput state' も lazy である必要有り。
-- |@'parseStr' p str@ packs @str@ and parses it.
-parseStr :: Parser a -> String -> (ParserResult a, LazyByteString)
+parseStr :: Parser a -> String -> (# ParserResult a, LazyByteString #)
parseStr p input
= p `seq` -- input は lazy である必要有り。
- parse p $! B.pack input
+ parse p (B.pack input)
anyChar :: Parser Char
parseHTTPDateTime :: String -> Maybe ClockTime
parseHTTPDateTime src
= case parseStr httpDateTime src of
- (Success ct, _) -> Just ct
- _ -> Nothing
+ (# Success ct, _ #) -> Just ct
+ (# _ , _ #) -> Nothing
httpDateTime :: Parser ClockTime
-- Request 應答を設定し、それを出力してから切斷するやう
-- に ResponseWriter に通知する。
case parse requestP input of
- (Success req , input') -> acceptParsableRequest req input'
- (IllegalInput, _ ) -> acceptNonparsableRequest BadRequest
- (ReachedEOF , _ ) -> acceptNonparsableRequest BadRequest
+ (# Success req , input' #) -> acceptParsableRequest req input'
+ (# IllegalInput, _ #) -> acceptNonparsableRequest BadRequest
+ (# ReachedEOF , _ #) -> acceptNonparsableRequest BadRequest
acceptNonparsableRequest :: StatusCode -> IO ()
acceptNonparsableRequest status
-- 讀み終へてゐない
do let (_, input') = B.splitAt (fromIntegral
$ fromJust remainingM) input
- (footerR, input'') = parse chunkFooterP input'
+ (# footerR, input'' #) = parse chunkFooterP input'
if footerR == Success () then
-- チャンクフッタを正常に讀めた
if newRemaining == Just 0 then
-- チャンクフッタを讀む
case parse chunkFooterP input' of
- (Success _, input'')
+ (# Success _, input'' #)
-> do updateStates
return $ observeChunkedRequest itr input''
- _ -> return $ chunkWasMalformed itr
+ (# _, _ #)
+ -> return $ chunkWasMalformed itr
else
-- まだチャンクの終はりに達してゐない
do updateStates
= {-# SCC "seekNextChunk" #-}
case parse chunkHeaderP input of
-- 最終チャンク (中身が空)
- (Success 0, input')
+ (# Success 0, input' #)
-> case parse chunkTrailerP input' of
- (Success _, input'')
+ (# Success _, input'' #)
-> do writeItr itr itrReqChunkLength $ Nothing
writeItr itr itrReqChunkRemaining $ Nothing
writeItr itr itrReqChunkIsOver True
return $ acceptRequest input''
- _ -> return $ chunkWasMalformed itr
+ (# _, _ #)
+ -> return $ chunkWasMalformed itr
-- 最終でないチャンク
- (Success len, input')
+ (# Success len, input' #)
-> do writeItr itr itrReqChunkLength $ Just len
writeItr itr itrReqChunkRemaining $ Just len
return $ observeChunkedRequest itr input'
-- チャンクヘッダがをかしい
- _ -> return $ chunkWasMalformed itr
+ (# _, _ #)
+ -> return $ chunkWasMalformed itr
chunkWasMalformed :: Interaction -> IO ()
chunkWasMalformed itr
-> return []
Just accept
-> case parseStr mimeTypeListP accept of
- (Success xs, _) -> return xs
- _ -> abort BadRequest []
- (Just $ "Unparsable Accept: " ++ accept)
+ (# Success xs, _ #) -> return xs
+ (# _ , _ #) -> abort BadRequest []
+ (Just $ "Unparsable Accept: " ++ accept)
-- |Get a list of @(contentCoding, qvalue)@ enumerated on header
-- \"Accept-Encoding\". The list is sorted in descending order by
-> return [("identity", Nothing)]
Just accEnc
-> case parseStr acceptEncodingListP accEnc of
- (Success x, _) -> return $ reverse $ sortBy orderAcceptEncodings x
- _ -> abort BadRequest []
- (Just $ "Unparsable Accept-Encoding: " ++ accEnc)
+ (# Success x, _ #) -> return $ reverse $ sortBy orderAcceptEncodings x
+ (# _ , _ #) -> abort BadRequest []
+ (Just $ "Unparsable Accept-Encoding: " ++ accEnc)
-- |Check whether a given content-coding is acceptable.
isEncodingAcceptable :: String -> Resource Bool
-> return Nothing
Just cType
-> case parseStr mimeTypeP cType of
- (Success t, _) -> return $ Just t
- _ -> abort BadRequest []
- (Just $ "Unparsable Content-Type: " ++ cType)
+ (# Success t, _ #) -> return $ Just t
+ (# _ , _ #) -> abort BadRequest []
+ (Just $ "Unparsable Content-Type: " ++ cType)
{- ExaminingRequest 時に使用するアクション群 -}
Nothing -> return ()
Just "*" -> return ()
Just list -> case parseStr eTagListP list of
- (Success tags, _)
+ (# Success tags, _ #)
-- tags の中に一致するものが無ければ
-- PreconditionFailed で終了。
-> when (not $ any (== tag) tags)
$ abort PreconditionFailed []
$! Just ("The entity tag doesn't match: " ++ list)
- _ -> abort BadRequest [] $! Just ("Unparsable If-Match: " ++ fromJust ifMatch)
+ (# _, _ #)
+ -> abort BadRequest [] $! Just ("Unparsable If-Match: " ++ fromJust ifMatch)
let statusForNoneMatch = if method == GET || method == HEAD then
NotModified
Nothing -> return ()
Just "*" -> abort statusForNoneMatch [] $! Just ("The entity tag matches: *")
Just list -> case parseStr eTagListP list of
- (Success tags, _)
+ (# Success tags, _ #)
-> when (any (== tag) tags)
$ abort statusForNoneMatch [] $! Just ("The entity tag matches: " ++ list)
- _ -> abort BadRequest [] $! Just ("Unparsable If-None-Match: " ++ list)
+ (# _, _ #)
+ -> abort BadRequest [] $! Just ("Unparsable If-None-Match: " ++ list)
driftTo GettingBody
projects / Lucu.git / commitdiff