cgi 3001.1.0 → 3001.1.3

raw patch · 5 files changed

+84/−15 lines, 5 filessetup-changed

Files

• Network/CGI.hs +20/−7
• Network/CGI/Multipart.hs +3/−2
• Network/CGI/Protocol.hs +6/−3
• Setup.hs +54/−2
• cgi.cabal +1/−1

@@ -361,15 +361,28 @@ --   See also 'requestURI'. progURI :: MonadCGI m => m URI progURI =-    do host <- serverName-       port <- serverPort+    do -- Use HTTP_HOST if available, otherwise SERVER_NAME+       h <- requestHeader "Host" >>= maybe serverName return+       p <- serverPort        name <- scriptName-       let scheme = if port == 443 then "https:" else "http:"-           auth = URIAuth { uriUserInfo = "",+       https <- liftM (maybe False (const True)) (getVar "HTTPS")+       -- SERVER_PORT might not be the port that the client used+       -- if the server listens on multiple ports, so we give priority+       -- to the port in HTTP_HOST.+       -- HTTP_HOST should include the port according to RFC2616 sec 14.23+       -- Some servers (e.g. lighttpd) also seem to include the port in +       -- SERVER_NAME. +       -- We include the port if it is in HTTP_HOST or SERVER_NAME, or if+       -- it is a non-standard port.+       let (host,port) = case break (==':') h of+                           (_,"")  -> (h, if (not https && p == 80) +                                            || (https && p == 443) +                                           then "" else ':':show p)+                           (h',p') -> (h',p')+       let auth = URIAuth { uriUserInfo = "",                              uriRegName = host,-                            uriPort = if port == 80 || port == 443 -                                       then "" else ":"++show port }-       return $ nullURI { uriScheme = scheme, +                            uriPort = port }+       return $ nullURI { uriScheme = if https then "https:" else "http:",                            uriAuthority = Just auth,                           uriPath = name } 

@@ -186,7 +186,7 @@ findCRLF s =      case findCRorLF s of               Nothing -> Nothing-              Just j | j == BS.length s - 1 -> Just (j,1)+              Just j | BS.null (BS.drop (j+1) s) -> Just (j,1)               Just j -> case (BS.index s j, BS.index s (j+1)) of                            ('\n','\r') -> Just (j,2)                            ('\r','\n') -> Just (j,2)@@ -203,7 +203,8 @@ --   nothing is done. If the string does not start with CRLF, --   the first character is dropped. dropCRLF :: ByteString -> ByteString-dropCRLF s | BS.length s <= 1 = BS.drop 1 s+dropCRLF s | BS.null s = BS.empty+           | BS.null (BS.drop 1 s) = BS.empty            | c0 == '\n' && c1 == '\r' = BS.drop 2 s            | c0 == '\r' && c1 == '\n' = BS.drop 2 s            | otherwise = BS.drop 1 s

@@ -108,8 +108,8 @@ -- | Runs a CGI action in a given environment. Uses Handles for input and output.  hRunCGI :: MonadIO m =>            [(String,String)] -- ^ CGI environment variables, e.g. from 'getCGIVars'.-        -> Handle -- ^ Handle that input will be read from, e.g. 'stdin'.-        -> Handle -- ^ Handle that output will be written to, e.g. 'stdout'.+        -> Handle -- ^ Handle that input will be read from, e.g. 'System.IO.stdin'.+        -> Handle -- ^ Handle that output will be written to, e.g. 'System.IO.stdout'.         -> (CGIRequest -> m (Headers, CGIResult)) -- ^ CGI action         -> m () hRunCGI env hin hout f = @@ -140,8 +140,11 @@  formatResponse :: ByteString -> Headers -> ByteString formatResponse c hs = -    BS.unlines ([BS.pack (n++": "++v) | (HeaderName n,v) <- hs] +    -- NOTE: we use CRLF since lighttpd mod_fastcgi can't handle+    -- just LF if there are CRs in the content.+    unlinesCrLf ([BS.pack (n++": "++v) | (HeaderName n,v) <- hs]                  ++ [BS.empty,c])+  where unlinesCrLf = BS.concat . intersperse (BS.pack "\r\n")  defaultContentType :: String defaultContentType = "text/html; charset=ISO-8859-1"

@@ -1,6 +1,58 @@+ module Main (main) where -import Distribution.Simple (defaultMainWithHooks, defaultUserHooks)+import Data.List+import Distribution.Simple+import Distribution.PackageDescription+import Distribution.Setup+import Distribution.Simple.LocalBuildInfo+import System.Environment  main :: IO ()-main = defaultMainWithHooks defaultUserHooks+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+

@@ -1,5 +1,5 @@ Name: cgi-Version: 3001.1.0+Version: 3001.1.3 Copyright: Bjorn Bringert, Andy Gill, Ian Lynagh, Erik Meijer,             Sven Panne, Jeremy Shaw Maintainer: bjorn@bringert.net