cgi 3001.1.6.0 → 3001.1.7.0

raw patch · 6 files changed

+333/−89 lines, 6 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Network/CGI.hs +47/−5
• Network/CGI/Accept.hs +176/−0
• Network/CGI/Header.hs +102/−62
• Network/CGI/Multipart.hs +5/−7
• Network/CGI/Protocol.hs +1/−14
• cgi.cabal +2/−1

@@ -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

@@ -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 "<source>") ts] (parseM parseHeaderValue "<source>" 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 "*"

@@ -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

@@ -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]   --

@@ -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

@@ -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