diff --git a/Network/CGI.hs b/Network/CGI.hs --- a/Network/CGI.hs +++ b/Network/CGI.hs @@ -66,6 +66,7 @@ , getInputFilename, getInputContentType -- * Environment , getVar, getVarWithDefault, getVars + -- * Request information , serverName, serverPort , requestMethod, pathInfo , pathTranslated, scriptName @@ -76,6 +77,11 @@ , requestHeader -- * Program and request URI , progURI, queryURI, requestURI + -- * Content negotiation + , Acceptable, Accept + , Charset(..), ContentEncoding(..), Language(..) + , requestAccept, requestAcceptCharset, requestAcceptEncoding, requestAcceptLanguage + , negotiate -- * Content type , ContentType(..), showContentType, parseContentType -- * Cookies @@ -105,8 +111,8 @@ import Network.CGI.Cookie (Cookie(..), showCookie, newCookie, findCookie) import qualified Network.CGI.Cookie as Cookie (deleteCookie) -import Network.CGI.Header (ContentType(..), - parseContentType, showContentType) +import Network.CGI.Accept +import Network.CGI.Header import Network.CGI.Monad import Network.CGI.Protocol import Network.CGI.Compat @@ -197,9 +203,17 @@ outputError c m es = do logCGI $ show (c,m,es) setStatus c m - setHeader "Content-type" "text/html; charset=ISO-8859-1" - page <- errorPage c m es - output $ renderHtml page + let textType = ContentType "text" "plain" [("charset","ISO-8859-1")] + htmlType = ContentType "text" "html" [("charset","ISO-8859-1")] + cts <- liftM (negotiate [htmlType,textType]) requestAccept + case cts of + ct:_ | ct == textType -> + do setHeader "Content-type" (showContentType textType) + text <- errorText c m es + output text + _ -> do setHeader "Content-type" (showContentType htmlType) + page <- errorPage c m es + output $ renderHtml page -- | Create an HTML error page. errorPage :: MonadCGI m => @@ -219,6 +233,13 @@ +++ body << (h1 << tit +++ map (paragraph <<) es +++ hr +++ address << sig) +errorText :: MonadCGI m => + Int -- ^ Status code + -> String -- ^ Status message + -> [String] -- ^ Error information + -> m String +errorText c m es = return $ unlines $ (show c ++ " " ++ m) : es + -- -- * Specific HTTP errors -- @@ -269,6 +290,9 @@ m [(String,String)] getVars = liftM Map.toList $ cgiGet cgiVars +-- +-- * Request information +-- -- | The server\'s hostname, DNS alias, or IP address as it would -- appear in self-referencing URLs. @@ -366,6 +390,24 @@ requestHeader name = getVar var where var = "HTTP_" ++ map toUpper (replace '-' '_' name) +-- +-- * Content negotiation +-- + +requestHeaderValue :: (MonadCGI m, HeaderValue a) => String -> m (Maybe a) +requestHeaderValue h = liftM (>>= parseM parseHeaderValue h) $ requestHeader h + +requestAccept :: MonadCGI m => m (Maybe (Accept ContentType)) +requestAccept = requestHeaderValue "Accept" + +requestAcceptCharset :: MonadCGI m => m (Maybe (Accept Charset)) +requestAcceptCharset = requestHeaderValue "Accept-Charset" + +requestAcceptEncoding :: MonadCGI m => m (Maybe (Accept ContentEncoding)) +requestAcceptEncoding = requestHeaderValue "Accept-Encoding" + +requestAcceptLanguage :: MonadCGI m => m (Maybe (Accept Language)) +requestAcceptLanguage = requestHeaderValue "Accept-Language" -- -- * Program and request URI diff --git a/Network/CGI/Accept.hs b/Network/CGI/Accept.hs new file mode 100644 --- /dev/null +++ b/Network/CGI/Accept.hs @@ -0,0 +1,176 @@ +module Network.CGI.Accept ( + -- * Accept-X headers + Acceptable + , Accept + , Charset(..), ContentEncoding(..), Language(..) + -- * Content negotiation + , negotiate + ) where + +import Control.Monad +import Data.Char +import Data.Function +import Data.List +import Data.Maybe +import Numeric + +import Text.ParserCombinators.Parsec + +import Network.CGI.Header + + +-- +-- * Accept-X headers +-- + +newtype Accept a = Accept [(a, Quality)] + deriving (Show) + +type Quality = Double + +-- A bounded join-semilattice +class Eq a => Acceptable a where + includes :: a -> a -> Bool + top :: a + +instance HeaderValue a => HeaderValue (Accept a) where + parseHeaderValue = fmap Accept $ sepBy p (lexeme (char ',')) + where p = do a <- parseHeaderValue + q <- option 1 $ do lexeme $ char ';' + lexeme $ char 'q' + lexeme $ char '=' + lexeme pQuality + return (a,q) + pQuality = (char '0' >> option "0" (char '.' >> many digit) >>= \ds -> return (read ("0." ++ ds ++ "0"))) + <|> (char '1' >> optional (char '.' >> many (char '0')) >> return 1) + prettyHeaderValue (Accept xs) = concat $ intersperse ", " [prettyHeaderValue a ++ "; q=" ++ showQuality q | (a,q) <- xs] + where showQuality q = showFFloat (Just 3) q "" + +starOrEqualTo :: String -> String -> Bool +starOrEqualTo x y = x == "*" || x == y + + +negotiate :: Acceptable a => [a] -> Maybe (Accept a) -> [a] +negotiate ys Nothing = ys +negotiate ys (Just xs) = reverse [ z | (q,z) <- sortBy (compare `on` fst) [ (quality xs y,y) | y <- ys], q > 0] + +--testNegotiate :: (HeaderValue a, Acceptable a) => [String] -> String -> [a] +--testNegotiate ts a = negotiate [t | Just t <- map (parseM parseHeaderValue "") ts] (parseM parseHeaderValue "" a) + +quality :: Acceptable a => Accept a -> a -> Quality +quality (Accept xs) y = fromMaybe 0 $ listToMaybe $ sort $ map snd $ sortBy (compareSpecificity `on` fst) $ filter ((`includes` y) . fst) xs + +compareSpecificity :: Acceptable a => a -> a -> Ordering +compareSpecificity x y + | x `includes` y && y `includes` x = EQ + | x `includes` y = GT + | y `includes` x = LT + | otherwise = error "Non-comparable Acceptables" + +-- +-- ** Accept +-- + +instance Acceptable ContentType where + includes x y = ctType x `starOrEqualTo` ctType y + && ctSubtype x `starOrEqualTo` ctSubtype y + && all (hasParameter y) (ctParameters x) + top = ContentType "*" "*" [] + +hasParameter :: ContentType -> (String, String) -> Bool +hasParameter t (k,v) = maybe False (==v) $ lookup k (ctParameters t) + +-- +-- ** Accept-Charset +-- + +{- +RFC 2616 14.2: + +The special value "*", if present in the Accept-Charset field, matches +every character set (including ISO-8859-1) which is not mentioned +elsewhere in the Accept-Charset field. If no "*" is present in an +Accept-Charset field, then all character sets not explicitly mentioned +get a quality value of 0, except for ISO-8859-1, which gets a quality +value of 1 if not explicitly mentioned. + +If no Accept-Charset header is present, the default is that any +character set is acceptable. If an Accept-Charset header is present, +and if the server cannot send a response which is acceptable according +to the Accept-Charset header, then the server SHOULD send an error +response with the 406 (not acceptable) status code, though the sending +of an unacceptable response is also allowed. +-} + +newtype Charset = Charset String + deriving (Show) + +instance Eq Charset where + Charset x == Charset y = caseInsensitiveEq x y + +instance Ord Charset where + Charset x `compare` Charset y = caseInsensitiveCompare x y + +instance HeaderValue Charset where + parseHeaderValue = fmap Charset $ many ws1 >> lexeme p_token + prettyHeaderValue (Charset s) = s + +instance Acceptable Charset where + Charset x `includes` Charset y = starOrEqualTo x y + top = Charset "*" + +-- +-- ** Accept-Encoding +-- + +{- +RFC 2616, section 14.3 +-} + +newtype ContentEncoding = ContentEncoding String + deriving (Show) + +instance Eq ContentEncoding where + ContentEncoding x == ContentEncoding y = caseInsensitiveEq x y + +instance Ord ContentEncoding where + ContentEncoding x `compare` ContentEncoding y = caseInsensitiveCompare x y + +instance HeaderValue ContentEncoding where + parseHeaderValue = fmap ContentEncoding $ many ws1 >> lexeme p_token + prettyHeaderValue (ContentEncoding s) = s + +instance Acceptable ContentEncoding where + ContentEncoding x `includes` ContentEncoding y = starOrEqualTo x y + top = ContentEncoding "*" + +-- +-- ** Accept-Language +-- + +newtype Language = Language String + deriving (Show) + +instance Eq Language where + Language x == Language y = caseInsensitiveEq x y + +instance Ord Language where + Language x `compare` Language y = caseInsensitiveCompare x y + +instance HeaderValue Language where + parseHeaderValue = fmap Language $ many ws1 >> lexeme p_token + prettyHeaderValue (Language s) = s + +{- +RFC 2616 14.4 + +A language-range matches a language-tag if it exactly equals the tag, +or if it exactly equals a prefix of the tag such that the first tag +character following the prefix is "-". The special range "*", if +present in the Accept-Language field, matches every tag not matched by +any other range present in the Accept-Language field. +-} +instance Acceptable Language where + Language x `includes` Language y = + x == "*" || x == y || (x `isPrefixOf` y && "-" `isPrefixOf` drop (length x) y) + top = Language "*" diff --git a/Network/CGI/Header.hs b/Network/CGI/Header.hs --- a/Network/CGI/Header.hs +++ b/Network/CGI/Header.hs @@ -17,45 +17,66 @@ ----------------------------------------------------------------------------- module Network.CGI.Header ( -- * Headers - Header, - pHeader, + Headers, + HeaderName(..), + HeaderValue(..), pHeaders, - parseHeaders, -- * Content-type ContentType(..), getContentType, parseContentType, - pContentType, showContentType, -- * Content-transfer-encoding ContentTransferEncoding(..), getContentTransferEncoding, - parseContentTransferEncoding, -- * Content-disposition ContentDisposition(..), getContentDisposition, - parseContentDisposition, - showContentDisposition, -- * Utilities - parseM) where + parseM, + caseInsensitiveEq, + caseInsensitiveCompare, + lexeme, ws1, p_token + ) where +import Control.Monad import Data.Char +import Data.Function import Data.List +import Data.Maybe +import Data.Monoid + import Text.ParserCombinators.Parsec -type Header = (String, String) +-- +-- * Headers +-- -pHeaders :: Parser [Header] -pHeaders = many pHeader +-- | HTTP headers. +type Headers = [(HeaderName, String)] -parseHeaders :: Monad m => SourceName -> String -> m [Header] -parseHeaders s inp = parseM pHeaders s inp +-- | A string with case insensitive equality and comparisons. +newtype HeaderName = HeaderName String deriving (Show) -pHeader :: Parser Header +instance Eq HeaderName where + HeaderName x == HeaderName y = map toLower x == map toLower y + +instance Ord HeaderName where + HeaderName x `compare` HeaderName y = map toLower x `compare` map toLower y + + +class HeaderValue a where + parseHeaderValue :: Parser a + prettyHeaderValue :: a -> String + +pHeaders :: Parser Headers +pHeaders = many pHeader + +pHeader :: Parser (HeaderName, String) pHeader = do name <- many1 headerNameChar char ':' @@ -63,7 +84,7 @@ line <- lineString crLf extraLines <- many extraFieldLine - return (map toLower name, concat (line:extraLines)) + return (HeaderName name, concat (line:extraLines)) extraFieldLine :: Parser String extraFieldLine = @@ -72,6 +93,9 @@ crLf return (sp:line) +getHeaderValue :: (Monad m, HeaderValue a) => String -> Headers -> m a +getHeaderValue h hs = lookupM (HeaderName h) hs >>= parseM parseHeaderValue h + -- -- * Parameters (for Content-type etc.) -- @@ -85,9 +109,20 @@ | otherwise = [c] p_parameter :: Parser (String,String) -p_parameter = +p_parameter = try $ do lexeme $ char ';' p_name <- lexeme $ p_token + -- Don't allow parameters named q. This is needed for parsing Accept-X + -- headers. From RFC 2616 14.1: + -- Note: Use of the "q" parameter name to separate media type + -- parameters from Accept extension parameters is due to historical + -- practice. Although this prevents any media type parameter named + -- "q" from being used with a media range, such an event is believed + -- to be unlikely given the lack of any "q" parameters in the IANA + -- media type registry and the rare usage of any media type + -- parameters in Accept. Future media types are discouraged from + -- registering any parameter named "q". + when (p_name == "q") pzero lexeme $ char '=' -- Workaround for seemingly standardized web browser bug -- where nothing is escaped in the filename parameter @@ -98,7 +133,6 @@ p_value <- litStr <|> p_token return (map toLower p_name, p_value) - -- -- * Content type -- @@ -125,31 +159,41 @@ -- top-level type, e.g. @(\"charset\",\"ISO-8859-1\")@. ctParameters :: [(String, String)] } - deriving (Show, Read, Eq, Ord) + deriving (Show, Read) --- | Produce the standard string representation of a content-type, --- e.g. \"text\/html; charset=ISO-8859-1\". -showContentType :: ContentType -> String -showContentType (ContentType x y ps) = x ++ "/" ++ y ++ showParameters ps +instance Eq ContentType where + x == y = ctType x `caseInsensitiveEq` ctType y + && ctSubtype x `caseInsensitiveEq` ctSubtype y + && ctParameters x == ctParameters y -pContentType :: Parser ContentType -pContentType = - do many ws1 - c_type <- p_token - lexeme $ char '/' - c_subtype <- lexeme $ p_token - c_parameters <- many p_parameter - return $ ContentType (map toLower c_type) (map toLower c_subtype) c_parameters +instance Ord ContentType where + x `compare` y = mconcat [ctType x `caseInsensitiveCompare` ctType y, + ctSubtype x `caseInsensitiveCompare` ctSubtype y, + ctParameters x `compare` ctParameters y] +instance HeaderValue ContentType where + parseHeaderValue = + do many ws1 + c_type <- p_token + char '/' + c_subtype <- lexeme $ p_token + c_parameters <- many p_parameter + return $ ContentType (map toLower c_type) (map toLower c_subtype) c_parameters + prettyHeaderValue (ContentType x y ps) = x ++ "/" ++ y ++ showParameters ps + + -- | Parse the standard representation of a content-type. -- If the input cannot be parsed, this function calls -- 'fail' with a (hopefully) informative error message. parseContentType :: Monad m => String -> m ContentType -parseContentType = parseM pContentType "Content-type" +parseContentType = parseM parseHeaderValue "Content-type" -getContentType :: Monad m => [Header] -> m ContentType -getContentType hs = lookupM "content-type" hs >>= parseContentType +showContentType :: ContentType -> String +showContentType = prettyHeaderValue +getContentType :: Monad m => Headers -> m ContentType +getContentType = getHeaderValue "content-type" + -- -- * Content transfer encoding -- @@ -158,19 +202,15 @@ ContentTransferEncoding String deriving (Show, Read, Eq, Ord) -pContentTransferEncoding :: Parser ContentTransferEncoding -pContentTransferEncoding = - do many ws1 - c_cte <- p_token - return $ ContentTransferEncoding (map toLower c_cte) - -parseContentTransferEncoding :: Monad m => String -> m ContentTransferEncoding -parseContentTransferEncoding = - parseM pContentTransferEncoding "Content-transfer-encoding" +instance HeaderValue ContentTransferEncoding where + parseHeaderValue = + do many ws1 + c_cte <- p_token + return $ ContentTransferEncoding (map toLower c_cte) + prettyHeaderValue (ContentTransferEncoding s) = s -getContentTransferEncoding :: Monad m => [Header] -> m ContentTransferEncoding -getContentTransferEncoding hs = - lookupM "content-transfer-encoding" hs >>= parseContentTransferEncoding +getContentTransferEncoding :: Monad m => Headers -> m ContentTransferEncoding +getContentTransferEncoding = getHeaderValue "content-transfer-encoding" -- -- * Content disposition @@ -180,24 +220,18 @@ ContentDisposition String [(String, String)] deriving (Show, Read, Eq, Ord) -pContentDisposition :: Parser ContentDisposition -pContentDisposition = - do many ws1 - c_cd <- p_token - c_parameters <- many p_parameter - return $ ContentDisposition (map toLower c_cd) c_parameters - -parseContentDisposition :: Monad m => String -> m ContentDisposition -parseContentDisposition = parseM pContentDisposition "Content-disposition" - -getContentDisposition :: Monad m => [Header] -> m ContentDisposition -getContentDisposition hs = - lookupM "content-disposition" hs >>= parseContentDisposition +instance HeaderValue ContentDisposition where + parseHeaderValue = + do many ws1 + c_cd <- p_token + c_parameters <- many p_parameter + return $ ContentDisposition (map toLower c_cd) c_parameters + prettyHeaderValue (ContentDisposition t hs) = + t ++ concat ["; " ++ n ++ "=" ++ quote v | (n,v) <- hs] + where quote x = "\"" ++ x ++ "\"" -- NOTE: silly, but de-facto standard -showContentDisposition :: ContentDisposition -> String -showContentDisposition (ContentDisposition t hs) = - t ++ concat ["; " ++ n ++ "=" ++ quote v | (n,v) <- hs] - where quote x = "\"" ++ x ++ "\"" -- NOTE: silly, but de-facto standard +getContentDisposition :: Monad m => Headers -> m ContentDisposition +getContentDisposition = getHeaderValue "content-disposition" -- -- * Utilities @@ -211,6 +245,12 @@ lookupM :: (Monad m, Eq a, Show a) => a -> [(a,b)] -> m b lookupM n = maybe (fail ("No such field: " ++ show n)) return . lookup n + +caseInsensitiveEq :: String -> String -> Bool +caseInsensitiveEq x y = map toLower x == map toLower y + +caseInsensitiveCompare :: String -> String -> Ordering +caseInsensitiveCompare x y = map toLower x `compare` map toLower y -- -- * Parsing utilities diff --git a/Network/CGI/Multipart.hs b/Network/CGI/Multipart.hs --- a/Network/CGI/Multipart.hs +++ b/Network/CGI/Multipart.hs @@ -18,15 +18,13 @@ module Network.CGI.Multipart ( -- * Multi-part messages - MultiPart(..), BodyPart(..), Header + MultiPart(..), BodyPart(..) , parseMultipartBody, hGetMultipartBody , showMultipartBody -- * Headers , ContentType(..), ContentTransferEncoding(..) , ContentDisposition(..) , parseContentType - , parseContentTransferEncoding - , parseContentDisposition , getContentType , getContentTransferEncoding , getContentDisposition @@ -48,10 +46,10 @@ -- data MultiPart = MultiPart [BodyPart] - deriving (Show, Read, Eq, Ord) + deriving (Show, Eq, Ord) -data BodyPart = BodyPart [Header] ByteString - deriving (Show, Read, Eq, Ord) +data BodyPart = BodyPart Headers ByteString + deriving (Show, Eq, Ord) -- | Read a multi-part message from a 'ByteString'. parseMultipartBody :: String -- ^ Boundary @@ -83,7 +81,7 @@ showBodyPart :: BodyPart -> ByteString showBodyPart (BodyPart hs c) = - unlinesCRLF $ [BS.pack (n++": "++v) | (n,v) <- hs] ++ [BS.empty,c] + unlinesCRLF $ [BS.pack (n++": "++v) | (HeaderName n,v) <- hs] ++ [BS.empty,c] -- diff --git a/Network/CGI/Protocol.hs b/Network/CGI/Protocol.hs --- a/Network/CGI/Protocol.hs +++ b/Network/CGI/Protocol.hs @@ -33,7 +33,6 @@ ) where import Control.Monad.Trans (MonadIO(..)) -import Data.Char (toLower) import Data.List (intersperse) import qualified Data.Map as Map import Data.Map (Map) @@ -47,6 +46,7 @@ import Data.Typeable (Typeable(..), mkTyConApp, mkTyCon) +import Network.CGI.Header import Network.CGI.Multipart @@ -91,19 +91,6 @@ data CGIResult = CGIOutput ByteString | CGINothing deriving (Show, Read, Eq, Ord) - -type Headers = [(HeaderName, String)] - --- | A string with case insensitive equality and comparisons. -newtype HeaderName = HeaderName String deriving (Show) - -instance Eq HeaderName where - HeaderName x == HeaderName y = map toLower x == map toLower y - -instance Ord HeaderName where - HeaderName x `compare` HeaderName y = map toLower x `compare` map toLower y - - -- -- * Running CGI actions diff --git a/cgi.cabal b/cgi.cabal --- a/cgi.cabal +++ b/cgi.cabal @@ -1,5 +1,5 @@ Name: cgi -Version: 3001.1.6.0 +Version: 3001.1.7.0 Copyright: Bjorn Bringert, Andy Gill, Ian Lynagh, Erik Meijer, Sven Panne, Jeremy Shaw Maintainer: bjorn@bringert.net @@ -23,6 +23,7 @@ Network.CGI.Cookie, Network.CGI.Compat Other-modules: + Network.CGI.Accept, Network.CGI.Multipart, Network.CGI.Header Extensions: MultiParamTypeClasses