haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Migrated to WAI 0.2

Browse Source
This commit is contained in:
Michael Snoyman 2010-07-09 00:06:46 +03:00
parent d5704fb65d
commit e2eb7d3315
4 changed files with 33 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
Yesod/Content.hs
View File

@ -8,7 +8,7 @@
module Yesod.Content module Yesod.Content
( -- * Content ( -- * Content
Content (..) Content
, emptyContent , emptyContent
, ToContent (..) , ToContent (..)
-- * Mime types -- * Mime types
@ -56,7 +56,6 @@ import Data.Text.Lazy (Text)
import qualified Data.Text as T import qualified Data.Text as T
import qualified Network.Wai as W import qualified Network.Wai as W
import qualified Network.Wai.Enumerator as WE
import Data.Time import Data.Time
import System.Locale import System.Locale
@ -72,22 +71,11 @@ import Test.Framework.Providers.QuickCheck2 (testProperty)
import Test.HUnit hiding (Test) import Test.HUnit hiding (Test)
#endif #endif
-- | There are two different methods available for providing content in the type Content = W.ResponseBody
-- 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))
-- | Zero-length enumerator. -- | Zero-length enumerator.
emptyContent :: Content emptyContent :: Content
emptyContent = ContentEnum $ \_ -> return . Right emptyContent = W.ResponseLBS L.empty
-- | Anything which can be converted into 'Content'. Most of the time, you will -- | 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 -- want to use the 'ContentEnum' constructor. An easier approach will be to use
@ -97,15 +85,15 @@ class ToContent a where
toContent :: a -> Content toContent :: a -> Content
instance ToContent B.ByteString where instance ToContent B.ByteString where
toContent bs = ContentEnum $ \f a -> f a bs toContent = W.ResponseLBS . L.fromChunks . return
instance ToContent L.ByteString where instance ToContent L.ByteString where
toContent = swapEnum . WE.fromLBS toContent = W.ResponseLBS
instance ToContent T.Text where instance ToContent T.Text where
toContent = toContent . Data.Text.Encoding.encodeUtf8 toContent = toContent . Data.Text.Encoding.encodeUtf8
instance ToContent Text where instance ToContent Text where
toContent = toContent . Data.Text.Lazy.Encoding.encodeUtf8 toContent = W.ResponseLBS . Data.Text.Lazy.Encoding.encodeUtf8
instance ToContent String where 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 -- | A function which gives targetted representations of content based on the
-- content-types the user accepts. -- content-types the user accepts.
@ -113,9 +101,6 @@ type ChooseRep =
[ContentType] -- ^ list of content-types user accepts, ordered by preference [ContentType] -- ^ list of content-types user accepts, ordered by preference
-> IO (ContentType, Content) -> IO (ContentType, Content)
swapEnum :: W.Enumerator -> Content
swapEnum (W.Enumerator e) = ContentEnum e
-- | Any type which can be converted to representations. -- | Any type which can be converted to representations.
class HasReps a where class HasReps a where
chooseRep :: a -> ChooseRep chooseRep :: a -> ChooseRep

24
Yesod/Dispatch.hs
View File

@ -1,6 +1,7 @@
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Yesod.Dispatch module Yesod.Dispatch
( -- * Quasi-quoted routing ( -- * Quasi-quoted routing
parseRoutes parseRoutes
@ -64,6 +65,7 @@ import Data.Serialize
import qualified Data.Serialize as Ser import qualified Data.Serialize as Ser
import Network.Wai.Parse hiding (FileInfo) import Network.Wai.Parse hiding (FileInfo)
import qualified Network.Wai.Parse as NWP import qualified Network.Wai.Parse as NWP
import Data.String (fromString)
#if TEST #if TEST
import Test.Framework (testGroup, Test) import Test.Framework (testGroup, Test)
@ -241,11 +243,11 @@ toWaiApp' y segments env = do
let exp' = getExpires $ clientSessionDuration y let exp' = getExpires $ clientSessionDuration y
let host = W.remoteHost env let host = W.remoteHost env
let session' = fromMaybe [] $ do let session' = fromMaybe [] $ do
raw <- lookup W.Cookie $ W.requestHeaders env raw <- lookup "Cookie" $ W.requestHeaders env
val <- lookup (B.pack sessionName) $ parseCookies raw val <- lookup (B.pack sessionName) $ parseCookies raw
decodeSession key' now host val decodeSession key' now host val
let site = getSite let site = getSite
method = B.unpack $ W.methodToBS $ W.requestMethod env method = B.unpack $ W.requestMethod env
types = httpAccept env types = httpAccept env
pathSegments = filter (not . null) segments pathSegments = filter (not . null) segments
eurl = parsePathSegments site pathSegments eurl = parsePathSegments site pathSegments
@ -281,10 +283,8 @@ toWaiApp' y segments env = do
(S.toString sessionVal) (S.toString sessionVal)
: hs : hs
hs'' = map (headerToPair getExpires) hs' hs'' = map (headerToPair getExpires) hs'
hs''' = (W.ContentType, S.fromString ct) : hs'' hs''' = ("Content-Type", S.fromString ct) : hs''
return $ W.Response s hs''' $ case c of return $ W.Response s hs''' c
ContentFile fp -> Left fp
ContentEnum e -> Right $ W.Enumerator e
-- | Fully render a route to an absolute URL. Since Yesod does this for you -- | 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 -- 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 httpAccept = map B.unpack
. parseHttpAccept . parseHttpAccept
. fromMaybe B.empty . fromMaybe B.empty
. lookup W.Accept . lookup "Accept"
. W.requestHeaders . W.requestHeaders
-- | Runs an application with CGI if CGI variables are present (namely -- | Runs an application with CGI if CGI variables are present (namely
@ -347,10 +347,10 @@ parseWaiRequest :: W.Request
parseWaiRequest env session' = do parseWaiRequest env session' = do
let gets' = map (S.toString *** S.toString) let gets' = map (S.toString *** S.toString)
$ parseQueryString $ W.queryString env $ parseQueryString $ W.queryString env
let reqCookie = fromMaybe B.empty $ lookup W.Cookie let reqCookie = fromMaybe B.empty $ lookup "Cookie"
$ W.requestHeaders env $ W.requestHeaders env
cookies' = map (S.toString *** S.toString) $ parseCookies reqCookie 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 = map S.toString $ maybe [] parseHttpAccept acceptLang
langs' = case lookup langKey session' of langs' = case lookup langKey session' of
Nothing -> langs Nothing -> langs
@ -389,14 +389,14 @@ headerToPair :: (Int -> UTCTime) -- ^ minutes -> expiration time
-> (W.ResponseHeader, B.ByteString) -> (W.ResponseHeader, B.ByteString)
headerToPair getExpires (AddCookie minutes key value) = headerToPair getExpires (AddCookie minutes key value) =
let expires = getExpires minutes let expires = getExpires minutes
in (W.SetCookie, S.fromString in ("Set-Cookie", S.fromString
$ key ++ "=" ++ value ++"; path=/; expires=" $ key ++ "=" ++ value ++"; path=/; expires="
++ formatW3 expires) ++ formatW3 expires)
headerToPair _ (DeleteCookie key) = headerToPair _ (DeleteCookie key) =
(W.SetCookie, S.fromString $ ("Set-Cookie", S.fromString $
key ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT") key ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT")
headerToPair _ (Header key value) = headerToPair _ (Header key value) =
(W.responseHeaderFromBS $ S.fromString key, S.fromString value) (fromString key, S.fromString value)
encodeSession :: CS.Key encodeSession :: CS.Key
-> UTCTime -- ^ expire time -> UTCTime -- ^ expire time

24
Yesod/Handler.hs
View File

@ -240,11 +240,11 @@ runHandler handler mrender sroute tomr ma tosa = YesodApp $ \eh rr cts -> do
let hs' = headers hs let hs' = headers hs
return (getStatus e, hs', ct, c, sess) return (getStatus e, hs', ct, c, sess)
let sendFile' ct fp = let sendFile' ct fp =
return (W.Status200, headers [], ct, ContentFile fp, finalSession) return (W.status200, headers [], ct, W.ResponseFile fp, finalSession)
case contents of case contents of
HCContent a -> do HCContent a -> do
(ct, c) <- chooseRep a cts (ct, c) <- chooseRep a cts
return (W.Status200, headers [], ct, c, finalSession) return (W.status200, headers [], ct, c, finalSession)
HCError e -> handleError e HCError e -> handleError e
HCRedirect rt loc -> do HCRedirect rt loc -> do
let hs = Header "Location" loc : headers [] 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 :: ErrorResponse -> YesodApp
safeEh er = YesodApp $ \_ _ _ -> do safeEh er = YesodApp $ \_ _ _ -> do
liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er 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 to the given route.
redirect :: RedirectType -> Route master -> GHandler sub master a redirect :: RedirectType -> Route master -> GHandler sub master a
@ -373,7 +373,7 @@ notFound = failure NotFound
badMethod :: (RequestReader m, Failure ErrorResponse m) => m a badMethod :: (RequestReader m, Failure ErrorResponse m) => m a
badMethod = do badMethod = do
w <- waiRequest w <- waiRequest
failure $ BadMethod $ toString $ W.methodToBS $ W.requestMethod w failure $ BadMethod $ toString $ W.requestMethod w
-- | Return a 403 permission denied page. -- | Return a 403 permission denied page.
permissionDenied :: Failure ErrorResponse m => String -> m a permissionDenied :: Failure ErrorResponse m => String -> m a
@ -422,16 +422,16 @@ addHeader :: Header -> GHandler sub master ()
addHeader = GHandler . lift . lift . tell . (:) addHeader = GHandler . lift . lift . tell . (:)
getStatus :: ErrorResponse -> W.Status getStatus :: ErrorResponse -> W.Status
getStatus NotFound = W.Status404 getStatus NotFound = W.status404
getStatus (InternalError _) = W.Status500 getStatus (InternalError _) = W.status500
getStatus (InvalidArgs _) = W.Status400 getStatus (InvalidArgs _) = W.status400
getStatus (PermissionDenied _) = W.Status403 getStatus (PermissionDenied _) = W.status403
getStatus (BadMethod _) = W.Status405 getStatus (BadMethod _) = W.status405
getRedirectStatus :: RedirectType -> W.Status getRedirectStatus :: RedirectType -> W.Status
getRedirectStatus RedirectPermanent = W.Status301 getRedirectStatus RedirectPermanent = W.status301
getRedirectStatus RedirectTemporary = W.Status302 getRedirectStatus RedirectTemporary = W.status302
getRedirectStatus RedirectSeeOther = W.Status303 getRedirectStatus RedirectSeeOther = W.status303
-- | Different types of redirects. -- | Different types of redirects.
data RedirectType = RedirectPermanent data RedirectType = RedirectPermanent

4
yesod.cabal
View File

@ -22,8 +22,8 @@ flag buildtests
library library
build-depends: base >= 4 && < 5, build-depends: base >= 4 && < 5,
time >= 1.1.3 && < 1.2, time >= 1.1.3 && < 1.2,
wai >= 0.1.0 && < 0.2, wai >= 0.2.0 && < 0.3,
wai-extra >= 0.1.3.1 && < 0.2, wai-extra >= 0.2.0 && < 0.3,
authenticate >= 0.6.3 && < 0.7, authenticate >= 0.6.3 && < 0.7,
bytestring >= 0.9.1.4 && < 0.10, bytestring >= 0.9.1.4 && < 0.10,
directory >= 1 && < 1.1, directory >= 1 && < 1.1,