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
( -- * 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

24
Yesod/Dispatch.hs
View File

@ -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

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
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

4
yesod.cabal
View File

@ -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,