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

8
Yesod/Content.hs
View File

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

21
Yesod/Core.hs
View File

@ -27,6 +27,7 @@ module Yesod.Core
import Yesod.Content
import Yesod.Handler
import Control.Arrow ((***))
import qualified Paths_yesod_core
import Data.Version (showVersion)
import Yesod.Widget
@ -37,7 +38,6 @@ import Yesod.Internal.Session
import Yesod.Internal.Request
import Web.ClientSession (getKey, defaultKeyFile)
import qualified Web.ClientSession as CS
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import Data.Monoid
@ -45,7 +45,6 @@ import Control.Monad.Trans.RWS
import Text.Hamlet
import Text.Cassius
import Text.Julius
import Web.Routes
import Text.Blaze (preEscapedLazyText)
import Data.Text.Lazy.Builder (toLazyText)
import Data.Text.Lazy.Encoding (encodeUtf8)
@ -54,6 +53,9 @@ import Control.Monad.IO.Class (liftIO)
import Web.Cookie (parseCookies)
import qualified Data.Map as Map
import Data.Time
import Network.HTTP.Types (encodePath)
import qualified Data.Text as TS
import qualified Data.Ascii as A
#if GHC7
#define HAMLET hamlet
@ -188,10 +190,15 @@ class RenderRoute (Route a) => Yesod a where
-- be the inverse of 'splitPath'.
joinPath :: a
-> String -- ^ application root
-> [String] -- ^ path pieces
-> [String] -- ^ path pieces FIXME Text
-> [(String, String)] -- ^ query 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
-- 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
$ Map.toList
$ Map.insert nonceKey nonce sm
_ -> S.empty
_ -> mempty
hs' =
case mkey of
Nothing -> hs
@ -322,7 +329,7 @@ applyLayout' title body = fmap chooseRep $ defaultLayout $ do
defaultErrorHandler :: Yesod y => ErrorResponse -> GHandler sub y ChooseRep
defaultErrorHandler NotFound = do
r <- waiRequest
let path' = bsToChars $ W.pathInfo r
let path' = bsToChars $ W.rawPathInfo r
applyLayout' "Not Found"
#if GHC7
[hamlet|
@ -372,7 +379,7 @@ defaultErrorHandler (BadMethod m) =
[$hamlet|
#endif
<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.

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.Gzip
import qualified Data.ByteString.Char8 as B
import Data.ByteString.Lazy.Char8 ()
import Web.ClientSession
import Data.Char (isUpper)
import Web.Routes (decodePathInfo)
import qualified Data.Text as TS
-- | Generates URL datatype and site function for the given 'Resource's. This
-- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter.
@ -178,9 +176,7 @@ toWaiApp' :: (Yesod y, YesodDispatch y y)
-> Maybe Key
-> W.Application
toWaiApp' y key' env = do
let dropSlash ('/':x) = x
dropSlash x = x
let segments = decodePathInfo $ dropSlash $ B.unpack $ W.pathInfo env
let segments = map TS.unpack $ W.pathInfo env
case yesodDispatch y key' segments y id of
Just app -> app 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 qualified Network.Wai as W
import qualified Network.HTTP.Types as H
import Control.Failure (Failure (failure))
import Text.Hamlet
@ -128,7 +129,6 @@ import Control.Monad.IO.Peel (MonadPeelIO)
import Control.Monad.Trans.Peel (MonadTransPeel (peel), liftPeel)
import qualified Data.Map as Map
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import Data.ByteString (ByteString)
import Data.Enumerator (Iteratee (..))
import Network.Wai.Parse (parseHttpAccept)
@ -136,10 +136,11 @@ import Network.Wai.Parse (parseHttpAccept)
import Yesod.Content
import Data.Maybe (fromMaybe)
import Web.Cookie (SetCookie (..), renderSetCookie)
import Blaze.ByteString.Builder (toByteString)
import Data.Enumerator (run_, ($$))
import Control.Arrow (second, (***))
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.
type family Route a
@ -152,7 +153,7 @@ data HandlerData sub master = HandlerData
, handlerSub :: sub
, handlerMaster :: master
, 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
}
@ -264,14 +265,14 @@ newtype YesodApp = YesodApp
data YesodAppResult
= YARWai W.Response
| YARPlain W.Status [Header] ContentType Content SessionMap
| YARPlain H.Status [Header] ContentType Content SessionMap
data HandlerContents =
HCContent W.Status ChooseRep
HCContent H.Status ChooseRep
| HCError ErrorResponse
| HCSendFile ContentType FilePath
| HCRedirect RedirectType ByteString
| HCCreated ByteString
| HCRedirect RedirectType A.Ascii
| HCCreated A.Ascii
| HCWai W.Response
instance Error HandlerContents where
@ -363,7 +364,7 @@ runHandler handler mrender sroute tomr ma sa =
$ flip runReaderT hd
$ unGHandler handler
) (\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
yar <- unYesodApp (eh e) safeEh rr cts finalSession
case yar of
@ -372,7 +373,7 @@ runHandler handler mrender sroute tomr ma sa =
in return $ YARPlain (getStatus e) hs' ct c sess
YARWai _ -> return yar
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
HCContent status a -> do
(ct, c) <- liftIO $ chooseRep a cts
@ -389,7 +390,7 @@ runHandler handler mrender sroute tomr ma sa =
HCCreated loc -> do
let hs = Header "Location" loc : headers []
return $ YARPlain
(W.Status 201 (S8.pack "Created"))
H.status201
hs
typePlain
emptyContent
@ -406,7 +407,7 @@ safeEh :: ErrorResponse -> YesodApp
safeEh er = YesodApp $ \_ _ _ session -> do
liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er
return $ YARPlain
W.status500
H.status500
[]
typePlain
(toContent ("Internal Server Error" :: S.ByteString))
@ -422,10 +423,10 @@ redirectParams :: Monad mo
-> GGHandler sub master mo a
redirectParams rt url params = do
r <- getUrlRenderParams
redirectString rt $ S8.pack $ r url params
redirectString rt $ A.unsafeFromString $ r url params
-- | 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
ultDestKey :: String
@ -470,7 +471,7 @@ redirectUltDest :: Monad mo
redirectUltDest rt def = do
mdest <- lookupSession ultDestKey
deleteSession ultDestKey
maybe (redirect rt def) (redirectString rt . S8.pack) mdest
maybe (redirect rt def) (redirectString rt . A.unsafeFromString) mdest
msgKey :: String
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
-- status code.
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
-- | Bypass remaining handler code and output the given content with the given
-- 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
. chooseRep
@ -515,7 +516,7 @@ sendResponseStatus s = GHandler . lift . throwError . HCContent s
sendResponseCreated :: Monad mo => Route m -> GGHandler s m mo a
sendResponseCreated url = do
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
-- 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 = do
w <- waiRequest
failure $ BadMethod $ bsToChars $ W.requestMethod w
failure $ BadMethod $ W.requestMethod w
-- | Return a 403 permission denied page.
permissionDenied :: Failure ErrorResponse m => String -> m a
@ -547,29 +548,29 @@ invalidArgs = failure . InvalidArgs
-- | Set the cookie on the client.
setCookie :: Monad mo
=> Int -- ^ minutes to timeout
-> ByteString -- ^ key
-> ByteString -- ^ value
-> A.Ascii -- ^ key
-> A.Ascii -- ^ value
-> GGHandler sub master mo ()
setCookie a b = addHeader . AddCookie a b
-- | 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
-- | Set the language in the user session. Will show up in 'languages' on the
-- next request.
setLanguage :: Monad mo => String -> GGHandler sub master mo ()
setLanguage = setSession langKey
setLanguage = setSession (A.toString langKey)
-- | Set an arbitrary response header.
setHeader :: Monad mo
=> W.ResponseHeader -> ByteString -> GGHandler sub master mo ()
=> A.CIAscii -> A.Ascii -> GGHandler sub master mo ()
setHeader a = addHeader . Header a
-- | Set the Cache-Control header to indicate this response should be cached
-- for the given number of seconds.
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="
, show i
, ", public"
@ -587,7 +588,7 @@ alreadyExpired = setHeader "Expires" "Thu, 01 Jan 1970 05:05:05 GMT"
-- | Set an Expires header to the given date.
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.
--
@ -611,17 +612,17 @@ modSession f x = x { ghsSession = f $ ghsSession x }
addHeader :: Monad mo => Header -> GGHandler sub master mo ()
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 :: ErrorResponse -> H.Status
getStatus NotFound = H.status404
getStatus (InternalError _) = H.status500
getStatus (InvalidArgs _) = H.status400
getStatus (PermissionDenied _) = H.status403
getStatus (BadMethod _) = H.status405
getRedirectStatus :: RedirectType -> W.Status
getRedirectStatus RedirectPermanent = W.status301
getRedirectStatus RedirectTemporary = W.status302
getRedirectStatus RedirectSeeOther = W.status303
getRedirectStatus :: RedirectType -> H.Status
getRedirectStatus RedirectPermanent = H.status301
getRedirectStatus RedirectTemporary = H.status302
getRedirectStatus RedirectSeeOther = H.status303
-- | Different types of redirects.
data RedirectType = RedirectPermanent
@ -665,7 +666,7 @@ handlerToYAR y s toMasterRoute render errorHandler rr murl sessionMap h =
type HeaderRenderer = [Header]
-> ContentType
-> SessionMap
-> [(W.ResponseHeader, ByteString)]
-> [(A.CIAscii, A.Ascii)]
yarToResponse :: HeaderRenderer -> YesodAppResult -> W.Response
yarToResponse _ (YARWai a) = a
@ -679,7 +680,7 @@ yarToResponse renderHeaders (YARPlain s hs ct c sessionFinal) =
W.ResponseEnumerator $ \iter -> run_ $ e $$ iter s finalHeaders
where
finalHeaders = renderHeaders hs ct sessionFinal
finalHeaders' len = ("Content-Length", S8.pack $ show len)
finalHeaders' len = ("Content-Length", A.unsafeFromString $ show len)
: finalHeaders
{-
getExpires m = fromIntegral (m * 60) `addUTCTime` now
@ -703,16 +704,16 @@ yarToResponse renderHeaders (YARPlain s hs ct c sessionFinal) =
httpAccept :: W.Request -> [ContentType]
httpAccept = parseHttpAccept
. fromMaybe S.empty
. fromMaybe mempty
. lookup "Accept"
. W.requestHeaders
-- | Convert Header to a key/value pair.
headerToPair :: (Int -> UTCTime) -- ^ minutes -> expiration time
-> Header
-> (W.ResponseHeader, ByteString)
-> (A.CIAscii, A.Ascii)
headerToPair getExpires (AddCookie minutes key value) =
("Set-Cookie", toByteString $ renderSetCookie $ SetCookie
("Set-Cookie", A.fromAsciiBuilder $ renderSetCookie $ SetCookie
{ setCookieName = key
, setCookieValue = value
, setCookiePath = Just "/" -- FIXME make a config option, or use approot?
@ -721,7 +722,7 @@ headerToPair getExpires (AddCookie minutes key value) =
})
headerToPair _ (DeleteCookie key) =
( "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)

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.Encoding as LT
import qualified Network.Wai as W
import Data.Typeable (Typeable)
import Control.Exception (Exception)
import qualified Data.Ascii as A
import qualified Network.HTTP.Types as H
#if GHC7
#define HAMLET hamlet
#else
@ -66,19 +68,19 @@ data ErrorResponse =
| InternalError String
| InvalidArgs [String]
| PermissionDenied String
| BadMethod String
| BadMethod H.Method
deriving (Show, Eq, Typeable)
instance Exception ErrorResponse
----- header stuff
-- | Headers to be added to a 'Result'.
data Header =
AddCookie Int ByteString ByteString
| DeleteCookie ByteString
| Header W.ResponseHeader ByteString
AddCookie Int A.Ascii A.Ascii
| DeleteCookie A.Ascii
| Header A.CIAscii A.Ascii
deriving (Eq, Show)
langKey :: String
langKey :: A.Ascii
langKey = "_LANG"
data Location url = Local url | Remote String
@ -121,7 +123,7 @@ charsToBs = T.encodeUtf8 . T.pack
nonceKey :: String
nonceKey = "_NONCE"
sessionName :: ByteString
sessionName :: A.Ascii
sessionName = "_SESSION"
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 qualified Data.ByteString as S
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 y segments' env =
return $ W.responseLBS W.status301
return $ W.responseLBS status301
[ ("Content-Type", "text/plain")
, ("Location", S8.pack $ dest')
, ("Location", A.unsafeFromString $ dest')
] "Redirecting"
where
dest = joinPath y (approot y) segments' []
dest' =
if S.null (W.queryString env)
if S.null (W.rawQueryString env)
then dest
else dest ++ '?' : S8.unpack (W.queryString env)
else dest ++ '?' : S8.unpack (W.rawQueryString env)
mkYesodDispatch' :: [((String, Pieces), Maybe String)]
-> [((String, Pieces), Maybe String)]
@ -147,7 +149,7 @@ mkSimpleExp segments [] frontVars (master, sub, toMasterRoute, mkey, constr, met
onSuccess <- newName "onSuccess"
req <- newName "req"
badMethod' <- [|badMethod|]
rm <- [|S8.unpack . W.requestMethod|]
rm <- [|A.toString . W.requestMethod|]
let caseExp = rm `AppE` VarE req
yr <- [|yesodRunner|]
cr <- [|fmap chooseRep|]

20
Yesod/Internal/Request.hs
View File

@ -6,32 +6,32 @@ module Yesod.Internal.Request
import Yesod.Request
import Control.Arrow (first, (***))
import qualified Network.Wai.Parse as NWP
import Data.Maybe (fromMaybe)
import Yesod.Internal
import qualified Network.Wai as W
import qualified Data.ByteString as S
import System.Random (randomR, newStdGen)
import Web.Cookie (parseCookies)
import qualified Data.Ascii as A
import Data.Monoid (mempty)
parseWaiRequest :: W.Request
-> [(String, String)] -- ^ session
-> Maybe a
-> IO Request
parseWaiRequest env session' key' = do
let gets' = map (bsToChars *** bsToChars)
$ NWP.parseQueryString $ W.queryString env
let reqCookie = fromMaybe S.empty $ lookup "Cookie"
let gets' = map (bsToChars *** maybe "" bsToChars)
$ W.queryString env
let reqCookie = maybe mempty id $ lookup "Cookie"
$ W.requestHeaders env
cookies' = map (bsToChars *** bsToChars) $ parseCookies reqCookie
cookies' = parseCookies reqCookie
acceptLang = lookup "Accept-Language" $ W.requestHeaders env
langs = map bsToChars $ maybe [] NWP.parseHttpAccept acceptLang
langs' = case lookup langKey session' of
langs = map A.toString $ maybe [] NWP.parseHttpAccept acceptLang
langs' = case lookup (A.toString langKey) session' of
Nothing -> langs
Just x -> x : langs
langs'' = case lookup langKey cookies' of
Nothing -> langs'
Just x -> x : langs'
langs''' = case lookup langKey gets' of
Just x -> A.toString x : langs'
langs''' = case lookup (A.toString langKey) gets' of
Nothing -> langs''
Just x -> x : langs''
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.ByteString (ByteString)
import Control.Monad (guard)
import qualified Data.Ascii as A
encodeSession :: CS.Key
-> UTCTime -- ^ expire time
-> ByteString -- ^ remote host
-> [(String, String)] -- ^ session
-> ByteString -- ^ cookie value
-> A.Ascii -- ^ cookie value
encodeSession key expire rhost session' =
CS.encrypt key $ encode $ SessionCookie expire rhost session'
decodeSession :: CS.Key
-> UTCTime -- ^ current time
-> ByteString -- ^ remote host field
-> ByteString -- ^ cookie value
-> A.Ascii -- ^ cookie value
-> Maybe [(String, String)]
decodeSession key now rhost encrypted = do
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.Instances () -- I'm missing the instance Monad ((->) r
import Data.Maybe (listToMaybe)
import qualified Data.Ascii as A
type ParamName = String
type ParamValue = String
@ -92,7 +93,7 @@ data FileInfo = FileInfo
-- | The parsed request information.
data Request = Request
{ reqGetParams :: [(ParamName, ParamValue)]
, reqCookies :: [(ParamName, ParamValue)]
, reqCookies :: [(A.Ascii, A.Ascii)]
, reqWaiRequest :: W.Request
-- | Languages which the client supports.
, reqLangs :: [String]
@ -141,11 +142,11 @@ lookupFiles pn = do
return $ lookup' pn files
-- | Lookup for cookie data.
lookupCookie :: RequestReader m => ParamName -> m (Maybe ParamValue)
lookupCookie :: RequestReader m => A.Ascii -> m (Maybe A.Ascii)
lookupCookie = liftM listToMaybe . lookupCookies
-- | Lookup for cookie data.
lookupCookies :: RequestReader m => ParamName -> m [ParamValue]
lookupCookies :: RequestReader m => A.Ascii -> m [A.Ascii]
lookupCookies pn = do
rr <- getRequest
return $ lookup' pn $ reqCookies rr

13
yesod-core.cabal
View File

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