1f7163b · typeable/wai

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

compare with master

unifiedsplit

@@ -24,7 +24,6 @@ import qualified Data.String as String

24import Data.Monoid (mconcat, mempty)

25import Blaze.ByteString.Builder (fromByteString, toLazyByteString)

26import Blaze.ByteString.Builder.Char8 (fromChar, fromString)

27−import Data.Conduit.Blaze (builderToByteStringFlush)

28import Control.Monad.IO.Class (liftIO)

27import Control.Monad.IO.Class (liftIO)

29import Data.ByteString.Lazy.Internal (defaultChunkSize)

28import Data.ByteString.Lazy.Internal (defaultChunkSize)

30import System.IO (Handle)

29import System.IO (Handle)

@@ -32,7 +31,6 @@ import Network.HTTP.Types (Status (..))

32import qualified Network.HTTP.Types as H

31import qualified Network.HTTP.Types as H

33import qualified Data.CaseInsensitive as CI

32import qualified Data.CaseInsensitive as CI

34import Data.Monoid (mappend)

33import Data.Monoid (mappend)

35−import Data.Conduit

36

34

37#if WINDOWS

35#if WINDOWS

38import System.Environment (getEnvironment)

36import System.Environment (getEnvironment)

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

@@ -33,11 +33,6 @@ import Network.HTTP.Types (Status, Header)

33import Control.Monad.IO.Class (liftIO)

34import Control.Monad.Trans.Resource (runResourceT)

35import System.Directory (doesFileExist, createDirectoryIfMissing)

36−import qualified Data.Conduit as C

37−import qualified Data.Conduit.Zlib as CZ

38−import qualified Data.Conduit.Binary as CB

39−import qualified Data.Conduit.List as CL

40−import Data.Conduit.Blaze (builderToByteStringFlush)

41import Blaze.ByteString.Builder (fromByteString)

36import Blaze.ByteString.Builder (fromByteString)

42import Control.Exception (try, SomeException)

37import Control.Exception (try, SomeException)

43import qualified Data.Set as Set

38import qualified Data.Set as Set

wai-extra/Network/Wai/Middleware/Jsonp.hs−1

@@ -25,7 +25,6 @@ import Data.Monoid (mappend)

25import Control.Monad (join)

26import Data.Maybe (fromMaybe)

27import qualified Data.ByteString as S

28−import qualified Data.Conduit as C

29import Data.CaseInsensitive (CI)

28import Data.CaseInsensitive (CI)

30import Network.HTTP.Types (Status)

29import Network.HTTP.Types (Status)

31

30

wai-extra/Network/Wai/Middleware/MethodOverridePost.hs−2

@@ -11,8 +11,6 @@ module Network.Wai.Middleware.MethodOverridePost

11import Network.Wai

12import Network.HTTP.Types (parseQuery)

13import Data.Monoid (mconcat)

14−import Data.Conduit.Lazy (lazyConsume)

15−import Data.Conduit.List (sourceList)

16

14

17-- | Allows overriding of the HTTP request method via the _method post string parameter.

15-- | Allows overriding of the HTTP request method via the _method post string parameter.

18--

16--

wai-extra/Network/Wai/Middleware/RequestLogger.hs−3

@@ -34,9 +34,6 @@ import Network.Wai.Parse (sinkRequestBody, lbsBackEnd, fileName, Param, File, ge

34import qualified Data.ByteString.Lazy as LBS

35import qualified Data.ByteString.Char8 as S8

36

37−import qualified Data.Conduit as C

38−import qualified Data.Conduit.List as CL

39−

40import System.Console.ANSI

37import System.Console.ANSI

41import Data.IORef.Lifted

38import Data.IORef.Lifted

42import System.IO.Unsafe

39import System.IO.Unsafe

wai-extra/Network/Wai/Parse.hs−5

@@ -42,17 +42,12 @@ import Data.Function (on)

42import System.Directory (removeFile, getTemporaryDirectory)

43import System.IO (hClose, openBinaryTempFile)

44import Network.Wai

45−import Data.Conduit

46−import Data.Conduit.Internal ()

47−import qualified Data.Conduit.List as CL

48−import qualified Data.Conduit.Binary as CB

49import Control.Monad.IO.Class (liftIO)

45import Control.Monad.IO.Class (liftIO)

50import qualified Network.HTTP.Types as H

46import qualified Network.HTTP.Types as H

51import Data.Either (partitionEithers)

47import Data.Either (partitionEithers)

52import Control.Monad (when, unless)

48import Control.Monad (when, unless)

53import Control.Monad.Trans.Class (lift)

49import Control.Monad.Trans.Class (lift)

54import Control.Monad.Trans.Resource (allocate, release, register, InternalState, runInternalState)

50import Control.Monad.Trans.Resource (allocate, release, register, InternalState, runInternalState)

55−import Data.Conduit.Internal (Pipe (NeedInput, HaveOutput), (>+>), withUpstream, injectLeftovers, ConduitM (..))

56import Data.Void (Void)

51import Data.Void (Void)

57

52

58breakDiscard :: Word8 -> S.ByteString -> (S.ByteString, S.ByteString)

53breakDiscard :: Word8 -> S.ByteString -> (S.ByteString, S.ByteString)

wai-extra/Network/Wai/Test.hs+18−12

@@ -35,8 +35,7 @@ import Data.Map (Map)

35import qualified Data.Map as Map

36import Data.ByteString (ByteString)

37import qualified Data.ByteString.Char8 as S8

38−import Data.Conduit.Blaze (builderToByteString)

39−import Blaze.ByteString.Builder (flush)

38+import Blaze.ByteString.Builder (toLazyByteString)

40import qualified Blaze.ByteString.Builder as B

39import qualified Blaze.ByteString.Builder as B

41import qualified Data.ByteString.Lazy as L

40import qualified Data.ByteString.Lazy as L

42import qualified Data.ByteString.Lazy.Char8 as L8

41import qualified Data.ByteString.Lazy.Char8 as L8

@@ -45,10 +44,12 @@ import Data.CaseInsensitive (CI)

45import qualified Data.ByteString as S

44import qualified Data.ByteString as S

46import qualified Data.Text as T

45import qualified Data.Text as T

47import qualified Data.Text.Encoding as TE

46import qualified Data.Text.Encoding as TE

48−import qualified Data.Conduit as C

47+import Data.IORef

49−import qualified Data.Conduit.List as CL

48+import Data.Monoid (mempty, mappend)

50

49

50+type Session = ReaderT

51+ (Request -> (Response -> IO SResponse) -> IO SResponse)

51−type Session = ReaderT Application (StateT ClientState IO)

52+ (StateT ClientState IO)

52

53

53data ClientState = ClientState

54data ClientState = ClientState

54 { _clientCookies :: Map ByteString ByteString

55 { _clientCookies :: Map ByteString ByteString

@@ -96,21 +97,26 @@ setRawPathInfo r rawPinfo =

96srequest :: SRequest -> Session SResponse

97srequest :: SRequest -> Session SResponse

97srequest (SRequest req bod) = do

98srequest (SRequest req bod) = do

98 app <- ask

99 app <- ask

100+ refChunks <- liftIO $ newIORef $ L.toChunks bod

99 let req' = req

101 let req' = req

100− { requestBody = CL.sourceList $ L.toChunks bod

102+ { requestBody = atomicModifyIORef refChunks $ \bss ->

103+ case bss of

104+ [] -> ([], S.empty)

105+ x:y -> (y, x)

101 }

106 }

102− liftIO $ app req' >>= runResponse

107+ liftIO $ app req' runResponse

103 -- FIXME cookie processing

108 -- FIXME cookie processing

104 --return sres

109 --return sres

105

110

106runResponse :: Response -> IO SResponse

111runResponse :: Response -> IO SResponse

107runResponse res = do

112runResponse res = do

108− bss <- withBody $ \body -> body C.$= CL.map toBuilder C.$= builderToByteString C.$$ CL.consume

113+ refBuilder <- newIORef mempty

114+ let add y = atomicModifyIORef refBuilder $ \x -> (x `mappend` y, ())

115+ withBody $ \body -> body add (return ())

116+ builder <- readIORef refBuilder

109− return $ SResponse s h $ L.fromChunks bss

117+ return $ SResponse s h $ toLazyByteString builder

110 where

118 where

111− (s, h, withBody) = responseToSource res

119+ (s, h, withBody) = responseToStream res

112− toBuilder (C.Chunk builder) = builder

113− toBuilder C.Flush = flush

114

120

115assertBool :: String -> Bool -> Session ()

121assertBool :: String -> Bool -> Session ()

116assertBool s b = unless b $ assertFailure s

122assertBool s b = unless b $ assertFailure s

wai-extra/Network/Wai/UrlMap.hs+14−11

@@ -1,4 +1,5 @@

1{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-}

2+{-# LANGUAGE ExistentialQuantification #-}

2{- | This module gives you a way to mount applications under sub-URIs.

3{- | This module gives you a way to mount applications under sub-URIs.

3For example:

4For example:

4

5

@@ -49,13 +50,13 @@ instance Alternative UrlMap' where

49 empty = UrlMap' empty

50 empty = UrlMap' empty

50 (UrlMap' xs) <|> (UrlMap' ys) = UrlMap' (xs <|> ys)

51 (UrlMap' xs) <|> (UrlMap' ys) = UrlMap' (xs <|> ys)

51

52

52−type UrlMap = UrlMap' Application

53+type UrlMap = UrlMap' Application'

53

54

54-- | Mount an application under a given path. The ToApplication typeclass gives

55-- | Mount an application under a given path. The ToApplication typeclass gives

55-- you the option to pass either an 'Network.Wai.Application' or an 'UrlMap'

56-- you the option to pass either an 'Network.Wai.Application' or an 'UrlMap'

56-- as the second argument.

57-- as the second argument.

57mount' :: ToApplication a => Path -> a -> UrlMap

58mount' :: ToApplication a => Path -> a -> UrlMap

58−mount' prefix thing = UrlMap' [(prefix, toApplication thing)]

59+mount' prefix thing = UrlMap' [(prefix, Application' $ toApplication thing)]

59

60

60-- | A convenience function like mount', but for mounting things under a single

61-- | A convenience function like mount', but for mounting things under a single

61-- path segment.

62-- path segment.

@@ -77,20 +78,20 @@ try xs tuples = foldl go Nothing tuples

77 go _ (prefix, y) = stripPrefix prefix xs >>= \xs' -> return (xs', y)

78 go _ (prefix, y) = stripPrefix prefix xs >>= \xs' -> return (xs', y)

78

79

79class ToApplication a where

80class ToApplication a where

80− toApplication :: a -> Application

81+ toApplication :: a -> Application'

81

82

82instance ToApplication Application where

83instance ToApplication Application where

83− toApplication = id

84+ toApplication = Application'

84

85

85instance ToApplication UrlMap where

86instance ToApplication UrlMap where

86− toApplication urlMap = \req ->

87+ toApplication urlMap req sendResponse = Application' $

87 case try (pathInfo req) (unUrlMap urlMap) of

88 case try (pathInfo req) (unUrlMap urlMap) of

88− Just (newPath, app) ->

89+ Just (newPath, Application' app) ->

89− app $ req { pathInfo = newPath

90+ app (req { pathInfo = newPath

90− , rawPathInfo = makeRaw newPath

91+ , rawPathInfo = makeRaw newPath

91− }

92+ }) sendResponse

92 Nothing ->

93 Nothing ->

93− return $ responseLBS

94+ sendResponse $ responseLBS

94 status404

95 status404

95 [("content-type", "text/plain")]

96 [("content-type", "text/plain")]

96 "Not found\n"

97 "Not found\n"

@@ -100,4 +101,6 @@ instance ToApplication UrlMap where

100 makeRaw = ("/" `B.append`) . T.encodeUtf8 . T.intercalate "/"

101 makeRaw = ("/" `B.append`) . T.encodeUtf8 . T.intercalate "/"

101

102

102mapUrls :: UrlMap -> Application

103mapUrls :: UrlMap -> Application

104+mapUrls um =

103−mapUrls = toApplication

105+ case toApplication um of

106+ Application' a -> a