[Initial darcs import.
bringert@cs.chalmers.se**20060828154609] {
adddir ./examples
addfile ./CGILight.hs
addfile ./hello.hs
move ./hello.hs ./examples/hello.hs
hunk ./CGILight.hs 1
+{- |
+ Module : CGILight
+ Copyright : (c) The University of Glasgow 2001
+ (c) Peter Thiemann 2001,2002
+ (c) Bjorn Bringert 2004-2006
+ License : BSD-style
+
+ Maintainer : bjorn@bringert.net
+ Stability : experimental
+ Portability : portable
+
+
+ This is a simple CGI library for teaching purposes.
+ It does not support file uploads, custom error handling
+ ByteString output.
+ Use the cgi package when you need any of those.
+
+ A simple example:
+
+@
+import CGILight
+
+cgiMain :: Environment -> Inputs -> IO (Headers,String)
+cgiMain env input = return (hs, output)
+ where
+ hs = [("Content-type","text/html")]
+ output = "Hello World!
"
+
+main :: IO ()
+main = runCGI cgiMain
+@
+
+ This module may include code by
+ Erik Meijer ,
+ Sven Panne ,
+ Andy Gill ,
+ and Peter Thiemann.
+
+-}
+module CGILight (
+ -- * Types
+ Environment, Inputs, Headers,
+ -- * Running CGI programs
+ runCGI,
+ -- * URL encoding
+ formEncode, urlEncode, formDecode, urlDecode,
+ ) where
+
+import Data.Char
+import Data.List
+import Data.Maybe
+import Network.URI
+import System.Environment
+import System.IO
+import Text.ParserCombinators.Parsec
+
+
+type Environment = [(String,String)]
+type Inputs = [(String,String)]
+
+type Header = (String, String)
+type Headers = [Header]
+
+runCGI :: (Environment -> Inputs -> IO (Headers,String)) -> IO ()
+runCGI f =
+ do env <- getCgiVars
+ input <- hGetContents stdin
+ let inputs = decodeInput env input
+ (hs,output) <- f env inputs
+ mapM_ (hPutStrLn stdout . formatHeader) hs
+ hPutStrLn stdout ""
+ hPutStrLn stdout output
+ hFlush stdout
+ where formatHeader (n,v) = n ++ ": " ++ v
+
+
+
+-- This ought to be getEnvironment, but olders versions
+-- of System.Environment don't have that.
+getCgiVars :: IO [(String,String)]
+getCgiVars = do vals <- mapM myGetEnv cgiVarNames
+ return (zip cgiVarNames vals)
+
+myGetEnv :: String -> IO String
+myGetEnv v = Prelude.catch (getEnv v) (const (return ""))
+
+cgiVarNames :: [String]
+cgiVarNames =
+ [ "DOCUMENT_ROOT"
+ , "AUTH_TYPE"
+ , "GATEWAY_INTERFACE"
+ , "SERVER_SOFTWARE"
+ , "SERVER_NAME"
+ , "REQUEST_METHOD"
+ , "SERVER_ADMIN"
+ , "SERVER_PORT"
+ , "QUERY_STRING"
+ , "CONTENT_LENGTH"
+ , "CONTENT_TYPE"
+ , "REMOTE_USER"
+ , "REMOTE_IDENT"
+ , "REMOTE_ADDR"
+ , "REMOTE_HOST"
+ , "TZ"
+ , "PATH"
+ , "PATH_INFO"
+ , "PATH_TRANSLATED"
+ , "SCRIPT_NAME"
+ , "SCRIPT_FILENAME"
+ , "HTTP_CONNECTION"
+ , "HTTP_ACCEPT_LANGUAGE"
+ , "HTTP_ACCEPT"
+ , "HTTP_HOST"
+ , "HTTP_UA_COLOR"
+ , "HTTP_UA_CPU"
+ , "HTTP_UA_OS"
+ , "HTTP_UA_PIXELS"
+ , "HTTP_USER_AGENT"
+ ]
+
+
+
+
+
+
+
+--
+-- * Inputs
+--
+
+-- | Get and decode the input according to the request
+-- method and the content-type.
+decodeInput :: [(String,String)] -- ^ CGI environment variables.
+ -> String -- ^ Request body.
+ -> Inputs -- ^ Input variables and values.
+decodeInput env inp = queryInput env ++ bodyInput env inp
+
+
+--
+-- * Query string
+--
+
+-- | Get inputs from the query string.
+queryInput :: [(String,String)] -- ^ CGI environment variables.
+ -> Inputs -- ^ Input variables and values.
+queryInput env = formInput $ lookupOrNil "QUERY_STRING" env
+
+-- | Decode application\/x-www-form-urlencoded inputs.
+formInput :: String
+ -> Inputs -- ^ Input variables and values.
+formInput qs = [(n, v) | (n,v) <- formDecode qs]
+
+
+--
+-- * URL encoding
+--
+
+-- | Format name-value pairs as application\/x-www-form-urlencoded.
+formEncode :: [(String,String)] -> String
+formEncode xs =
+ concat $ intersperse "&" [urlEncode n ++ "=" ++ urlEncode v | (n,v) <- xs]
+
+-- | Convert a single value to the application\/x-www-form-urlencoded encoding.
+urlEncode :: String -> String
+urlEncode = replace ' ' '+' . escapeURIString okChar
+ where okChar c = c == ' ' ||
+ (isUnescapedInURI c && c `notElem` "&=+")
+
+-- | Get the name-value pairs from application\/x-www-form-urlencoded data.
+formDecode :: String -> [(String,String)]
+formDecode "" = []
+formDecode s = (urlDecode n, urlDecode (drop 1 v)) : formDecode (drop 1 rs)
+ where (nv,rs) = break (=='&') s
+ (n,v) = break (=='=') nv
+
+-- | Convert a single value from the
+-- application\/x-www-form-urlencoded encoding.
+urlDecode :: String -> String
+urlDecode = unEscapeString . replace '+' ' '
+
+
+
+--
+-- * Request content
+--
+
+-- | Get input variables from the body, if any.
+bodyInput :: [(String,String)] -- ^ CGI environment variables.
+ -> String -- ^ Request body.
+ -> Inputs -- ^ Input variables and values.
+bodyInput env inp =
+ case lookup "REQUEST_METHOD" env of
+ Just "POST" ->
+ let ctype = lookup "CONTENT_TYPE" env >>= parseContentType
+ in decodeBody ctype $ takeInput env inp
+ _ -> []
+
+-- | Decode a POST body.
+decodeBody :: Maybe ContentType -- ^ Content-type, if any
+ -> String -- ^ Request body
+ -> Inputs -- ^ Input variables and values.
+decodeBody ctype inp =
+ case ctype of
+ Just (ContentType "application" "x-www-form-urlencoded" _)
+ -> formInput inp
+ Just _ -> [] -- unknown content-type, the user will have to
+ -- deal with it by looking at the raw content
+ -- No content-type given, assume x-www-form-urlencoded
+ Nothing -> formInput inp
+
+-- | Take the right number of bytes from the input.
+takeInput :: [(String,String)] -- ^ CGI environment variables.
+ -> String -- ^ Request body.
+ -> String -- ^ CONTENT_LENGTH bytes from the request
+ -- body, or the empty string if there is no
+ -- CONTENT_LENGTH.
+takeInput env req =
+ case len of
+ Just l -> take l req
+ Nothing -> ""
+ where len = lookup "CONTENT_LENGTH" env >>= maybeRead
+
+
+
+--
+-- * Utilities
+--
+
+-- | Replace all instances of a value in a list by another value.
+replace :: Eq a =>
+ a -- ^ Value to look for
+ -> a -- ^ Value to replace it with
+ -> [a] -- ^ Input list
+ -> [a] -- ^ Output list
+replace x y = map (\z -> if z == x then y else z)
+
+maybeRead :: Read a => String -> Maybe a
+maybeRead = fmap fst . listToMaybe . reads
+
+-- | Same as 'lookup' specialized to strings, but
+-- returns the empty string if lookup fails.
+lookupOrNil :: String -> [(String,String)] -> String
+lookupOrNil n = fromMaybe "" . lookup n
+
+
+
+
+--
+-- * Parameters (for Content-type etc.)
+--
+
+p_parameter :: Parser (String,String)
+p_parameter =
+ do lexeme $ char ';'
+ p_name <- lexeme $ p_token
+ lexeme $ char '='
+ -- Workaround for seemingly standardized web browser bug
+ -- where nothing is escaped in the filename parameter
+ -- of the content-disposition header in multipart/form-data
+ let litStr = if p_name == "filename"
+ then buggyLiteralString
+ else literalString
+ p_value <- litStr <|> p_token
+ return (map toLower p_name, p_value)
+
+--
+-- * Content type
+--
+
+data ContentType =
+ ContentType String String [(String, String)]
+ deriving (Show, Read, Eq, Ord)
+
+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
+
+parseContentType :: Monad m => String -> m ContentType
+parseContentType = parseM pContentType "Content-type"
+
+--
+-- * Utilities
+--
+
+parseM :: Monad m => Parser a -> SourceName -> String -> m a
+parseM p n inp =
+ case parse p n inp of
+ Left e -> fail (show e)
+ Right x -> return x
+
+--
+-- * Parsing utilities
+--
+
+-- | RFC 822 LWSP-char
+ws1 :: Parser Char
+ws1 = oneOf " \t"
+
+lexeme :: Parser a -> Parser a
+lexeme p = do x <- p; many ws1; return x
+
+literalString :: Parser String
+literalString = do char '\"'
+ str <- many (noneOf "\"\\" <|> quoted_pair)
+ char '\"'
+ return str
+
+-- No web browsers seem to implement RFC 2046 correctly,
+-- since they do not escape double quotes and backslashes
+-- in the filename parameter in multipart/form-data.
+--
+-- Note that this eats everything until the last double quote on the line.
+buggyLiteralString :: Parser String
+buggyLiteralString =
+ do char '\"'
+ str <- manyTill anyChar (try lastQuote)
+ return str
+ where lastQuote = do char '\"'
+ notFollowedBy (try (many (noneOf "\"") >> char '\"'))
+
+especials, tokenchar :: [Char]
+especials = "()<>@,;:\\\"/[]?.="
+tokenchar = "!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~" \\ especials
+
+p_token :: Parser String
+p_token = many1 (oneOf tokenchar)
+
+text_chars :: [Char]
+text_chars = map chr ([1..9] ++ [11,12] ++ [14..127])
+
+p_text :: Parser Char
+p_text = oneOf text_chars
+
+quoted_pair :: Parser Char
+quoted_pair = do char '\\'
+ p_text
hunk ./examples/hello.hs 1
+#!/usr/bin/env runhugs
+
+import CGILight
+
+cgiMain :: Environment -> Inputs -> IO (Headers,String)
+cgiMain env input = return (hs, output)
+ where
+ hs = [("Content-type","text/html")]
+ output = "Hello World!
"
+
+main :: IO ()
+main = runCGI cgiMain
}