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

WAI 0.4

Browse Source
This commit is contained in:
Michael Snoyman 2011-03-10 11:32:43 +02:00
parent 77fee84f5d
commit 4bbbc78f2b
11 changed files with 112 additions and 99 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
Test/CleanPath.hs
View File

@ -13,6 +13,7 @@ import Test.Framework.Providers.HUnit
import Test.HUnit hiding (Test) import Test.HUnit hiding (Test)
import Network.Wai import Network.Wai
import Network.Wai.Test import Network.Wai.Test
import Network.HTTP.Types (status200, decodePathSegments)
import qualified Data.ByteString.Lazy.Char8 as L8 import qualified Data.ByteString.Lazy.Char8 as L8
@ -65,22 +66,23 @@ cleanPathTest = testGroup "Test.CleanPath"
runner f = toWaiApp Y >>= runSession f runner f = toWaiApp Y >>= runSession f
defaultRequest = Request defaultRequest = Request
{ pathInfo = "" { pathInfo = []
, requestHeaders = [] , requestHeaders = []
, queryString = "" , queryString = []
, rawQueryString = ""
, requestMethod = "GET" , requestMethod = "GET"
} }
removeTrailingSlash = runner $ do removeTrailingSlash = runner $ do
res <- request defaultRequest res <- request defaultRequest
{ pathInfo = "/foo/" { pathInfo = decodePathSegments "/foo/"
} }
assertStatus 301 res assertStatus 301 res
assertHeader "Location" "http://test/foo" res assertHeader "Location" "http://test/foo" res
noTrailingSlash = runner $ do noTrailingSlash = runner $ do
res <- request defaultRequest res <- request defaultRequest
{ pathInfo = "/foo" { pathInfo = decodePathSegments "/foo"
} }
assertStatus 200 res assertStatus 200 res
assertContentType "text/plain; charset=utf-8" res assertContentType "text/plain; charset=utf-8" res
@ -88,14 +90,14 @@ noTrailingSlash = runner $ do
addTrailingSlash = runner $ do addTrailingSlash = runner $ do
res <- request defaultRequest res <- request defaultRequest
{ pathInfo = "/bar" { pathInfo = decodePathSegments "/bar"
} }
assertStatus 301 res assertStatus 301 res
assertHeader "Location" "http://test/bar/" res assertHeader "Location" "http://test/bar/" res
hasTrailingSlash = runner $ do hasTrailingSlash = runner $ do
res <- request defaultRequest res <- request defaultRequest
{ pathInfo = "/bar/" { pathInfo = decodePathSegments "/bar/"
} }
assertStatus 200 res assertStatus 200 res
assertContentType "text/plain; charset=utf-8" res assertContentType "text/plain; charset=utf-8" res
@ -103,7 +105,7 @@ hasTrailingSlash = runner $ do
fooSomething = runner $ do fooSomething = runner $ do
res <- request defaultRequest res <- request defaultRequest
{ pathInfo = "/foo/something" { pathInfo = decodePathSegments "/foo/something"
} }
assertStatus 200 res assertStatus 200 res
assertContentType "text/plain; charset=utf-8" res assertContentType "text/plain; charset=utf-8" res
@ -111,7 +113,7 @@ fooSomething = runner $ do
subsiteDispatch = runner $ do subsiteDispatch = runner $ do
res <- request defaultRequest res <- request defaultRequest
{ pathInfo = "/subsite/1/2/3/" { pathInfo = decodePathSegments "/subsite/1/2/3/"
} }
assertStatus 200 res assertStatus 200 res
assertContentType "SUBSITE" res assertContentType "SUBSITE" res

8
Yesod/Content.hs
View File

@ -44,7 +44,6 @@ module Yesod.Content
import Data.Maybe (mapMaybe) import Data.Maybe (mapMaybe)
import qualified Data.ByteString as B import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import Data.Text.Lazy (Text, pack) import Data.Text.Lazy (Text, pack)
import qualified Data.Text as T import qualified Data.Text as T
@ -62,6 +61,7 @@ import Data.Monoid (mempty)
import Text.Hamlet (Html) import Text.Hamlet (Html)
import Text.Blaze.Renderer.Utf8 (renderHtmlBuilder) import Text.Blaze.Renderer.Utf8 (renderHtmlBuilder)
import Data.String (IsString (fromString)) import Data.String (IsString (fromString))
import qualified Data.Ascii as A
data Content = ContentBuilder Builder (Maybe Int) -- ^ The content and optional content length. data Content = ContentBuilder Builder (Maybe Int) -- ^ The content and optional content length.
| ContentEnum (forall a. Enumerator Builder IO a) | ContentEnum (forall a. Enumerator Builder IO a)
@ -167,7 +167,7 @@ newtype RepXml = RepXml Content
instance HasReps RepXml where instance HasReps RepXml where
chooseRep (RepXml c) _ = return (typeXml, c) chooseRep (RepXml c) _ = return (typeXml, c)
type ContentType = B.ByteString type ContentType = A.Ascii
typeHtml :: ContentType typeHtml :: ContentType
typeHtml = "text/html; charset=utf-8" typeHtml = "text/html; charset=utf-8"
@ -216,8 +216,8 @@ typeOctet = "application/octet-stream"
-- --
-- For example, \"text/html; charset=utf-8\" is commonly used to specify the -- For example, \"text/html; charset=utf-8\" is commonly used to specify the
-- character encoding for HTML data. This function would return \"text/html\". -- character encoding for HTML data. This function would return \"text/html\".
simpleContentType :: B.ByteString -> B.ByteString simpleContentType :: A.Ascii -> A.Ascii
simpleContentType = S8.takeWhile (/= ';') simpleContentType = A.unsafeFromByteString . fst . B.breakByte 59 . A.toByteString -- 59 == ;
-- | Format a 'UTCTime' in W3 format. -- | Format a 'UTCTime' in W3 format.
formatW3 :: UTCTime -> String formatW3 :: UTCTime -> String

21
Yesod/Core.hs
View File

@ -27,6 +27,7 @@ module Yesod.Core
import Yesod.Content import Yesod.Content
import Yesod.Handler import Yesod.Handler
import Control.Arrow ((***))
import qualified Paths_yesod_core import qualified Paths_yesod_core
import Data.Version (showVersion) import Data.Version (showVersion)
import Yesod.Widget import Yesod.Widget
@ -37,7 +38,6 @@ import Yesod.Internal.Session
import Yesod.Internal.Request import Yesod.Internal.Request
import Web.ClientSession (getKey, defaultKeyFile) import Web.ClientSession (getKey, defaultKeyFile)
import qualified Web.ClientSession as CS import qualified Web.ClientSession as CS
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import Data.Monoid import Data.Monoid
@ -45,7 +45,6 @@ import Control.Monad.Trans.RWS
import Text.Hamlet import Text.Hamlet
import Text.Cassius import Text.Cassius
import Text.Julius import Text.Julius
import Web.Routes
import Text.Blaze (preEscapedLazyText) import Text.Blaze (preEscapedLazyText)
import Data.Text.Lazy.Builder (toLazyText) import Data.Text.Lazy.Builder (toLazyText)
import Data.Text.Lazy.Encoding (encodeUtf8) import Data.Text.Lazy.Encoding (encodeUtf8)
@ -54,6 +53,9 @@ import Control.Monad.IO.Class (liftIO)
import Web.Cookie (parseCookies) import Web.Cookie (parseCookies)
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Time import Data.Time
import Network.HTTP.Types (encodePath)
import qualified Data.Text as TS
import qualified Data.Ascii as A
#if GHC7 #if GHC7
#define HAMLET hamlet #define HAMLET hamlet
@ -188,10 +190,15 @@ class RenderRoute (Route a) => Yesod a where
-- be the inverse of 'splitPath'. -- be the inverse of 'splitPath'.
joinPath :: a joinPath :: a
-> String -- ^ application root -> String -- ^ application root
-> [String] -- ^ path pieces -> [String] -- ^ path pieces FIXME Text
-> [(String, String)] -- ^ query string -> [(String, String)] -- ^ query string
-> String -> String
joinPath _ ar pieces qs = ar ++ '/' : encodePathInfo pieces qs joinPath _ ar pieces qs' =
ar ++ A.toString (A.fromAsciiBuilder $ encodePath (map TS.pack pieces) qs)
where
qs = map (charsToBs *** go) qs'
go "" = Nothing
go x = Just $ charsToBs x
-- | This function is used to store some static content to be served as an -- | This function is used to store some static content to be served as an
-- external file. The most common case of this is stashing CSS and -- external file. The most common case of this is stashing CSS and
@ -268,7 +275,7 @@ defaultYesodRunner s master toMasterRoute mkey murl handler req = do
-> encodeSession key exp' host -> encodeSession key exp' host
$ Map.toList $ Map.toList
$ Map.insert nonceKey nonce sm $ Map.insert nonceKey nonce sm
_ -> S.empty _ -> mempty
hs' = hs' =
case mkey of case mkey of
Nothing -> hs Nothing -> hs
@ -322,7 +329,7 @@ applyLayout' title body = fmap chooseRep $ defaultLayout $ do
defaultErrorHandler :: Yesod y => ErrorResponse -> GHandler sub y ChooseRep defaultErrorHandler :: Yesod y => ErrorResponse -> GHandler sub y ChooseRep
defaultErrorHandler NotFound = do defaultErrorHandler NotFound = do
r <- waiRequest r <- waiRequest
let path' = bsToChars $ W.pathInfo r let path' = bsToChars $ W.rawPathInfo r
applyLayout' "Not Found" applyLayout' "Not Found"
#if GHC7 #if GHC7
[hamlet| [hamlet|
@ -372,7 +379,7 @@ defaultErrorHandler (BadMethod m) =
[$hamlet| [$hamlet|
#endif #endif
<h1>Method Not Supported <h1>Method Not Supported
<p>Method "#{m}" not supported <p>Method "#{A.toText m}" not supported
|] |]
-- | Return the same URL if the user is authorized to see it. -- | Return the same URL if the user is authorized to see it.

8
Yesod/Dispatch.hs
View File

@ -35,13 +35,11 @@ import qualified Network.Wai as W
import Network.Wai.Middleware.Jsonp import Network.Wai.Middleware.Jsonp
import Network.Wai.Middleware.Gzip import Network.Wai.Middleware.Gzip
import qualified Data.ByteString.Char8 as B
import Data.ByteString.Lazy.Char8 () import Data.ByteString.Lazy.Char8 ()
import Web.ClientSession import Web.ClientSession
import Data.Char (isUpper) import Data.Char (isUpper)
import qualified Data.Text as TS
import Web.Routes (decodePathInfo)
-- | Generates URL datatype and site function for the given 'Resource's. This -- | Generates URL datatype and site function for the given 'Resource's. This
-- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter. -- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter.
@ -178,9 +176,7 @@ toWaiApp' :: (Yesod y, YesodDispatch y y)
-> Maybe Key -> Maybe Key
-> W.Application -> W.Application
toWaiApp' y key' env = do toWaiApp' y key' env = do
let dropSlash ('/':x) = x let segments = map TS.unpack $ W.pathInfo env
dropSlash x = x
let segments = decodePathInfo $ dropSlash $ B.unpack $ W.pathInfo env
case yesodDispatch y key' segments y id of case yesodDispatch y key' segments y id of
Just app -> app env Just app -> app env
Nothing -> yesodRunner y y id key' Nothing notFound env Nothing -> yesodRunner y y id key' Nothing notFound env

83
Yesod/Handler.hs
View File

@ -120,6 +120,7 @@ import Control.Monad.Trans.Error (throwError, ErrorT (..), Error (..))
import System.IO import System.IO
import qualified Network.Wai as W import qualified Network.Wai as W
import qualified Network.HTTP.Types as H
import Control.Failure (Failure (failure)) import Control.Failure (Failure (failure))
import Text.Hamlet import Text.Hamlet
@ -128,7 +129,6 @@ import Control.Monad.IO.Peel (MonadPeelIO)
import Control.Monad.Trans.Peel (MonadTransPeel (peel), liftPeel) import Control.Monad.Trans.Peel (MonadTransPeel (peel), liftPeel)
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.ByteString as S import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Data.Enumerator (Iteratee (..)) import Data.Enumerator (Iteratee (..))
import Network.Wai.Parse (parseHttpAccept) import Network.Wai.Parse (parseHttpAccept)
@ -136,10 +136,11 @@ import Network.Wai.Parse (parseHttpAccept)
import Yesod.Content import Yesod.Content
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Web.Cookie (SetCookie (..), renderSetCookie) import Web.Cookie (SetCookie (..), renderSetCookie)
import Blaze.ByteString.Builder (toByteString)
import Data.Enumerator (run_, ($$)) import Data.Enumerator (run_, ($$))
import Control.Arrow (second, (***)) import Control.Arrow (second, (***))
import qualified Network.Wai.Parse as NWP import qualified Network.Wai.Parse as NWP
import qualified Data.Ascii as A
import Data.Monoid (mappend, mempty)
-- | The type-safe URLs associated with a site argument. -- | The type-safe URLs associated with a site argument.
type family Route a type family Route a
@ -152,7 +153,7 @@ data HandlerData sub master = HandlerData
, handlerSub :: sub , handlerSub :: sub
, handlerMaster :: master , handlerMaster :: master
, handlerRoute :: Maybe (Route sub) , handlerRoute :: Maybe (Route sub)
, handlerRender :: (Route master -> [(String, String)] -> String) , handlerRender :: (Route master -> [(String, String)] -> String) -- FIXME replace output String with Ascii
, handlerToMaster :: Route sub -> Route master , handlerToMaster :: Route sub -> Route master
} }
@ -264,14 +265,14 @@ newtype YesodApp = YesodApp
data YesodAppResult data YesodAppResult
= YARWai W.Response = YARWai W.Response
| YARPlain W.Status [Header] ContentType Content SessionMap | YARPlain H.Status [Header] ContentType Content SessionMap
data HandlerContents = data HandlerContents =
HCContent W.Status ChooseRep HCContent H.Status ChooseRep
| HCError ErrorResponse | HCError ErrorResponse
| HCSendFile ContentType FilePath | HCSendFile ContentType FilePath
| HCRedirect RedirectType ByteString | HCRedirect RedirectType A.Ascii
| HCCreated ByteString | HCCreated A.Ascii
| HCWai W.Response | HCWai W.Response
instance Error HandlerContents where instance Error HandlerContents where
@ -363,7 +364,7 @@ runHandler handler mrender sroute tomr ma sa =
$ flip runReaderT hd $ flip runReaderT hd
$ unGHandler handler $ unGHandler handler
) (\e -> return ((Left $ HCError $ toErrorHandler e, id), initSession)) ) (\e -> return ((Left $ HCError $ toErrorHandler e, id), initSession))
let contents = either id (HCContent W.status200 . chooseRep) contents' let contents = either id (HCContent H.status200 . chooseRep) contents'
let handleError e = do let handleError e = do
yar <- unYesodApp (eh e) safeEh rr cts finalSession yar <- unYesodApp (eh e) safeEh rr cts finalSession
case yar of case yar of
@ -372,7 +373,7 @@ runHandler handler mrender sroute tomr ma sa =
in return $ YARPlain (getStatus e) hs' ct c sess in return $ YARPlain (getStatus e) hs' ct c sess
YARWai _ -> return yar YARWai _ -> return yar
let sendFile' ct fp = let sendFile' ct fp =
return $ YARPlain W.status200 (headers []) ct (ContentFile fp) finalSession return $ YARPlain H.status200 (headers []) ct (ContentFile fp) finalSession
case contents of case contents of
HCContent status a -> do HCContent status a -> do
(ct, c) <- liftIO $ chooseRep a cts (ct, c) <- liftIO $ chooseRep a cts
@ -389,7 +390,7 @@ runHandler handler mrender sroute tomr ma sa =
HCCreated loc -> do HCCreated loc -> do
let hs = Header "Location" loc : headers [] let hs = Header "Location" loc : headers []
return $ YARPlain return $ YARPlain
(W.Status 201 (S8.pack "Created")) H.status201
hs hs
typePlain typePlain
emptyContent emptyContent
@ -406,7 +407,7 @@ safeEh :: ErrorResponse -> YesodApp
safeEh er = YesodApp $ \_ _ _ session -> do safeEh er = YesodApp $ \_ _ _ session -> do
liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er
return $ YARPlain return $ YARPlain
W.status500 H.status500
[] []
typePlain typePlain
(toContent ("Internal Server Error" :: S.ByteString)) (toContent ("Internal Server Error" :: S.ByteString))
@ -422,10 +423,10 @@ redirectParams :: Monad mo
-> GGHandler sub master mo a -> GGHandler sub master mo a
redirectParams rt url params = do redirectParams rt url params = do
r <- getUrlRenderParams r <- getUrlRenderParams
redirectString rt $ S8.pack $ r url params redirectString rt $ A.unsafeFromString $ r url params
-- | Redirect to the given URL. -- | Redirect to the given URL.
redirectString :: Monad mo => RedirectType -> ByteString -> GGHandler sub master mo a redirectString :: Monad mo => RedirectType -> A.Ascii -> GGHandler sub master mo a
redirectString rt = GHandler . lift . throwError . HCRedirect rt redirectString rt = GHandler . lift . throwError . HCRedirect rt
ultDestKey :: String ultDestKey :: String
@ -470,7 +471,7 @@ redirectUltDest :: Monad mo
redirectUltDest rt def = do redirectUltDest rt def = do
mdest <- lookupSession ultDestKey mdest <- lookupSession ultDestKey
deleteSession ultDestKey deleteSession ultDestKey
maybe (redirect rt def) (redirectString rt . S8.pack) mdest maybe (redirect rt def) (redirectString rt . A.unsafeFromString) mdest
msgKey :: String msgKey :: String
msgKey = "_MSG" msgKey = "_MSG"
@ -501,12 +502,12 @@ sendFile ct = GHandler . lift . throwError . HCSendFile ct
-- | Bypass remaining handler code and output the given content with a 200 -- | Bypass remaining handler code and output the given content with a 200
-- status code. -- status code.
sendResponse :: (Monad mo, HasReps c) => c -> GGHandler sub master mo a sendResponse :: (Monad mo, HasReps c) => c -> GGHandler sub master mo a
sendResponse = GHandler . lift . throwError . HCContent W.status200 sendResponse = GHandler . lift . throwError . HCContent H.status200
. chooseRep . chooseRep
-- | Bypass remaining handler code and output the given content with the given -- | Bypass remaining handler code and output the given content with the given
-- status code. -- status code.
sendResponseStatus :: (Monad mo, HasReps c) => W.Status -> c -> GGHandler s m mo a sendResponseStatus :: (Monad mo, HasReps c) => H.Status -> c -> GGHandler s m mo a
sendResponseStatus s = GHandler . lift . throwError . HCContent s sendResponseStatus s = GHandler . lift . throwError . HCContent s
. chooseRep . chooseRep
@ -515,7 +516,7 @@ sendResponseStatus s = GHandler . lift . throwError . HCContent s
sendResponseCreated :: Monad mo => Route m -> GGHandler s m mo a sendResponseCreated :: Monad mo => Route m -> GGHandler s m mo a
sendResponseCreated url = do sendResponseCreated url = do
r <- getUrlRender r <- getUrlRender
GHandler $ lift $ throwError $ HCCreated $ S8.pack $ r url GHandler $ lift $ throwError $ HCCreated $ A.unsafeFromString $ r url
-- | Send a 'W.Response'. Please note: this function is rarely -- | Send a 'W.Response'. Please note: this function is rarely
-- necessary, and will /disregard/ any changes to response headers and session -- necessary, and will /disregard/ any changes to response headers and session
@ -533,7 +534,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 $ bsToChars $ W.requestMethod w failure $ BadMethod $ 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
@ -547,29 +548,29 @@ invalidArgs = failure . InvalidArgs
-- | Set the cookie on the client. -- | Set the cookie on the client.
setCookie :: Monad mo setCookie :: Monad mo
=> Int -- ^ minutes to timeout => Int -- ^ minutes to timeout
-> ByteString -- ^ key -> A.Ascii -- ^ key
-> ByteString -- ^ value -> A.Ascii -- ^ value
-> GGHandler sub master mo () -> GGHandler sub master mo ()
setCookie a b = addHeader . AddCookie a b setCookie a b = addHeader . AddCookie a b
-- | Unset the cookie on the client. -- | Unset the cookie on the client.
deleteCookie :: Monad mo => ByteString -> GGHandler sub master mo () deleteCookie :: Monad mo => A.Ascii -> GGHandler sub master mo ()
deleteCookie = addHeader . DeleteCookie deleteCookie = addHeader . DeleteCookie
-- | Set the language in the user session. Will show up in 'languages' on the -- | Set the language in the user session. Will show up in 'languages' on the
-- next request. -- next request.
setLanguage :: Monad mo => String -> GGHandler sub master mo () setLanguage :: Monad mo => String -> GGHandler sub master mo ()
setLanguage = setSession langKey setLanguage = setSession (A.toString langKey)
-- | Set an arbitrary response header. -- | Set an arbitrary response header.
setHeader :: Monad mo setHeader :: Monad mo
=> W.ResponseHeader -> ByteString -> GGHandler sub master mo () => A.CIAscii -> A.Ascii -> GGHandler sub master mo ()
setHeader a = addHeader . Header a setHeader a = addHeader . Header a
-- | Set the Cache-Control header to indicate this response should be cached -- | Set the Cache-Control header to indicate this response should be cached
-- for the given number of seconds. -- for the given number of seconds.
cacheSeconds :: Monad mo => Int -> GGHandler s m mo () cacheSeconds :: Monad mo => Int -> GGHandler s m mo ()
cacheSeconds i = setHeader "Cache-Control" $ S8.pack $ concat cacheSeconds i = setHeader "Cache-Control" $ A.unsafeFromString $ concat
[ "max-age=" [ "max-age="
, show i , show i
, ", public" , ", public"
@ -587,7 +588,7 @@ alreadyExpired = setHeader "Expires" "Thu, 01 Jan 1970 05:05:05 GMT"
-- | Set an Expires header to the given date. -- | Set an Expires header to the given date.
expiresAt :: Monad mo => UTCTime -> GGHandler s m mo () expiresAt :: Monad mo => UTCTime -> GGHandler s m mo ()
expiresAt = setHeader "Expires" . S8.pack . formatRFC1123 expiresAt = setHeader "Expires" . A.unsafeFromString . formatRFC1123
-- | Set a variable in the user's session. -- | Set a variable in the user's session.
-- --
@ -611,17 +612,17 @@ modSession f x = x { ghsSession = f $ ghsSession x }
addHeader :: Monad mo => Header -> GGHandler sub master mo () addHeader :: Monad mo => Header -> GGHandler sub master mo ()
addHeader = GHandler . lift . lift . tell . (:) addHeader = GHandler . lift . lift . tell . (:)
getStatus :: ErrorResponse -> W.Status getStatus :: ErrorResponse -> H.Status
getStatus NotFound = W.status404 getStatus NotFound = H.status404
getStatus (InternalError _) = W.status500 getStatus (InternalError _) = H.status500
getStatus (InvalidArgs _) = W.status400 getStatus (InvalidArgs _) = H.status400
getStatus (PermissionDenied _) = W.status403 getStatus (PermissionDenied _) = H.status403
getStatus (BadMethod _) = W.status405 getStatus (BadMethod _) = H.status405
getRedirectStatus :: RedirectType -> W.Status getRedirectStatus :: RedirectType -> H.Status
getRedirectStatus RedirectPermanent = W.status301 getRedirectStatus RedirectPermanent = H.status301
getRedirectStatus RedirectTemporary = W.status302 getRedirectStatus RedirectTemporary = H.status302
getRedirectStatus RedirectSeeOther = W.status303 getRedirectStatus RedirectSeeOther = H.status303
-- | Different types of redirects. -- | Different types of redirects.
data RedirectType = RedirectPermanent data RedirectType = RedirectPermanent
@ -665,7 +666,7 @@ handlerToYAR y s toMasterRoute render errorHandler rr murl sessionMap h =
type HeaderRenderer = [Header] type HeaderRenderer = [Header]
-> ContentType -> ContentType
-> SessionMap -> SessionMap
-> [(W.ResponseHeader, ByteString)] -> [(A.CIAscii, A.Ascii)]
yarToResponse :: HeaderRenderer -> YesodAppResult -> W.Response yarToResponse :: HeaderRenderer -> YesodAppResult -> W.Response
yarToResponse _ (YARWai a) = a yarToResponse _ (YARWai a) = a
@ -679,7 +680,7 @@ yarToResponse renderHeaders (YARPlain s hs ct c sessionFinal) =
W.ResponseEnumerator $ \iter -> run_ $ e $$ iter s finalHeaders W.ResponseEnumerator $ \iter -> run_ $ e $$ iter s finalHeaders
where where
finalHeaders = renderHeaders hs ct sessionFinal finalHeaders = renderHeaders hs ct sessionFinal
finalHeaders' len = ("Content-Length", S8.pack $ show len) finalHeaders' len = ("Content-Length", A.unsafeFromString $ show len)
: finalHeaders : finalHeaders
{- {-
getExpires m = fromIntegral (m * 60) `addUTCTime` now getExpires m = fromIntegral (m * 60) `addUTCTime` now
@ -703,16 +704,16 @@ yarToResponse renderHeaders (YARPlain s hs ct c sessionFinal) =
httpAccept :: W.Request -> [ContentType] httpAccept :: W.Request -> [ContentType]
httpAccept = parseHttpAccept httpAccept = parseHttpAccept
. fromMaybe S.empty . fromMaybe mempty
. lookup "Accept" . lookup "Accept"
. W.requestHeaders . W.requestHeaders
-- | Convert Header to a key/value pair. -- | Convert Header to a key/value pair.
headerToPair :: (Int -> UTCTime) -- ^ minutes -> expiration time headerToPair :: (Int -> UTCTime) -- ^ minutes -> expiration time
-> Header -> Header
-> (W.ResponseHeader, ByteString) -> (A.CIAscii, A.Ascii)
headerToPair getExpires (AddCookie minutes key value) = headerToPair getExpires (AddCookie minutes key value) =
("Set-Cookie", toByteString $ renderSetCookie $ SetCookie ("Set-Cookie", A.fromAsciiBuilder $ renderSetCookie $ SetCookie
{ setCookieName = key { setCookieName = key
, setCookieValue = value , setCookieValue = value
, setCookiePath = Just "/" -- FIXME make a config option, or use approot? , setCookiePath = Just "/" -- FIXME make a config option, or use approot?
@ -721,7 +722,7 @@ headerToPair getExpires (AddCookie minutes key value) =
}) })
headerToPair _ (DeleteCookie key) = headerToPair _ (DeleteCookie key) =
( "Set-Cookie" ( "Set-Cookie"
, key `S.append` "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT" , key `mappend` "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT"
) )
headerToPair _ (Header key value) = (key, value) headerToPair _ (Header key value) = (key, value)

16
Yesod/Internal.hs
View File

@ -49,10 +49,12 @@ import qualified Data.Text.Encoding.Error as T
import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Encoding as LT import qualified Data.Text.Lazy.Encoding as LT
import qualified Network.Wai as W
import Data.Typeable (Typeable) import Data.Typeable (Typeable)
import Control.Exception (Exception) import Control.Exception (Exception)
import qualified Data.Ascii as A
import qualified Network.HTTP.Types as H
#if GHC7 #if GHC7
#define HAMLET hamlet #define HAMLET hamlet
#else #else
@ -66,19 +68,19 @@ data ErrorResponse =
| InternalError String | InternalError String
| InvalidArgs [String] | InvalidArgs [String]
| PermissionDenied String | PermissionDenied String
| BadMethod String | BadMethod H.Method
deriving (Show, Eq, Typeable) deriving (Show, Eq, Typeable)
instance Exception ErrorResponse instance Exception ErrorResponse
----- header stuff ----- header stuff
-- | Headers to be added to a 'Result'. -- | Headers to be added to a 'Result'.
data Header = data Header =
AddCookie Int ByteString ByteString AddCookie Int A.Ascii A.Ascii
| DeleteCookie ByteString | DeleteCookie A.Ascii
| Header W.ResponseHeader ByteString | Header A.CIAscii A.Ascii
deriving (Eq, Show) deriving (Eq, Show)
langKey :: String langKey :: A.Ascii
langKey = "_LANG" langKey = "_LANG"
data Location url = Local url | Remote String data Location url = Local url | Remote String
@ -121,7 +123,7 @@ charsToBs = T.encodeUtf8 . T.pack
nonceKey :: String nonceKey :: String
nonceKey = "_NONCE" nonceKey = "_NONCE"
sessionName :: ByteString sessionName :: A.Ascii
sessionName = "_SESSION" sessionName = "_SESSION"
data GWData a = GWData data GWData a = GWData

12
Yesod/Internal/Dispatch.hs
View File

@ -21,6 +21,8 @@ import qualified Data.ByteString.Char8 as S8
import Data.ByteString.Lazy.Char8 () import Data.ByteString.Lazy.Char8 ()
import qualified Data.ByteString as S import qualified Data.ByteString as S
import Yesod.Core (Yesod (joinPath, approot, cleanPath)) import Yesod.Core (Yesod (joinPath, approot, cleanPath))
import Network.HTTP.Types (status301)
import qualified Data.Ascii as A
{-| {-|
@ -77,16 +79,16 @@ local routes.
sendRedirect :: Yesod master => master -> [String] -> W.Application sendRedirect :: Yesod master => master -> [String] -> W.Application
sendRedirect y segments' env = sendRedirect y segments' env =
return $ W.responseLBS W.status301 return $ W.responseLBS status301
[ ("Content-Type", "text/plain") [ ("Content-Type", "text/plain")
, ("Location", S8.pack $ dest') , ("Location", A.unsafeFromString $ dest')
] "Redirecting" ] "Redirecting"
where where
dest = joinPath y (approot y) segments' [] dest = joinPath y (approot y) segments' []
dest' = dest' =
if S.null (W.queryString env) if S.null (W.rawQueryString env)
then dest then dest
else dest ++ '?' : S8.unpack (W.queryString env) else dest ++ '?' : S8.unpack (W.rawQueryString env)
mkYesodDispatch' :: [((String, Pieces), Maybe String)] mkYesodDispatch' :: [((String, Pieces), Maybe String)]
-> [((String, Pieces), Maybe String)] -> [((String, Pieces), Maybe String)]
@ -147,7 +149,7 @@ mkSimpleExp segments [] frontVars (master, sub, toMasterRoute, mkey, constr, met
onSuccess <- newName "onSuccess" onSuccess <- newName "onSuccess"
req <- newName "req" req <- newName "req"
badMethod' <- [|badMethod|] badMethod' <- [|badMethod|]
rm <- [|S8.unpack . W.requestMethod|] rm <- [|A.toString . W.requestMethod|]
let caseExp = rm `AppE` VarE req let caseExp = rm `AppE` VarE req
yr <- [|yesodRunner|] yr <- [|yesodRunner|]
cr <- [|fmap chooseRep|] cr <- [|fmap chooseRep|]

20
Yesod/Internal/Request.hs
View File

@ -6,32 +6,32 @@ module Yesod.Internal.Request
import Yesod.Request import Yesod.Request
import Control.Arrow (first, (***)) import Control.Arrow (first, (***))
import qualified Network.Wai.Parse as NWP import qualified Network.Wai.Parse as NWP
import Data.Maybe (fromMaybe)
import Yesod.Internal import Yesod.Internal
import qualified Network.Wai as W import qualified Network.Wai as W
import qualified Data.ByteString as S
import System.Random (randomR, newStdGen) import System.Random (randomR, newStdGen)
import Web.Cookie (parseCookies) import Web.Cookie (parseCookies)
import qualified Data.Ascii as A
import Data.Monoid (mempty)
parseWaiRequest :: W.Request parseWaiRequest :: W.Request
-> [(String, String)] -- ^ session -> [(String, String)] -- ^ session
-> Maybe a -> Maybe a
-> IO Request -> IO Request
parseWaiRequest env session' key' = do parseWaiRequest env session' key' = do
let gets' = map (bsToChars *** bsToChars) let gets' = map (bsToChars *** maybe "" bsToChars)
$ NWP.parseQueryString $ W.queryString env $ W.queryString env
let reqCookie = fromMaybe S.empty $ lookup "Cookie" let reqCookie = maybe mempty id $ lookup "Cookie"
$ W.requestHeaders env $ W.requestHeaders env
cookies' = map (bsToChars *** bsToChars) $ parseCookies reqCookie cookies' = parseCookies reqCookie
acceptLang = lookup "Accept-Language" $ W.requestHeaders env acceptLang = lookup "Accept-Language" $ W.requestHeaders env
langs = map bsToChars $ maybe [] NWP.parseHttpAccept acceptLang langs = map A.toString $ maybe [] NWP.parseHttpAccept acceptLang
langs' = case lookup langKey session' of langs' = case lookup (A.toString langKey) session' of
Nothing -> langs Nothing -> langs
Just x -> x : langs Just x -> x : langs
langs'' = case lookup langKey cookies' of langs'' = case lookup langKey cookies' of
Nothing -> langs' Nothing -> langs'
Just x -> x : langs' Just x -> A.toString x : langs'
langs''' = case lookup langKey gets' of langs''' = case lookup (A.toString langKey) gets' of
Nothing -> langs'' Nothing -> langs''
Just x -> x : langs'' Just x -> x : langs''
nonce <- case (key', lookup nonceKey session') of nonce <- case (key', lookup nonceKey session') of

5
Yesod/Internal/Session.hs
View File

@ -8,19 +8,20 @@ import Data.Serialize
import Data.Time import Data.Time
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Control.Monad (guard) import Control.Monad (guard)
import qualified Data.Ascii as A
encodeSession :: CS.Key encodeSession :: CS.Key
-> UTCTime -- ^ expire time -> UTCTime -- ^ expire time
-> ByteString -- ^ remote host -> ByteString -- ^ remote host
-> [(String, String)] -- ^ session -> [(String, String)] -- ^ session
-> ByteString -- ^ cookie value -> A.Ascii -- ^ cookie value
encodeSession key expire rhost session' = encodeSession key expire rhost session' =
CS.encrypt key $ encode $ SessionCookie expire rhost session' CS.encrypt key $ encode $ SessionCookie expire rhost session'
decodeSession :: CS.Key decodeSession :: CS.Key
-> UTCTime -- ^ current time -> UTCTime -- ^ current time
-> ByteString -- ^ remote host field -> ByteString -- ^ remote host field
-> ByteString -- ^ cookie value -> A.Ascii -- ^ cookie value
-> Maybe [(String, String)] -> Maybe [(String, String)]
decodeSession key now rhost encrypted = do decodeSession key now rhost encrypted = do
decrypted <- CS.decrypt key encrypted decrypted <- CS.decrypt key encrypted

7
Yesod/Request.hs
View File

@ -43,6 +43,7 @@ import Control.Monad.IO.Class
import Control.Monad (liftM) import Control.Monad (liftM)
import Control.Monad.Instances () -- I'm missing the instance Monad ((->) r import Control.Monad.Instances () -- I'm missing the instance Monad ((->) r
import Data.Maybe (listToMaybe) import Data.Maybe (listToMaybe)
import qualified Data.Ascii as A
type ParamName = String type ParamName = String
type ParamValue = String type ParamValue = String
@ -92,7 +93,7 @@ data FileInfo = FileInfo
-- | The parsed request information. -- | The parsed request information.
data Request = Request data Request = Request
{ reqGetParams :: [(ParamName, ParamValue)] { reqGetParams :: [(ParamName, ParamValue)]
, reqCookies :: [(ParamName, ParamValue)] , reqCookies :: [(A.Ascii, A.Ascii)]
, reqWaiRequest :: W.Request , reqWaiRequest :: W.Request
-- | Languages which the client supports. -- | Languages which the client supports.
, reqLangs :: [String] , reqLangs :: [String]
@ -141,11 +142,11 @@ lookupFiles pn = do
return $ lookup' pn files return $ lookup' pn files
-- | Lookup for cookie data. -- | Lookup for cookie data.
lookupCookie :: RequestReader m => ParamName -> m (Maybe ParamValue) lookupCookie :: RequestReader m => A.Ascii -> m (Maybe A.Ascii)
lookupCookie = liftM listToMaybe . lookupCookies lookupCookie = liftM listToMaybe . lookupCookies
-- | Lookup for cookie data. -- | Lookup for cookie data.
lookupCookies :: RequestReader m => ParamName -> m [ParamValue] lookupCookies :: RequestReader m => A.Ascii -> m [A.Ascii]
lookupCookies pn = do lookupCookies pn = do
rr <- getRequest rr <- getRequest
return $ lookup' pn $ reqCookies rr return $ lookup' pn $ reqCookies rr

13
yesod-core.cabal
View File

@ -1,5 +1,5 @@
name: yesod-core name: yesod-core
version: 0.7.0.2 version: 0.8.0
license: BSD3 license: BSD3
license-file: LICENSE license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com> author: Michael Snoyman <michael@snoyman.com>
@ -28,8 +28,8 @@ library
else else
build-depends: base >= 4 && < 4.3 build-depends: base >= 4 && < 4.3
build-depends: time >= 1.1.4 && < 1.3 build-depends: time >= 1.1.4 && < 1.3
, wai >= 0.3 && < 0.4 , wai >= 0.4 && < 0.5
, wai-extra >= 0.3 && < 0.4 , wai-extra >= 0.4 && < 0.5
, bytestring >= 0.9.1.4 && < 0.10 , bytestring >= 0.9.1.4 && < 0.10
, text >= 0.5 && < 0.12 , text >= 0.5 && < 0.12
, template-haskell , template-haskell
@ -37,17 +37,18 @@ library
, hamlet >= 0.7 && < 0.8 , hamlet >= 0.7 && < 0.8
, blaze-builder >= 0.2.1 && < 0.3 , blaze-builder >= 0.2.1 && < 0.3
, transformers >= 0.2 && < 0.3 , transformers >= 0.2 && < 0.3
, clientsession >= 0.4.0 && < 0.5 , clientsession >= 0.5 && < 0.6
, random >= 1.0.0.2 && < 1.1 , random >= 1.0.0.2 && < 1.1
, cereal >= 0.2 && < 0.4 , cereal >= 0.2 && < 0.4
, old-locale >= 1.0.0.2 && < 1.1 , old-locale >= 1.0.0.2 && < 1.1
, web-routes >= 0.23 && < 0.24
, failure >= 0.1 && < 0.2 , failure >= 0.1 && < 0.2
, containers >= 0.2 && < 0.5 , containers >= 0.2 && < 0.5
, monad-peel >= 0.1 && < 0.2 , monad-peel >= 0.1 && < 0.2
, enumerator >= 0.4 && < 0.5 , enumerator >= 0.4 && < 0.5
, cookie >= 0.0 && < 0.1 , cookie >= 0.1 && < 0.2
, blaze-html >= 0.4 && < 0.5 , blaze-html >= 0.4 && < 0.5
, ascii >= 0.0.2 && < 0.1
, http-types >= 0.5 && < 0.6
exposed-modules: Yesod.Content exposed-modules: Yesod.Content
Yesod.Core Yesod.Core
Yesod.Dispatch Yesod.Dispatch