diff --git a/Network/CGI.hs b/Network/CGI.hs --- a/Network/CGI.hs +++ b/Network/CGI.hs @@ -92,7 +92,8 @@ import Data.List (intersperse, sort, group) import Data.Maybe (fromMaybe) import qualified Data.Map as Map -import Network.URI (URI(..), URIAuth(..), nullURI, parseRelativeReference) +import Network.URI (URI(..), URIAuth(..), nullURI, parseRelativeReference, + escapeURIString, isUnescapedInURI) import System.IO (stdin, stdout) import System.IO.Error (isUserError, ioeGetErrorString) @@ -284,22 +285,36 @@ -- CGI program path. -- If the string returned by this function is not empty, -- it is guaranteed to start with a @\'\/\'@. +-- +-- Note that this function returns an unencoded string. +-- Make sure to percent-encode any characters +-- that are not allowed in URI paths before using the result of +-- this function to construct a URI. +-- See 'progURI', 'queryURI' and 'requestURI' for a higher-level +-- interface. pathInfo :: MonadCGI m => m String pathInfo = liftM slash $ getVarWithDefault "PATH_INFO" "" where slash s = if not (null s) && head s /= '/' then '/':s else s --- | The path returned by 'pathInfo', but with any virtual-to-physical +-- | The path returned by 'pathInfo', but with virtual-to-physical -- mapping applied to it. pathTranslated :: MonadCGI m => m String pathTranslated = getVarWithDefault "PATH_TRANSLATED" "" --- | A virtual path to the script being executed, --- used for self-referencing URLs. +-- | A virtual path to the script being executed, +-- used for self-referencing URIs. +-- +-- Note that this function returns an unencoded string. +-- Make sure to percent-encode any characters +-- that are not allowed in URI paths before using the result of +-- this function to construct a URI. +-- See 'progURI', 'queryURI' and 'requestURI' for a higher-level +-- interface. scriptName :: MonadCGI m => m String scriptName = getVarWithDefault "SCRIPT_NAME" "" -- | The information which follows the ? in the URL which referenced --- this program. This is the encoded query information. +-- this program. This is the percent-encoded query information. -- For most normal uses, 'getInput' and friends are probably -- more convenient. queryString :: MonadCGI m => m String @@ -359,6 +374,9 @@ -- If the server is rewriting request URIs, this URI can -- be different from the one requested by the client. -- See also 'requestURI'. +-- +-- Characters in the components of the returned URI are escaped +-- when needed, as required by "Network.URI". progURI :: MonadCGI m => m URI progURI = do -- Use HTTP_HOST if available, otherwise SERVER_NAME @@ -384,29 +402,42 @@ uriPort = port } return $ nullURI { uriScheme = if https then "https:" else "http:", uriAuthority = Just auth, - uriPath = name } + uriPath = escapePath name } -- | Like 'progURI', but the returned 'URI' also includes -- any extra path information, and any query parameters. -- If the server is rewriting request URIs, this URI can -- be different from the one requested by the client. -- See also 'requestURI'. +-- +-- Characters in the components of the returned URI are escaped +-- when needed, as required by "Network.URI". queryURI :: MonadCGI m => m URI queryURI = do uri <- progURI path <- pathInfo qs <- liftM (\q -> if null q then q else '?':q) $ queryString - return $ uri { uriPath = uriPath uri ++ path, uriQuery = qs } + return $ uri { uriPath = uriPath uri ++ escapePath path, + uriQuery = qs } +-- | Does percent-encoding as needed for URI path components. +escapePath :: String -> String +escapePath = escapeURIString isUnescapedInURIPath + where isUnescapedInURIPath c = isUnescapedInURI c && c `notElem` "?#" + -- | Attempts to reconstruct the absolute URI requested by the client, -- including extra path information and query parameters. -- If no request URI rewriting is done, or if the web server does not -- provide the information needed to reconstruct the request URI, -- this function returns the same value as 'queryURI'. +-- +-- Characters in the components of the returned URI are escaped +-- when needed, as required by "Network.URI". requestURI :: MonadCGI m => m URI requestURI = do uri <- queryURI - -- Apache sets REQUEST_URI to the original request URI + -- Apache sets REQUEST_URI to the original request URI, + -- with percent-encoding intact. mreq <- liftM (>>= parseRelativeReference) $ getVar "REQUEST_URI" return $ case mreq of Nothing -> uri diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,58 +1,4 @@ - -module Main (main) where +#!/usr/bin/env runghc -import Data.List import Distribution.Simple -import Distribution.PackageDescription -import Distribution.Setup -import Distribution.Simple.LocalBuildInfo -import System.Environment - -main :: IO () -main = do args <- getArgs - let (ghcArgs, args') = extractGhcArgs args - (_, args'') = extractConfigureArgs args' - hooks = defaultUserHooks { - buildHook = add_ghc_options ghcArgs - $ buildHook defaultUserHooks } - withArgs args'' $ defaultMainWithHooks hooks - -extractGhcArgs :: [String] -> ([String], [String]) -extractGhcArgs = extractPrefixArgs "--ghc-option=" - -extractConfigureArgs :: [String] -> ([String], [String]) -extractConfigureArgs = extractPrefixArgs "--configure-option=" - -extractPrefixArgs :: String -> [String] -> ([String], [String]) -extractPrefixArgs the_prefix args - = let f [] = ([], []) - f (x:xs) = case f xs of - (wantedArgs, otherArgs) -> - case removePrefix the_prefix x of - Just wantedArg -> - (wantedArg:wantedArgs, otherArgs) - Nothing -> - (wantedArgs, x:otherArgs) - in f args - -removePrefix :: String -> String -> Maybe String -removePrefix "" ys = Just ys -removePrefix _ "" = Nothing -removePrefix (x:xs) (y:ys) - | x == y = removePrefix xs ys - | otherwise = Nothing - -type Hook a = PackageDescription -> LocalBuildInfo -> UserHooks -> a -> IO () - -add_ghc_options :: [String] -> Hook a -> Hook a -add_ghc_options args f pd lbi uhs x - = do let lib' = case library pd of - Just lib -> - let bi = libBuildInfo lib - opts = options bi ++ [(GHC, args)] - bi' = bi { options = opts } - in lib { libBuildInfo = bi' } - Nothing -> error "Expected a library" - pd' = pd { library = Just lib' } - f pd' lbi uhs x - +main = defaultMain diff --git a/cgi.cabal b/cgi.cabal --- a/cgi.cabal +++ b/cgi.cabal @@ -1,12 +1,12 @@ Name: cgi -Version: 3001.1.3 +Version: 3001.1.4 Copyright: Bjorn Bringert, Andy Gill, Ian Lynagh, Erik Meijer, Sven Panne, Jeremy Shaw Maintainer: bjorn@bringert.net Author: Bjorn Bringert License: BSD3 License-file: LICENSE -Build-depends: base >= 2.0, network>=2.0, parsec >= 2.0, mtl >= 1.0, xhtml >= 3000.0.0 +Build-depends: base >= 2.0, network>=2.0, parsec >= 2.0, mtl >= 1.0, xhtml >= 3000.0.0 Extensions: MultiParamTypeClasses Synopsis: A library for writing CGI programs Description: