← Back to branch summary

~ubuntu-branches/ubuntu/precise/haskell-wai-extra/precise

« back to all changes in this revision

Viewing changes to Network/Wai/Handler/CGI.hs

  • Committer: Bazaar Package Importer
  • Author(s): Clint Adams
  • Date: 2011-06-01 23:22:01 UTC
  • Revision ID: james.westby@ubuntu.com-20110601232201-y6ygzozvhbcjdaoq
Tags: upstream-0.2.4.2
Import upstream version 0.2.4.2

Show diffs side-by-side

added added

removed removed

Lines of Context:
Network/Wai/Handler/CGI.hs
 
1
{-# LANGUAGE OverloadedStrings #-}
 
2
module Network.Wai.Handler.CGI
 
3
    ( run
 
4
    , run'
 
5
    , run''
 
6
    , runSendfile
 
7
    ) where
 
8
 
 
9
import Network.Wai
 
10
import Network.Wai.Enumerator (fromResponseBody)
 
11
import Network.Wai.Handler.Helper
 
12
import System.Environment (getEnvironment)
 
13
import Data.Maybe (fromMaybe)
 
14
import qualified Data.ByteString.Char8 as B
 
15
import Control.Arrow ((***))
 
16
import Data.Char (toLower)
 
17
import qualified System.IO
 
18
import Data.String (fromString)
 
19
 
 
20
safeRead :: Read a => a -> String -> a
 
21
safeRead d s =
 
22
  case reads s of
 
23
    ((x, _):_) -> x
 
24
    [] -> d
 
25
 
 
26
lookup' :: String -> [(String, String)] -> String
 
27
lookup' key pairs = fromMaybe "" $ lookup key pairs
 
28
 
 
29
run :: Application -> IO ()
 
30
run app = do
 
31
    vars <- getEnvironment
 
32
    let input = requestBodyHandle System.IO.stdin
 
33
        output = B.hPut System.IO.stdout
 
34
    run'' vars input output Nothing app
 
35
 
 
36
runSendfile :: String -- ^ sendfile header
 
37
            -> Application -> IO ()
 
38
runSendfile sf app = do
 
39
    vars <- getEnvironment
 
40
    let input = requestBodyHandle System.IO.stdin
 
41
        output = B.hPut System.IO.stdout
 
42
    run'' vars input output (Just sf) app
 
43
 
 
44
run' :: [(String, String)] -- ^ all variables
 
45
     -> System.IO.Handle -- ^ responseBody of input
 
46
     -> System.IO.Handle -- ^ destination for output
 
47
     -> Application
 
48
     -> IO ()
 
49
run' vars inputH outputH app = do
 
50
    let input = requestBodyHandle inputH
 
51
        output = B.hPut outputH
 
52
    run'' vars input output Nothing app
 
53
 
 
54
run'' :: [(String, String)] -- ^ all variables
 
55
     -> (Int -> Source) -- ^ responseBody of input
 
56
     -> (B.ByteString -> IO ()) -- ^ destination for output
 
57
     -> Maybe String -- ^ does the server support the X-Sendfile header?
 
58
     -> Application
 
59
     -> IO ()
 
60
run'' vars inputH outputH xsendfile app = do
 
61
    let rmethod = B.pack $ lookup' "REQUEST_METHOD" vars
 
62
        pinfo = lookup' "PATH_INFO" vars
 
63
        qstring = lookup' "QUERY_STRING" vars
 
64
        servername = lookup' "SERVER_NAME" vars
 
65
        serverport = safeRead 80 $ lookup' "SERVER_PORT" vars
 
66
        contentLength = safeRead 0 $ lookup' "CONTENT_LENGTH" vars
 
67
        remoteHost' =
 
68
            case lookup "REMOTE_HOST" vars of
 
69
                Just x -> x
 
70
                Nothing ->
 
71
                    case lookup "REMOTE_ADDR" vars of
 
72
                        Just x -> x
 
73
                        Nothing -> ""
 
74
        isSecure' =
 
75
            case map toLower $ lookup' "SERVER_PROTOCOL" vars of
 
76
                "https" -> True
 
77
                _ -> False
 
78
    let env = Request
 
79
            { requestMethod = rmethod
 
80
            , pathInfo = B.pack pinfo
 
81
            , queryString = B.pack qstring
 
82
            , serverName = B.pack servername
 
83
            , serverPort = serverport
 
84
            , requestHeaders = map (cleanupVarName *** B.pack) vars
 
85
            , isSecure = isSecure'
 
86
            , requestBody = inputH contentLength
 
87
            , errorHandler = System.IO.hPutStr System.IO.stderr
 
88
            , remoteHost = B.pack remoteHost'
 
89
            , httpVersion = "1.1" -- FIXME
 
90
            }
 
91
    res <- app env
 
92
    let h = responseHeaders res
 
93
    let h' = case lookup "Content-Type" h of
 
94
                Nothing -> ("Content-Type", "text/html; charset=utf-8")
 
95
                         : h
 
96
                Just _ -> h
 
97
    let hPut = outputH
 
98
    hPut $ B.pack $ "Status: " ++ (show $ statusCode $ status res) ++ " "
 
99
    hPut $ statusMessage $ status res
 
100
    hPut $ B.singleton '\n'
 
101
    mapM_ (printHeader hPut) h'
 
102
    case (xsendfile, responseBody res) of
 
103
        (Just sf, ResponseFile fp) ->
 
104
            hPut $ B.pack $ concat
 
105
                [ sf
 
106
                , ": "
 
107
                , fp
 
108
                , "\n\n"
 
109
                , sf
 
110
                , " not supported"
 
111
                ]
 
112
        _ -> do
 
113
            hPut $ B.singleton '\n'
 
114
            _ <- runEnumerator (fromResponseBody (responseBody res))
 
115
                               (myPut outputH) ()
 
116
            return ()
 
117
 
 
118
myPut :: (B.ByteString -> IO ()) -> () -> B.ByteString -> IO (Either () ())
 
119
myPut output _ bs = output bs >> return (Right ())
 
120
 
 
121
printHeader :: (B.ByteString -> IO ())
 
122
            -> (ResponseHeader, B.ByteString)
 
123
            -> IO ()
 
124
printHeader f (x, y) = do
 
125
    f $ ciOriginal x
 
126
    f $ B.pack ": "
 
127
    f y
 
128
    f $ B.singleton '\n'
 
129
 
 
130
cleanupVarName :: String -> RequestHeader
 
131
cleanupVarName ('H':'T':'T':'P':'_':a:as) =
 
132
    fromString $ a : helper' as
 
133
  where
 
134
    helper' ('_':x:rest) = '-' : x : helper' rest
 
135
    helper' (x:rest) = toLower x : helper' rest
 
136
    helper' [] = []
 
137
cleanupVarName "CONTENT_TYPE" = "Content-Type"
 
138
cleanupVarName "CONTENT_LENGTH" = "Content-Length"
 
139
cleanupVarName "SCRIPT_NAME" = "CGI-Script-Name"
 
140
cleanupVarName x = fromString x -- FIXME remove?