import Control.Concurrent.STM
import Control.Monad.Reader
import Data.Bits
-import Data.ByteString.Base (LazyByteString)
-import qualified Data.ByteString.Lazy.Char8 as B
+import Data.ByteString.Base (ByteString, LazyByteString(..))
+import qualified Data.ByteString.Char8 as C8
+import qualified Data.ByteString.Lazy.Char8 as L8
import Data.List
import Data.Maybe
import Network.HTTP.Lucu.Abortion
-- case-insensitive. Note that this action is not intended to be used
-- so frequently: there should be actions like 'getContentType' for
-- every common headers.
-getHeader :: String -> Resource (Maybe String)
+getHeader :: ByteString -> Resource (Maybe ByteString)
getHeader name = name `seq`
do req <- getRequest
return $! H.getHeader name req
-- |Get a list of 'Network.HTTP.Lucu.MIMEType.MIMEType' enumerated on
-- header \"Accept\".
getAccept :: Resource [MIMEType]
-getAccept = do acceptM <- getHeader "Accept"
+getAccept = do acceptM <- getHeader (C8.pack "Accept")
case acceptM of
Nothing
-> return []
Just accept
- -> case parseStr mimeTypeListP accept of
+ -> case parse mimeTypeListP (LPS [accept]) of
(# Success xs, _ #) -> return xs
(# _ , _ #) -> abort BadRequest []
- (Just $ "Unparsable Accept: " ++ accept)
+ (Just $ "Unparsable Accept: " ++ C8.unpack accept)
-- |Get a list of @(contentCoding, qvalue)@ enumerated on header
-- \"Accept-Encoding\". The list is sorted in descending order by
-- qvalue.
getAcceptEncoding :: Resource [(String, Maybe Double)]
getAcceptEncoding
- = do accEncM <- getHeader "Accept-Encoding"
+ = do accEncM <- getHeader (C8.pack "Accept-Encoding")
case accEncM of
Nothing
-- HTTP/1.0 には Accept-Encoding が無い場合の規定が無い
case ver of
HttpVersion 1 0 -> return [("identity", Nothing)]
HttpVersion 1 1 -> return [("*" , Nothing)]
- Just ""
- -- identity のみが許される。
- -> return [("identity", Nothing)]
- Just accEnc
- -> case parseStr acceptEncodingListP accEnc of
- (# Success x, _ #) -> return $ reverse $ sortBy orderAcceptEncodings x
- (# _ , _ #) -> abort BadRequest []
- (Just $ "Unparsable Accept-Encoding: " ++ accEnc)
+ Just value
+ -> if C8.null value then
+ -- identity のみが許される。
+ return [("identity", Nothing)]
+ else
+ case parse acceptEncodingListP (LPS [value]) of
+ (# Success x, _ #) -> return $ reverse $ sortBy orderAcceptEncodings x
+ (# _ , _ #) -> abort BadRequest []
+ (Just $ "Unparsable Accept-Encoding: " ++ C8.unpack value)
-- |Check whether a given content-coding is acceptable.
isEncodingAcceptable :: String -> Resource Bool
isEncodingAcceptable coding
= do accList <- getAcceptEncoding
return (flip any accList $ \ (c, q) ->
- (c == "*" || c `noCaseEq` coding) && q /= Just 0)
+ (c == "*" || C8.pack c `H.noCaseEq` C8.pack coding) && q /= Just 0)
-- |Get the header \"Content-Type\" as
-- 'Network.HTTP.Lucu.MIMEType.MIMEType'.
getContentType :: Resource (Maybe MIMEType)
getContentType
- = do cTypeM <- getHeader "Content-Type"
+ = do cTypeM <- getHeader (C8.pack "Content-Type")
case cTypeM of
Nothing
-> return Nothing
Just cType
- -> case parseStr mimeTypeP cType of
+ -> case parse mimeTypeP (LPS [cType]) of
(# Success t, _ #) -> return $ Just t
(# _ , _ #) -> abort BadRequest []
- (Just $ "Unparsable Content-Type: " ++ cType)
+ (Just $ "Unparsable Content-Type: " ++ C8.unpack cType)
{- ExaminingRequest 時に使用するアクション群 -}
method <- getMethod
when (method == GET || method == HEAD)
- $ setHeader' "Last-Modified" $! formatHTTPDateTime timeStamp
+ $ setHeader' (C8.pack "Last-Modified") (C8.pack $ formatHTTPDateTime timeStamp)
when (method == POST)
$ abort InternalServerError []
(Just "Illegal computation of foundEntity for POST request.")
method <- getMethod
when (method == GET || method == HEAD)
- $ setHeader' "ETag" $! show tag
+ $ setHeader' (C8.pack "ETag") (C8.pack $ show tag)
when (method == POST)
$ abort InternalServerError []
(Just "Illegal computation of foundETag for POST request.")
-- If-Match があればそれを見る。
- ifMatch <- getHeader "If-Match"
+ ifMatch <- getHeader (C8.pack "If-Match")
case ifMatch of
- Nothing -> return ()
- Just "*" -> return ()
- Just list -> case parseStr eTagListP list of
- (# 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)
+ Nothing -> return ()
+ Just value -> if value == C8.pack "*" then
+ return ()
+ else
+ case parse eTagListP (LPS [value]) of
+ (# Success tags, _ #)
+ -- tags の中に一致するものが無ければ
+ -- PreconditionFailed で終了。
+ -> when (not $ any (== tag) tags)
+ $ abort PreconditionFailed []
+ $! Just ("The entity tag doesn't match: " ++ C8.unpack value)
+ (# _, _ #)
+ -> abort BadRequest [] $! Just ("Unparsable If-Match: " ++ C8.unpack value)
let statusForNoneMatch = if method == GET || method == HEAD then
NotModified
PreconditionFailed
-- If-None-Match があればそれを見る。
- ifNoneMatch <- getHeader "If-None-Match"
+ ifNoneMatch <- getHeader (C8.pack "If-None-Match")
case ifNoneMatch of
- Nothing -> return ()
- Just "*" -> abort statusForNoneMatch [] $! Just ("The entity tag matches: *")
- Just list -> case parseStr eTagListP list of
- (# Success tags, _ #)
- -> when (any (== tag) tags)
- $ abort statusForNoneMatch [] $! Just ("The entity tag matches: " ++ list)
- (# _, _ #)
- -> abort BadRequest [] $! Just ("Unparsable If-None-Match: " ++ list)
+ Nothing -> return ()
+ Just value -> if value == C8.pack "*" then
+ abort statusForNoneMatch [] $! Just ("The entity tag matches: *")
+ else
+ case parse eTagListP (LPS [value]) of
+ (# Success tags, _ #)
+ -> when (any (== tag) tags)
+ $ abort statusForNoneMatch [] $! Just ("The entity tag matches: " ++ C8.unpack value)
+ (# _, _ #)
+ -> abort BadRequest [] $! Just ("Unparsable If-None-Match: " ++ C8.unpack value)
driftTo GettingBody
method <- getMethod
when (method == GET || method == HEAD)
- $ setHeader' "Last-Modified" $! formatHTTPDateTime timeStamp
+ $ setHeader' (C8.pack "Last-Modified") (C8.pack $ formatHTTPDateTime timeStamp)
when (method == POST)
$ abort InternalServerError []
(Just "Illegal computation of foundTimeStamp for POST request.")
PreconditionFailed
-- If-Modified-Since があればそれを見る。
- ifModSince <- getHeader "If-Modified-Since"
+ ifModSince <- getHeader (C8.pack "If-Modified-Since")
case ifModSince of
- Just str -> case parseHTTPDateTime str of
+ Just str -> case parseHTTPDateTime (LPS [str]) of
Just lastTime
-> when (timeStamp <= lastTime)
$ abort statusForIfModSince []
- $! Just ("The entity has not been modified since " ++ str)
+ $! Just ("The entity has not been modified since " ++ C8.unpack str)
Nothing
-> return () -- 不正な時刻は無視
Nothing -> return ()
-- If-Unmodified-Since があればそれを見る。
- ifUnmodSince <- getHeader "If-Unmodified-Since"
+ ifUnmodSince <- getHeader (C8.pack "If-Unmodified-Since")
case ifUnmodSince of
- Just str -> case parseHTTPDateTime str of
+ Just str -> case parseHTTPDateTime (LPS [str]) of
Just lastTime
-> when (timeStamp > lastTime)
$ abort PreconditionFailed []
- $! Just ("The entity has not been modified since " ++ str)
+ $! Just ("The entity has not been modified since " ++ C8.unpack str)
Nothing
-> return () -- 不正な時刻は無視
Nothing -> return ()
-- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
-- If-Match: 條件も滿たさない。
- ifMatch <- getHeader "If-Match"
+ ifMatch <- getHeader (C8.pack "If-Match")
when (ifMatch /= Nothing)
$ abort PreconditionFailed [] msgM
-- use it whenever possible.
input :: Int -> Resource String
input limit = limit `seq`
- inputLBS limit >>= return . B.unpack
+ inputLBS limit >>= return . L8.unpack
-- | This is mostly the same as 'input' but is more
askForInput itr
else
do driftTo DecidingHeader
- return B.empty
+ return L8.empty
return chunk
where
askForInput :: Interaction -> Resource LazyByteString
chunk <- liftIO $! atomically
$! do chunk <- readItr itr itrReceivedBody id
chunkIsOver <- readItr itr itrReqChunkIsOver id
- if B.length chunk < fromIntegral actualLimit then
+ if L8.length chunk < fromIntegral actualLimit then
-- 要求された量に滿たなくて、まだ殘り
-- があるなら再試行。
unless chunkIsOver
$ tooLarge actualLimit
-- 成功。itr 内にチャンクを置いたままにす
-- るとメモリの無駄になるので除去。
- writeItr itr itrReceivedBody B.empty
+ writeItr itr itrReceivedBody L8.empty
return chunk
driftTo DecidingHeader
return chunk
-- should use it whenever possible.
inputChunk :: Int -> Resource String
inputChunk limit = limit `seq`
- inputChunkLBS limit >>= return . B.unpack
+ inputChunkLBS limit >>= return . L8.unpack
-- | This is mostly the same as 'inputChunk' but is more
askForInput itr
else
do driftTo DecidingHeader
- return B.empty
+ return L8.empty
return chunk
where
askForInput :: Interaction -> Resource LazyByteString
$ do chunk <- readItr itr itrReceivedBody id
-- 要求された量に滿たなくて、まだ殘りがあ
-- るなら再試行。
- when (B.length chunk < fromIntegral actualLimit)
+ when (L8.length chunk < fromIntegral actualLimit)
$ do chunkIsOver <- readItr itr itrReqChunkIsOver id
unless chunkIsOver
$ retry
-- 成功
- writeItr itr itrReceivedBody B.empty
+ writeItr itr itrReceivedBody L8.empty
return chunk
- when (B.null chunk)
+ when (L8.null chunk)
$ driftTo DecidingHeader
return chunk
-- 20 bytes long. In this case the client shall only accept the first
-- 10 bytes of response body and thinks that the residual 10 bytes is
-- a part of header of the next response.
-setHeader :: String -> String -> Resource ()
+setHeader :: ByteString -> ByteString -> Resource ()
setHeader name value
= name `seq` value `seq`
driftTo DecidingHeader >> setHeader' name value
-setHeader' :: String -> String -> Resource ()
+setHeader' :: ByteString -> ByteString -> Resource ()
setHeader' name value
= name `seq` value `seq`
do itr <- getInteraction
-- \"Content-Type\" to @mType@.
setContentType :: MIMEType -> Resource ()
setContentType mType
- = setHeader "Content-Type" $! show mType
+ = setHeader (C8.pack "Content-Type") (C8.pack $ show mType)
-- | Computation of @'setLocation' uri@ sets the response header
-- \"Location\" to @uri@.
setLocation :: URI -> Resource ()
setLocation uri
- = setHeader "Location" $ uriToString id uri $ ""
+ = setHeader (C8.pack "Location") (C8.pack $ uriToString id uri $ "")
-- |Computation of @'setContentEncoding' codings@ sets the response
-- header \"Content-Encoding\" to @codings@.
let tr = case ver of
HttpVersion 1 0 -> unnormalizeCoding
HttpVersion 1 1 -> id
- setHeader "Content-Encoding" $ joinWith ", " $ map tr codings
+ setHeader (C8.pack "Content-Encoding") (C8.pack $ joinWith ", " $ map tr codings)
{- DecidingBody 時に使用するアクション群 -}
-- Note that 'outputLBS' is more efficient than 'output' so you should
-- use it whenever possible.
output :: String -> Resource ()
-output str = outputLBS $! B.pack str
+output str = outputLBS $! L8.pack str
{-# INLINE output #-}
-- | This is mostly the same as 'output' but is more efficient.
-- Note that 'outputChunkLBS' is more efficient than 'outputChunk' so
-- you should use it whenever possible.
outputChunk :: String -> Resource ()
-outputChunk str = outputChunkLBS $! B.pack str
+outputChunk str = outputChunkLBS $! L8.pack str
{-# INLINE outputChunk #-}
-- | This is mostly the same as 'outputChunk' but is more efficient.
unless (discardBody)
$ sendChunks str limit
- unless (B.null str)
+ unless (L8.null str)
$ liftIO $ atomically $
writeItr itr itrBodyIsNull False
where
-- チャンクの大きさは Config で制限されてゐる。もし例へば
- -- "/dev/zero" を B.readFile して作った LazyByteString をそのまま
+ -- "/dev/zero" を L8.readFile して作った LazyByteString をそのまま
-- ResponseWriter に渡したりすると大變な事が起こる。何故なら
-- ResponseWriter は Transfer-Encoding: chunked の時、ヘッダを書
-- く爲にチャンクの大きさを測る。
sendChunks :: LazyByteString -> Int -> Resource ()
sendChunks str limit
- | B.null str = return ()
- | otherwise = do let (chunk, remaining) = B.splitAt (fromIntegral limit) str
- itr <- getInteraction
- liftIO $ atomically $
- do buf <- readItr itr itrBodyToSend id
- if B.null buf then
- -- バッファが消化された
- writeItr itr itrBodyToSend chunk
- else
- -- 消化されるのを待つ
- retry
- -- 殘りのチャンクについて繰り返す
- sendChunks remaining limit
+ | L8.null str = return ()
+ | otherwise = do let (chunk, remaining) = L8.splitAt (fromIntegral limit) str
+ itr <- getInteraction
+ liftIO $ atomically $
+ do buf <- readItr itr itrBodyToSend id
+ if L8.null buf then
+ -- バッファが消化された
+ writeItr itr itrBodyToSend chunk
+ else
+ -- 消化されるのを待つ
+ retry
+ -- 殘りのチャンクについて繰り返す
+ sendChunks remaining limit
{-
projects / Lucu.git / blobdiff