From e2eb7d3315de6e051c7e1bbf493126913cdb3410 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 9 Jul 2010 00:06:46 +0300 Subject: [PATCH] Migrated to WAI 0.2 --- Yesod/Content.hs | 29 +++++++---------------------- Yesod/Dispatch.hs | 24 ++++++++++++------------ Yesod/Handler.hs | 24 ++++++++++++------------ yesod.cabal | 4 ++-- 4 files changed, 33 insertions(+), 48 deletions(-) diff --git a/Yesod/Content.hs b/Yesod/Content.hs index 0dea1d78..b21e0f59 100644 --- a/Yesod/Content.hs +++ b/Yesod/Content.hs @@ -8,7 +8,7 @@ module Yesod.Content ( -- * Content - Content (..) + Content , emptyContent , ToContent (..) -- * Mime types @@ -56,7 +56,6 @@ import Data.Text.Lazy (Text) import qualified Data.Text as T import qualified Network.Wai as W -import qualified Network.Wai.Enumerator as WE import Data.Time import System.Locale @@ -72,22 +71,11 @@ import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.HUnit hiding (Test) #endif --- | There are two different methods available for providing content in the --- response: via files and enumerators. The former allows server to use --- optimizations (usually the sendfile system call) for serving static files. --- The latter is a space-efficient approach to content. --- --- It can be tedious to write enumerators; often times, you will be well served --- to use 'toContent'. -data Content = ContentFile FilePath - | ContentEnum (forall a. - (a -> B.ByteString -> IO (Either a a)) - -> a - -> IO (Either a a)) +type Content = W.ResponseBody -- | Zero-length enumerator. emptyContent :: Content -emptyContent = ContentEnum $ \_ -> return . Right +emptyContent = W.ResponseLBS L.empty -- | Anything which can be converted into 'Content'. Most of the time, you will -- want to use the 'ContentEnum' constructor. An easier approach will be to use @@ -97,15 +85,15 @@ class ToContent a where toContent :: a -> Content instance ToContent B.ByteString where - toContent bs = ContentEnum $ \f a -> f a bs + toContent = W.ResponseLBS . L.fromChunks . return instance ToContent L.ByteString where - toContent = swapEnum . WE.fromLBS + toContent = W.ResponseLBS instance ToContent T.Text where toContent = toContent . Data.Text.Encoding.encodeUtf8 instance ToContent Text where - toContent = toContent . Data.Text.Lazy.Encoding.encodeUtf8 + toContent = W.ResponseLBS . Data.Text.Lazy.Encoding.encodeUtf8 instance ToContent String where - toContent = toContent . Data.ByteString.Lazy.UTF8.fromString + toContent = W.ResponseLBS . Data.ByteString.Lazy.UTF8.fromString -- | A function which gives targetted representations of content based on the -- content-types the user accepts. @@ -113,9 +101,6 @@ type ChooseRep = [ContentType] -- ^ list of content-types user accepts, ordered by preference -> IO (ContentType, Content) -swapEnum :: W.Enumerator -> Content -swapEnum (W.Enumerator e) = ContentEnum e - -- | Any type which can be converted to representations. class HasReps a where chooseRep :: a -> ChooseRep diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 24ea7d30..dbe607ec 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -1,6 +1,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module Yesod.Dispatch ( -- * Quasi-quoted routing parseRoutes @@ -64,6 +65,7 @@ import Data.Serialize import qualified Data.Serialize as Ser import Network.Wai.Parse hiding (FileInfo) import qualified Network.Wai.Parse as NWP +import Data.String (fromString) #if TEST import Test.Framework (testGroup, Test) @@ -241,11 +243,11 @@ toWaiApp' y segments env = do let exp' = getExpires $ clientSessionDuration y let host = W.remoteHost env let session' = fromMaybe [] $ do - raw <- lookup W.Cookie $ W.requestHeaders env + raw <- lookup "Cookie" $ W.requestHeaders env val <- lookup (B.pack sessionName) $ parseCookies raw decodeSession key' now host val let site = getSite - method = B.unpack $ W.methodToBS $ W.requestMethod env + method = B.unpack $ W.requestMethod env types = httpAccept env pathSegments = filter (not . null) segments eurl = parsePathSegments site pathSegments @@ -281,10 +283,8 @@ toWaiApp' y segments env = do (S.toString sessionVal) : hs hs'' = map (headerToPair getExpires) hs' - hs''' = (W.ContentType, S.fromString ct) : hs'' - return $ W.Response s hs''' $ case c of - ContentFile fp -> Left fp - ContentEnum e -> Right $ W.Enumerator e + hs''' = ("Content-Type", S.fromString ct) : hs'' + return $ W.Response s hs''' c -- | Fully render a route to an absolute URL. Since Yesod does this for you -- internally, you will rarely need access to this. However, if you need to @@ -303,7 +303,7 @@ httpAccept :: W.Request -> [ContentType] httpAccept = map B.unpack . parseHttpAccept . fromMaybe B.empty - . lookup W.Accept + . lookup "Accept" . W.requestHeaders -- | Runs an application with CGI if CGI variables are present (namely @@ -347,10 +347,10 @@ parseWaiRequest :: W.Request parseWaiRequest env session' = do let gets' = map (S.toString *** S.toString) $ parseQueryString $ W.queryString env - let reqCookie = fromMaybe B.empty $ lookup W.Cookie + let reqCookie = fromMaybe B.empty $ lookup "Cookie" $ W.requestHeaders env cookies' = map (S.toString *** S.toString) $ parseCookies reqCookie - acceptLang = lookup W.AcceptLanguage $ W.requestHeaders env + acceptLang = lookup "Accept-Language" $ W.requestHeaders env langs = map S.toString $ maybe [] parseHttpAccept acceptLang langs' = case lookup langKey session' of Nothing -> langs @@ -389,14 +389,14 @@ headerToPair :: (Int -> UTCTime) -- ^ minutes -> expiration time -> (W.ResponseHeader, B.ByteString) headerToPair getExpires (AddCookie minutes key value) = let expires = getExpires minutes - in (W.SetCookie, S.fromString + in ("Set-Cookie", S.fromString $ key ++ "=" ++ value ++"; path=/; expires=" ++ formatW3 expires) headerToPair _ (DeleteCookie key) = - (W.SetCookie, S.fromString $ + ("Set-Cookie", S.fromString $ key ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT") headerToPair _ (Header key value) = - (W.responseHeaderFromBS $ S.fromString key, S.fromString value) + (fromString key, S.fromString value) encodeSession :: CS.Key -> UTCTime -- ^ expire time diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index eb17e74f..ce81516f 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -240,11 +240,11 @@ runHandler handler mrender sroute tomr ma tosa = YesodApp $ \eh rr cts -> do let hs' = headers hs return (getStatus e, hs', ct, c, sess) let sendFile' ct fp = - return (W.Status200, headers [], ct, ContentFile fp, finalSession) + return (W.status200, headers [], ct, W.ResponseFile fp, finalSession) case contents of HCContent a -> do (ct, c) <- chooseRep a cts - return (W.Status200, headers [], ct, c, finalSession) + return (W.status200, headers [], ct, c, finalSession) HCError e -> handleError e HCRedirect rt loc -> do let hs = Header "Location" loc : headers [] @@ -257,7 +257,7 @@ runHandler handler mrender sroute tomr ma tosa = YesodApp $ \eh rr cts -> do safeEh :: ErrorResponse -> YesodApp safeEh er = YesodApp $ \_ _ _ -> do liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er - return (W.Status500, [], typePlain, toContent "Internal Server Error", []) + return (W.status500, [], typePlain, toContent "Internal Server Error", []) -- | Redirect to the given route. redirect :: RedirectType -> Route master -> GHandler sub master a @@ -373,7 +373,7 @@ notFound = failure NotFound badMethod :: (RequestReader m, Failure ErrorResponse m) => m a badMethod = do w <- waiRequest - failure $ BadMethod $ toString $ W.methodToBS $ W.requestMethod w + failure $ BadMethod $ toString $ W.requestMethod w -- | Return a 403 permission denied page. permissionDenied :: Failure ErrorResponse m => String -> m a @@ -422,16 +422,16 @@ addHeader :: Header -> GHandler sub master () addHeader = GHandler . lift . lift . tell . (:) getStatus :: ErrorResponse -> W.Status -getStatus NotFound = W.Status404 -getStatus (InternalError _) = W.Status500 -getStatus (InvalidArgs _) = W.Status400 -getStatus (PermissionDenied _) = W.Status403 -getStatus (BadMethod _) = W.Status405 +getStatus NotFound = W.status404 +getStatus (InternalError _) = W.status500 +getStatus (InvalidArgs _) = W.status400 +getStatus (PermissionDenied _) = W.status403 +getStatus (BadMethod _) = W.status405 getRedirectStatus :: RedirectType -> W.Status -getRedirectStatus RedirectPermanent = W.Status301 -getRedirectStatus RedirectTemporary = W.Status302 -getRedirectStatus RedirectSeeOther = W.Status303 +getRedirectStatus RedirectPermanent = W.status301 +getRedirectStatus RedirectTemporary = W.status302 +getRedirectStatus RedirectSeeOther = W.status303 -- | Different types of redirects. data RedirectType = RedirectPermanent diff --git a/yesod.cabal b/yesod.cabal index 89a37385..9b10d12b 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -22,8 +22,8 @@ flag buildtests library build-depends: base >= 4 && < 5, time >= 1.1.3 && < 1.2, - wai >= 0.1.0 && < 0.2, - wai-extra >= 0.1.3.1 && < 0.2, + wai >= 0.2.0 && < 0.3, + wai-extra >= 0.2.0 && < 0.3, authenticate >= 0.6.3 && < 0.7, bytestring >= 0.9.1.4 && < 0.10, directory >= 1 && < 1.1,