, getRequest
, getMethod
, getRequestURI
+ , getRequestVersion
, getResourcePath
, getPathInfo
, getQueryForm
, getHeader
, getAccept
+ , getAcceptEncoding
+ , isEncodingAcceptable
, getContentType
-- ** Finding an entity
, redirect
, setContentType
, setLocation
+ , setContentEncoding
-- ** Writing a response body
import Data.ByteString.Lazy.Char8 (ByteString)
import Data.List
import Data.Maybe
-import GHC.Conc (unsafeIOToSTM)
import Network.HTTP.Lucu.Abortion
import Network.HTTP.Lucu.Config
+import Network.HTTP.Lucu.ContentCoding
import Network.HTTP.Lucu.DefaultPage
import Network.HTTP.Lucu.ETag
import qualified Network.HTTP.Lucu.Headers as H
getRequestURI = do req <- getRequest
return $! reqURI req
+-- |Get the HTTP version of the request.
+getRequestVersion :: Resource HttpVersion
+getRequestVersion = do req <- getRequest
+ return $! reqVersion req
+
-- |Get the path of this 'Resource' (to be exact,
-- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef') in the
-- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this
-- |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 []
- else
- case parseStr mimeTypeListP $ fromJust accept of
- (Success xs, _) -> return xs
- _ -> return []
+getAccept = do acceptM <- getHeader "Accept"
+ case acceptM of
+ Nothing
+ -> return []
+ Just accept
+ -> case parseStr mimeTypeListP accept of
+ (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
+-- qvalue.
+getAcceptEncoding :: Resource [(String, 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)]
+ 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)
+
+-- |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)
+
-- |Get the header \"Content-Type\" as
-- 'Network.HTTP.Lucu.MIMEType.MIMEType'.
getContentType :: Resource (Maybe MIMEType)
-getContentType = do cType <- getHeader "Content-Type"
- if cType == Nothing then
- return Nothing
- else
- case parseStr mimeTypeP $ fromJust cType of
- (Success t, _) -> return $ Just t
- _ -> return Nothing
-
+getContentType
+ = do cTypeM <- getHeader "Content-Type"
+ case cTypeM of
+ Nothing
+ -> return Nothing
+ Just cType
+ -> case parseStr mimeTypeP cType of
+ (Success t, _) -> return $ Just t
+ _ -> abort BadRequest []
+ (Just $ "Unparsable Content-Type: " ++ cType)
{- ExaminingRequest 時に使用するアクション群 -}
setLocation uri
= setHeader "Location" $ uriToString id uri $ ""
+-- |Computation of @'setContentEncoding' codings@ sets the response
+-- header \"Content-Encoding\" to @codings@.
+setContentEncoding :: [String] -> Resource ()
+setContentEncoding codings
+ = do ver <- getRequestVersion
+ let tr = case ver of
+ HttpVersion 1 0 -> unnormalizeCoding
+ HttpVersion 1 1 -> id
+ setHeader "Content-Encoding" $ joinWith ", " $ map tr codings
+
{- DecidingBody 時に使用するアクション群 -}