git.iko.soy/typeable/wai
on master help sign in
Beginning of wai-extra conversion

I quickly ran into problems with existentials. Going to try out an alternate approach to simplify the types.

commit1f7163b4c68451f4b65815da2240dcfc6e7ab08b authorMichael Snoyman <michael@snoyman.com> dateThu 22 May 2014, 14:56 (12 years ago) parent5be28b6
8 files changed+32−41
compare with master
unifiedsplit
wai-extra/Network/Wai/Handler/CGI.hs−2 wai-extra/Network/Wai/Middleware/Gzip.hs−5 wai-extra/Network/Wai/Middleware/Jsonp.hs−1 wai-extra/Network/Wai/Middleware/MethodOverridePost.hs−2 wai-extra/Network/Wai/Middleware/RequestLogger.hs−3 wai-extra/Network/Wai/Parse.hs−5 wai-extra/Network/Wai/Test.hs+18−12 wai-extra/Network/Wai/UrlMap.hs+14−11
wai-extra/Network/Wai/Handler/CGI.hs−2
@@ -24,7 +24,6 @@ import qualified Data.String as String
2424import Data.Monoid (mconcat, mempty)
2525import Blaze.ByteString.Builder (fromByteString, toLazyByteString)
2626import Blaze.ByteString.Builder.Char8 (fromChar, fromString)
27−import Data.Conduit.Blaze (builderToByteStringFlush)
2827import Control.Monad.IO.Class (liftIO)
2928import Data.ByteString.Lazy.Internal (defaultChunkSize)
3029import System.IO (Handle)
@@ -32,7 +31,6 @@ import Network.HTTP.Types (Status (..))
3231import qualified Network.HTTP.Types as H
3332import qualified Data.CaseInsensitive as CI
3433import Data.Monoid (mappend)
35−import Data.Conduit
3634
3735#if WINDOWS
3836import System.Environment (getEnvironment)
wai-extra/Network/Wai/Middleware/Gzip.hs−5
@@ -33,11 +33,6 @@ import Network.HTTP.Types (Status, Header)
3333import Control.Monad.IO.Class (liftIO)
3434import Control.Monad.Trans.Resource (runResourceT)
3535import 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)
4136import Blaze.ByteString.Builder (fromByteString)
4237import Control.Exception (try, SomeException)
4338import qualified Data.Set as Set
wai-extra/Network/Wai/Middleware/Jsonp.hs−1
@@ -25,7 +25,6 @@ import Data.Monoid (mappend)
2525import Control.Monad (join)
2626import Data.Maybe (fromMaybe)
2727import qualified Data.ByteString as S
28−import qualified Data.Conduit as C
2928import Data.CaseInsensitive (CI)
3029import Network.HTTP.Types (Status)
3130
wai-extra/Network/Wai/Middleware/MethodOverridePost.hs−2
@@ -11,8 +11,6 @@ module Network.Wai.Middleware.MethodOverridePost
1111import Network.Wai
1212import Network.HTTP.Types (parseQuery)
1313import Data.Monoid (mconcat)
14−import Data.Conduit.Lazy (lazyConsume)
15−import Data.Conduit.List (sourceList)
1614
1715-- | Allows overriding of the HTTP request method via the _method post string parameter.
1816--
wai-extra/Network/Wai/Middleware/RequestLogger.hs−3
@@ -34,9 +34,6 @@ import Network.Wai.Parse (sinkRequestBody, lbsBackEnd, fileName, Param, File, ge
3434import qualified Data.ByteString.Lazy as LBS
3535import qualified Data.ByteString.Char8 as S8
3636
37−import qualified Data.Conduit as C
38−import qualified Data.Conduit.List as CL
39−
4037import System.Console.ANSI
4138import Data.IORef.Lifted
4239import System.IO.Unsafe
wai-extra/Network/Wai/Parse.hs−5
@@ -42,17 +42,12 @@ import Data.Function (on)
4242import System.Directory (removeFile, getTemporaryDirectory)
4343import System.IO (hClose, openBinaryTempFile)
4444import 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
4945import Control.Monad.IO.Class (liftIO)
5046import qualified Network.HTTP.Types as H
5147import Data.Either (partitionEithers)
5248import Control.Monad (when, unless)
5349import Control.Monad.Trans.Class (lift)
5450import Control.Monad.Trans.Resource (allocate, release, register, InternalState, runInternalState)
55−import Data.Conduit.Internal (Pipe (NeedInput, HaveOutput), (>+>), withUpstream, injectLeftovers, ConduitM (..))
5651import Data.Void (Void)
5752
5853breakDiscard :: Word8 -> S.ByteString -> (S.ByteString, S.ByteString)
wai-extra/Network/Wai/Test.hs+18−12
@@ -35,8 +35,7 @@ import Data.Map (Map)
3535import qualified Data.Map as Map
3636import Data.ByteString (ByteString)
3737import qualified Data.ByteString.Char8 as S8
38−import Data.Conduit.Blaze (builderToByteString)
39−import Blaze.ByteString.Builder (flush)
38+import Blaze.ByteString.Builder (toLazyByteString)
4039import qualified Blaze.ByteString.Builder as B
4140import qualified Data.ByteString.Lazy as L
4241import qualified Data.ByteString.Lazy.Char8 as L8
@@ -45,10 +44,12 @@ import Data.CaseInsensitive (CI)
4544import qualified Data.ByteString as S
4645import qualified Data.Text as T
4746import qualified Data.Text.Encoding as TE
48−import qualified Data.Conduit as C
49−import qualified Data.Conduit.List as CL
47+import Data.IORef
48+import Data.Monoid (mempty, mappend)
5049
51−type Session = ReaderT Application (StateT ClientState IO)
50+type Session = ReaderT
51+ (Request -> (Response -> IO SResponse) -> IO SResponse)
52+ (StateT ClientState IO)
5253
5354data ClientState = ClientState
5455 { _clientCookies :: Map ByteString ByteString
@@ -96,21 +97,26 @@ setRawPathInfo r rawPinfo =
9697srequest :: SRequest -> Session SResponse
9798srequest (SRequest req bod) = do
9899 app <- ask
100+ refChunks <- liftIO $ newIORef $ L.toChunks bod
99101 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)
101106 }
102− liftIO $ app req' >>= runResponse
107+ liftIO $ app req' runResponse
103108 -- FIXME cookie processing
104109 --return sres
105110
106111runResponse :: Response -> IO SResponse
107112runResponse res = do
108− bss <- withBody $ \body -> body C.$= CL.map toBuilder C.$= builderToByteString C.$$ CL.consume
109− return $ SResponse s h $ L.fromChunks bss
113+ refBuilder <- newIORef mempty
114+ let add y = atomicModifyIORef refBuilder $ \x -> (x `mappend` y, ())
115+ withBody $ \body -> body add (return ())
116+ builder <- readIORef refBuilder
117+ return $ SResponse s h $ toLazyByteString builder
110118 where
111− (s, h, withBody) = responseToSource res
112− toBuilder (C.Chunk builder) = builder
113− toBuilder C.Flush = flush
119+ (s, h, withBody) = responseToStream res
114120
115121assertBool :: String -> Bool -> Session ()
116122assertBool s b = unless b $ assertFailure s
wai-extra/Network/Wai/UrlMap.hs+14−11
@@ -1,4 +1,5 @@
11{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-}
2+{-# LANGUAGE ExistentialQuantification #-}
23{- | This module gives you a way to mount applications under sub-URIs.
34For example:
45
@@ -49,13 +50,13 @@ instance Alternative UrlMap' where
4950 empty = UrlMap' empty
5051 (UrlMap' xs) <|> (UrlMap' ys) = UrlMap' (xs <|> ys)
5152
52−type UrlMap = UrlMap' Application
53+type UrlMap = UrlMap' Application'
5354
5455-- | Mount an application under a given path. The ToApplication typeclass gives
5556-- you the option to pass either an 'Network.Wai.Application' or an 'UrlMap'
5657-- as the second argument.
5758mount' :: ToApplication a => Path -> a -> UrlMap
58−mount' prefix thing = UrlMap' [(prefix, toApplication thing)]
59+mount' prefix thing = UrlMap' [(prefix, Application' $ toApplication thing)]
5960
6061-- | A convenience function like mount', but for mounting things under a single
6162-- path segment.
@@ -77,20 +78,20 @@ try xs tuples = foldl go Nothing tuples
7778 go _ (prefix, y) = stripPrefix prefix xs >>= \xs' -> return (xs', y)
7879
7980class ToApplication a where
80− toApplication :: a -> Application
81+ toApplication :: a -> Application'
8182
8283instance ToApplication Application where
83− toApplication = id
84+ toApplication = Application'
8485
8586instance ToApplication UrlMap where
86− toApplication urlMap = \req ->
87+ toApplication urlMap req sendResponse = Application' $
8788 case try (pathInfo req) (unUrlMap urlMap) of
88− Just (newPath, app) ->
89− app $ req { pathInfo = newPath
90− , rawPathInfo = makeRaw newPath
91− }
89+ Just (newPath, Application' app) ->
90+ app (req { pathInfo = newPath
91+ , rawPathInfo = makeRaw newPath
92+ }) sendResponse
9293 Nothing ->
93− return $ responseLBS
94+ sendResponse $ responseLBS
9495 status404
9596 [("content-type", "text/plain")]
9697 "Not found\n"
@@ -100,4 +101,6 @@ instance ToApplication UrlMap where
100101 makeRaw = ("/" `B.append`) . T.encodeUtf8 . T.intercalate "/"
101102
102103mapUrls :: UrlMap -> Application
103−mapUrls = toApplication
104+mapUrls um =
105+ case toApplication um of
106+ Application' a -> a