Add 'wai-extra/' from commit '29076d018b0cc159c3ccf3050350e4b7469f2c6c'

git-subtree-dir: wai-extra
git-subtree-mainline: ebedc4d
git-subtree-split: 29076d0

wai-extra/.gitignore

@@ -0,0 +1,2 @@
+*.swp
+dist

wai-extra/LICENSE

@@ -0,0 +1,25 @@
+The following license covers this documentation, and the source code, except
+where otherwise indicated.
+
+Copyright 2010, Michael Snoyman. All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+* Redistributions of source code must retain the above copyright notice, this
+  list of conditions and the following disclaimer.
+
+* Redistributions in binary form must reproduce the above copyright notice,
+  this list of conditions and the following disclaimer in the documentation
+  and/or other materials provided with the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR
+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,
+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

wai-extra/Network/Wai/Handler/CGI.hs

@@ -0,0 +1,178 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+-- | Backend for Common Gateway Interface. Almost all users should use the
+-- 'run' function.
+module Network.Wai.Handler.CGI
+    ( run
+    , runSendfile
+    , runGeneric
+    , requestBodyFunc
+    ) where
+
+import Network.Wai
+import Network.Socket (getAddrInfo, addrAddress)
+import System.Environment (getEnvironment)
+import Data.Maybe (fromMaybe)
+import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.Lazy as L
+import Control.Arrow ((***))
+import Data.Char (toLower)
+import qualified System.IO
+import qualified Data.String as String
+import Data.Enumerator
+    ( Enumerator, Step (..), Stream (..), continue, yield
+    , enumList, ($$), joinI, returnI, (>>==), run_
+    )
+import Data.Monoid (mconcat)
+import Blaze.ByteString.Builder (fromByteString, toLazyByteString)
+import Blaze.ByteString.Builder.Char8 (fromChar, fromString)
+import Blaze.ByteString.Builder.Enumerator (builderToByteString)
+import Control.Monad.IO.Class (liftIO)
+import Data.ByteString.Lazy.Internal (defaultChunkSize)
+import System.IO (Handle)
+import Network.HTTP.Types (Status (..))
+import qualified Network.HTTP.Types as H
+import qualified Data.CaseInsensitive as CI
+
+safeRead :: Read a => a -> String -> a
+safeRead d s =
+  case reads s of
+    ((x, _):_) -> x
+    [] -> d
+
+lookup' :: String -> [(String, String)] -> String
+lookup' key pairs = fromMaybe "" $ lookup key pairs
+
+-- | Run an application using CGI.
+run :: Application -> IO ()
+run app = do
+    vars <- getEnvironment
+    let input = requestBodyHandle System.IO.stdin
+        output = B.hPut System.IO.stdout
+    runGeneric vars input output Nothing app
+
+-- | Some web servers provide an optimization for sending files via a sendfile
+-- system call via a special header. To use this feature, provide that header
+-- name here.
+runSendfile :: B.ByteString -- ^ sendfile header
+            -> Application -> IO ()
+runSendfile sf app = do
+    vars <- getEnvironment
+    let input = requestBodyHandle System.IO.stdin
+        output = B.hPut System.IO.stdout
+    runGeneric vars input output (Just sf) app
+
+-- | A generic CGI helper, which allows other backends (FastCGI and SCGI) to
+-- use the same code as CGI. Most users will not need this function, and can
+-- stick with 'run' or 'runSendfile'.
+runGeneric
+     :: [(String, String)] -- ^ all variables
+     -> (forall a. Int -> Enumerator B.ByteString IO a) -- ^ responseBody of input
+     -> (B.ByteString -> IO ()) -- ^ destination for output
+     -> Maybe B.ByteString -- ^ does the server support the X-Sendfile header?
+     -> Application
+     -> IO ()
+runGeneric vars inputH outputH xsendfile app = do
+    let rmethod = B.pack $ lookup' "REQUEST_METHOD" vars
+        pinfo = lookup' "PATH_INFO" vars
+        qstring = lookup' "QUERY_STRING" vars
+        servername = lookup' "SERVER_NAME" vars
+        serverport = safeRead 80 $ lookup' "SERVER_PORT" vars
+        contentLength = safeRead 0 $ lookup' "CONTENT_LENGTH" vars
+        remoteHost' =
+            case lookup "REMOTE_ADDR" vars of
+                Just x -> x
+                Nothing ->
+                    case lookup "REMOTE_HOST" vars of
+                        Just x -> x
+                        Nothing -> ""
+        isSecure' =
+            case map toLower $ lookup' "SERVER_PROTOCOL" vars of
+                "https" -> True
+                _ -> False
+    addrs <- getAddrInfo Nothing (Just remoteHost') Nothing
+    let addr =
+            case addrs of
+                a:_ -> addrAddress a
+                [] -> error $ "Invalid REMOTE_ADDR or REMOTE_HOST: " ++ remoteHost'
+    let env = Request
+            { requestMethod = rmethod
+            , rawPathInfo = B.pack pinfo
+            , pathInfo = H.decodePathSegments $ B.pack pinfo
+            , rawQueryString = B.pack qstring
+            , queryString = H.parseQuery $ B.pack qstring
+            , serverName = B.pack servername
+            , serverPort = serverport
+            , requestHeaders = map (cleanupVarName *** B.pack) vars
+            , isSecure = isSecure'
+            , remoteHost = addr
+            , httpVersion = H.http11 -- FIXME
+            }
+    -- FIXME worry about exception?
+    res <- run_ $ inputH contentLength $$ app env
+    case (xsendfile, res) of
+        (Just sf, ResponseFile s hs fp Nothing) ->
+            mapM_ outputH $ L.toChunks $ toLazyByteString $ sfBuilder s hs sf fp
+        _ -> responseEnumerator res $ \s hs ->
+            joinI $ enumList 1 [headers s hs, fromChar '\n'] $$ builderIter
+  where
+    headers s hs = mconcat (map header $ status s : map header' (fixHeaders hs))
+    status (Status i m) = (fromByteString "Status", mconcat
+        [ fromString $ show i
+        , fromChar ' '
+        , fromByteString m
+        ])
+    header' (x, y) = (fromByteString $ CI.original x, fromByteString y)
+    header (x, y) = mconcat
+        [ x
+        , fromByteString ": "
+        , y
+        , fromChar '\n'
+        ]
+    sfBuilder s hs sf fp = mconcat
+        [ headers s hs
+        , header $ (fromByteString sf, fromString fp)
+        , fromChar '\n'
+        , fromByteString sf
+        , fromByteString " not supported"
+        ]
+    bsStep = Continue bsStep'
+    bsStep' EOF = yield () EOF
+    bsStep' (Chunks []) = continue bsStep'
+    bsStep' (Chunks bss) = liftIO (mapM_ outputH bss) >> continue bsStep'
+    builderIter = builderToByteString bsStep
+    fixHeaders h =
+        case lookup "content-type" h of
+            Nothing -> ("Content-Type", "text/html; charset=utf-8") : h
+            Just _ -> h
+
+cleanupVarName :: String -> CI.CI B.ByteString
+cleanupVarName ('H':'T':'T':'P':'_':a:as) =
+    String.fromString $ a : helper' as
+  where
+    helper' ('_':x:rest) = '-' : x : helper' rest
+    helper' (x:rest) = toLower x : helper' rest
+    helper' [] = []
+cleanupVarName "CONTENT_TYPE" = "Content-Type"
+cleanupVarName "CONTENT_LENGTH" = "Content-Length"
+cleanupVarName "SCRIPT_NAME" = "CGI-Script-Name"
+cleanupVarName x = String.fromString x -- FIXME remove?
+
+requestBodyHandle :: Handle -> Int -> Enumerator B.ByteString IO a
+requestBodyHandle h =
+    requestBodyFunc go
+  where
+    go i = Just `fmap` B.hGet h (min i defaultChunkSize)
+
+requestBodyFunc :: (Int -> IO (Maybe B.ByteString))
+                -> Int
+                -> Enumerator B.ByteString IO a
+requestBodyFunc _ 0 step = returnI step
+requestBodyFunc h len (Continue k) = do
+    mbs <- liftIO $ h len
+    case mbs of
+        Nothing -> continue k
+        Just bs -> do
+            let newLen = len - B.length bs
+            k (Chunks [bs]) >>== requestBodyFunc h newLen
+requestBodyFunc _ _ step = returnI step

wai-extra/Network/Wai/Middleware/AcceptOverride.hs

@@ -0,0 +1,26 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Network.Wai.Middleware.AcceptOverride
+    ( acceptOverride
+    ) where
+
+import Network.Wai
+import Control.Monad (join)
+import Data.ByteString (ByteString)
+
+acceptOverride :: Middleware
+acceptOverride app req =
+    app req'
+  where
+    req' =
+        case join $ lookup "_accept" $ queryString req of
+            Nothing -> req
+            Just a -> req { requestHeaders = changeVal "Accept" a $ requestHeaders req}
+
+changeVal :: Eq a
+          => a
+          -> ByteString
+          -> [(a, ByteString)]
+          -> [(a, ByteString)]
+changeVal key val old = (key, val)
+                      : filter (\(k, _) -> k /= key) old

wai-extra/Network/Wai/Middleware/Autohead.hs

@@ -0,0 +1,23 @@
+{-# LANGUAGE OverloadedStrings #-}
+-- | Automatically produce responses to HEAD requests based on the underlying
+-- applications GET response.
+module Network.Wai.Middleware.Autohead (autohead) where
+
+import Network.Wai
+import Data.Monoid (mempty)
+import Data.Enumerator (enumEOF, ($$))
+
+autohead :: Middleware
+autohead app req
+    | requestMethod req == "HEAD" = do
+        res <- app req { requestMethod = "GET" }
+        case res of
+            ResponseFile s hs _ _ -> return $ ResponseBuilder s hs mempty
+            ResponseBuilder s hs _ -> return $ ResponseBuilder s hs mempty
+            ResponseEnumerator e -> do
+                let helper f =
+                        let helper' s hs = enumEOF $$ f s hs
+                         in e helper'
+                return $ ResponseEnumerator helper
+    | otherwise = app req
+

wai-extra/Network/Wai/Middleware/CleanPath.hs

@@ -0,0 +1,30 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Network.Wai.Middleware.CleanPath
+    ( cleanPath
+    ) where
+
+import Network.Wai
+import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.Lazy as L
+import Network.HTTP.Types (status301)
+import Data.Text (Text)
+import Data.Monoid (mconcat)
+
+cleanPath :: ([Text] -> Either B.ByteString [Text])
+          -> B.ByteString
+          -> ([Text] -> Application)
+          -> Application
+cleanPath splitter prefix app env =
+    case splitter $ pathInfo env of
+        Right pieces -> app pieces env
+        Left p -> return
+                $ responseLBS status301
+                  [("Location", mconcat [prefix, p, suffix])]
+                $ L.empty
+    where
+        -- include the query string if present
+        suffix =
+            case B.uncons $ rawQueryString env of
+                Nothing -> B.empty
+                Just ('?', _) -> rawQueryString env
+                _ -> B.cons '?' $ rawQueryString env

wai-extra/Network/Wai/Middleware/Debug.hs

@@ -0,0 +1,36 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Network.Wai.Middleware.Debug
+    ( debug
+    , debugDest
+    ) where
+
+import Network.Wai (Middleware, requestMethod, requestHeaders, rawPathInfo, rawQueryString)
+import Network.Wai.Parse (parseRequestBody, lbsSink, fileName)
+import Data.ByteString.Char8 (unpack)
+import System.IO (hPutStrLn, stderr)
+import Control.Monad.IO.Class (liftIO)
+import qualified Data.Text.Lazy as T
+import Data.Enumerator (run_, ($$), enumList)
+import Data.Enumerator.List (consume)
+
+-- | Prints a message to 'stderr' for each request.
+debug :: Middleware
+debug = debugDest $ hPutStrLn stderr . T.unpack
+
+-- | Prints a message using the given callback function for each request.
+debugDest :: (T.Text -> IO ()) -> Middleware
+debugDest cb app req = do
+    body <- consume
+    (params, files) <- liftIO $ run_ $ enumList 1 body $$ parseRequestBody lbsSink req
+    liftIO $ cb $ T.pack $ concat
+        [ unpack $ requestMethod req
+        , " "
+        , unpack $ rawPathInfo req
+        , unpack $ rawQueryString req
+        , "\n"
+        , (++) "Accept: " $ maybe "" unpack $ lookup "Accept" $ requestHeaders req
+        , "\n"
+        , if null params then "" else "Post parameters: " ++ show params ++ "\n"
+        , if null files then "" else "Post file names: " ++ show (map (fileName . snd) files) ++ "\n"
+        ]
+    liftIO $ run_ $ enumList 1 body $$ app req

wai-extra/Network/Wai/Middleware/Gzip.hs

@@ -0,0 +1,70 @@
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE OverloadedStrings #-}
+---------------------------------------------------------
+-- |
+-- Module        : Network.Wai.Middleware.Gzip
+-- Copyright     : Michael Snoyman
+-- License       : BSD3
+--
+-- Maintainer    : Michael Snoyman <michael@snoyman.com>
+-- Stability     : Unstable
+-- Portability   : portable
+--
+-- Automatic gzip compression of responses.
+--
+---------------------------------------------------------
+module Network.Wai.Middleware.Gzip (gzip) where
+
+import Network.Wai
+import Network.Wai.Zlib
+import Data.Maybe (fromMaybe)
+import Data.Enumerator (($$), joinI)
+import qualified Data.ByteString.Char8 as S8
+import qualified Data.ByteString as S
+
+-- | Use gzip to compress the body of the response.
+--
+-- Analyzes the \"Accept-Encoding\" header from the client to determine
+-- if gzip is supported.
+--
+-- Possible future enhancements:
+--
+-- * Only compress if the response is above a certain size.
+--
+-- * I've read that IE can\'t support compression for Javascript files.
+gzip :: Bool -- ^ should we gzip files?
+     -> Middleware
+gzip files app env = do
+    res <- app env
+    return $
+        case res of
+            ResponseFile{} | not files -> res
+            _ -> if "gzip" `elem` enc && not isMSIE6
+                    then ResponseEnumerator $ compressE $ responseEnumerator res
+                    else res
+  where
+    enc = fromMaybe [] $ (splitCommas . S8.unpack)
+                    `fmap` lookup "Accept-Encoding" (requestHeaders env)
+    ua = fromMaybe "" $ lookup "user-agent" $ requestHeaders env
+    isMSIE6 = "MSIE 6" `S.isInfixOf` ua
+
+compressE :: (forall a. ResponseEnumerator a)
+          -> (forall a. ResponseEnumerator a)
+compressE re f =
+    re f'
+    --e s hs'
+  where
+    f' s hs =
+        joinI $ compress $$ f s hs'
+      where
+        -- Remove Content-Length header, since we will certainly have a
+        -- different length after gzip compression.
+        hs' = ("Content-Encoding", "gzip") : filter notLength hs
+        notLength (x, _) = x /= "content-length"
+
+splitCommas :: String -> [String]
+splitCommas [] = []
+splitCommas x =
+    let (y, z) = break (== ',') x
+     in y : splitCommas (dropWhile (== ' ') $ drop 1 z)