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

Large-scale switch from String and Ascii to Text

Browse Source
This commit is contained in:
Michael Snoyman 2011-04-01 12:43:13 +03:00
parent 571ec80d16
commit b1abfd1a6a
9 changed files with 130 additions and 117 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
Yesod/Core.hs
View File

@ -46,7 +46,6 @@ import Text.Hamlet
import Text.Cassius import Text.Cassius
import Text.Julius import Text.Julius
import Text.Blaze (preEscapedLazyText, (!), customAttribute, textTag, toValue) import Text.Blaze (preEscapedLazyText, (!), customAttribute, textTag, toValue)
import qualified Data.Text as T
import qualified Text.Blaze.Html5 as TBH import qualified Text.Blaze.Html5 as TBH
import Data.Text.Lazy.Builder (toLazyText) import Data.Text.Lazy.Builder (toLazyText)
import Data.Text.Lazy.Encoding (encodeUtf8) import Data.Text.Lazy.Encoding (encodeUtf8)
@ -56,11 +55,11 @@ 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 Network.HTTP.Types (encodePath)
import qualified Network.HTTP.Types as H
import qualified Data.Text as TS import qualified Data.Text as TS
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text.Encoding as TE import qualified Data.Text.Encoding as TE
import Blaze.ByteString.Builder (Builder, fromByteString, toByteString) import Blaze.ByteString.Builder (Builder, toByteString)
import Blaze.ByteString.Builder.Char.Utf8 (fromText)
import Data.List (foldl') import Data.List (foldl')
#if GHC7 #if GHC7
@ -104,7 +103,7 @@ class RenderRoute (Route a) => Yesod a where
-- --
-- * You do not use any features that require absolute URLs, such as Atom -- * You do not use any features that require absolute URLs, such as Atom
-- feeds and XML sitemaps. -- feeds and XML sitemaps.
approot :: a -> H.Ascii approot :: a -> Text
-- | The encryption key to be used for encrypting client sessions. -- | The encryption key to be used for encrypting client sessions.
-- Returning 'Nothing' disables sessions. -- Returning 'Nothing' disables sessions.
@ -215,10 +214,10 @@ class RenderRoute (Route a) => Yesod a where
-- file, whereas a 'Just' 'Right' gives the type-safe URL. The former is -- file, whereas a 'Just' 'Right' gives the type-safe URL. The former is
-- necessary when you are serving the content outside the context of a -- necessary when you are serving the content outside the context of a
-- Yesod application, such as via memcached. -- Yesod application, such as via memcached.
addStaticContent :: String -- ^ filename extension addStaticContent :: Text -- ^ filename extension
-> String -- ^ mime-type -> Text -- ^ mime-type
-> L.ByteString -- ^ content -> L.ByteString -- ^ content
-> GHandler sub a (Maybe (Either String (Route a, [(String, String)]))) -> GHandler sub a (Maybe (Either Text (Route a, [(Text, Text)])))
addStaticContent _ _ _ = return Nothing addStaticContent _ _ _ = return Nothing
-- | Whether or not to tie a session to a specific IP address. Defaults to -- | Whether or not to tie a session to a specific IP address. Defaults to
@ -292,7 +291,7 @@ defaultYesodRunner s master toMasterRoute mkey murl handler req = do
hs'' = map (headerToPair getExpires) hs' hs'' = map (headerToPair getExpires) hs'
hs''' = ("Content-Type", ct) : hs'' hs''' = ("Content-Type", ct) : hs''
data AuthResult = Authorized | AuthenticationRequired | Unauthorized String data AuthResult = Authorized | AuthenticationRequired | Unauthorized Text
deriving (Eq, Show, Read) deriving (Eq, Show, Read)
-- | A type-safe, concise method of creating breadcrumbs for pages. For each -- | A type-safe, concise method of creating breadcrumbs for pages. For each
@ -408,6 +407,7 @@ widgetToPageContent (GWidget w) = do
let title = maybe mempty unTitle mTitle let title = maybe mempty unTitle mTitle
let scripts = runUniqueList scripts' let scripts = runUniqueList scripts'
let stylesheets = runUniqueList stylesheets' let stylesheets = runUniqueList stylesheets'
-- FIXME check size of cassius/julius template
let cssToHtml = preEscapedLazyText . renderCss let cssToHtml = preEscapedLazyText . renderCss
celper :: Cassius url -> Hamlet url celper :: Cassius url -> Hamlet url
celper = fmap cssToHtml celper = fmap cssToHtml
@ -415,8 +415,7 @@ widgetToPageContent (GWidget w) = do
jelper :: Julius url -> Hamlet url jelper :: Julius url -> Hamlet url
jelper = fmap jsToHtml jelper = fmap jsToHtml
renderFIXME <- getUrlRenderParams render <- getUrlRenderParams
let render a b = renderFIXME a $ map (TS.pack *** TS.pack) b
let renderLoc x = let renderLoc x =
case x of case x of
Nothing -> Nothing Nothing -> Nothing
@ -441,9 +440,13 @@ widgetToPageContent (GWidget w) = do
let renderLoc' render' (Local url) = render' url [] let renderLoc' render' (Local url) = render' url []
renderLoc' _ (Remote s) = s renderLoc' _ (Remote s) = s
let mkScriptTag (Script loc attrs) render' = let mkScriptTag (Script loc attrs) render' =
foldl' addAttr TBH.script (("src", T.pack $ renderLoc' render' loc) : attrs) $ return () foldl' addAttr TBH.script (("src", renderLoc' render' loc) : attrs) $ return ()
let mkLinkTag (Stylesheet loc attrs) render' = let mkLinkTag (Stylesheet loc attrs) render' =
foldl' addAttr TBH.link (("rel", "stylesheet") : ("href", T.pack $ renderLoc' render' loc) : attrs) foldl' addAttr TBH.link
( ("rel", "stylesheet")
: ("href", renderLoc' render' loc)
: attrs
)
let head'' = let head'' =
#if GHC7 #if GHC7
[hamlet| [hamlet|
@ -475,11 +478,11 @@ yesodRender :: Yesod y
=> y => y
-> Route y -> Route y
-> [(Text, Text)] -> [(Text, Text)]
-> String -- FIXME -> Text
yesodRender y u qs = yesodRender y u qs =
S8.unpack $ toByteString $ TE.decodeUtf8 $ toByteString $
fromMaybe fromMaybe
(joinPath y (fromByteString $ approot y) ps (joinPath y (fromText $ approot y) ps
$ qs ++ qs') $ qs ++ qs')
(urlRenderOverride y u) (urlRenderOverride y u)
where where

83
Yesod/Handler.hs
View File

@ -41,6 +41,7 @@ module Yesod.Handler
, redirect , redirect
, redirectParams , redirectParams
, redirectString , redirectString
, redirectText
, redirectToPost , redirectToPost
-- ** Errors -- ** Errors
, notFound , notFound
@ -124,6 +125,12 @@ import qualified Network.HTTP.Types as H
import Control.Failure (Failure (failure)) import Control.Failure (Failure (failure))
import Text.Hamlet import Text.Hamlet
import Text.Blaze (preEscapedText)
import qualified Text.Blaze.Renderer.Text
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import qualified Data.Text.Lazy as TL
import Control.Monad.IO.Control (MonadControlIO) import Control.Monad.IO.Control (MonadControlIO)
import Control.Monad.Trans.Control (MonadTransControl, liftControl, control) import Control.Monad.Trans.Control (MonadTransControl, liftControl, control)
@ -144,7 +151,6 @@ import qualified Data.ByteString.Char8 as S8
import Data.CaseInsensitive (CI) import Data.CaseInsensitive (CI)
import Blaze.ByteString.Builder (toByteString) import Blaze.ByteString.Builder (toByteString)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as TS
-- | 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
@ -157,7 +163,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 -> [(Text, Text)] -> String) -- FIXME replace output String with Ascii , handlerRender :: (Route master -> [(Text, Text)] -> Text)
, handlerToMaster :: Route sub -> Route master , handlerToMaster :: Route sub -> Route master
} }
@ -251,7 +257,7 @@ type GHInner s m monad = -- FIXME collapse the stack
monad monad
)))) ))))
type SessionMap = Map.Map String String type SessionMap = Map.Map Text Text
type Endo a = a -> a type Endo a = a -> a
@ -274,13 +280,13 @@ data YesodAppResult
data HandlerContents = data HandlerContents =
HCContent H.Status ChooseRep HCContent H.Status ChooseRep
| HCError ErrorResponse | HCError ErrorResponse
| HCSendFile ContentType FilePath | HCSendFile ContentType FilePath -- FIXME replace FilePath with opaque type from system-filepath?
| HCRedirect RedirectType H.Ascii | HCRedirect RedirectType Text
| HCCreated H.Ascii | HCCreated Text
| HCWai W.Response | HCWai W.Response
instance Error HandlerContents where instance Error HandlerContents where
strMsg = HCError . InternalError strMsg = HCError . InternalError . T.pack
instance Monad monad => Failure ErrorResponse (GGHandler sub master monad) where instance Monad monad => Failure ErrorResponse (GGHandler sub master monad) where
failure = GHandler . lift . throwError . HCError failure = GHandler . lift . throwError . HCError
@ -301,9 +307,10 @@ rbHelper req =
(map fix1 *** map fix2) <$> iter (map fix1 *** map fix2) <$> iter
where where
iter = NWP.parseRequestBody NWP.lbsSink req iter = NWP.parseRequestBody NWP.lbsSink req
fix1 = bsToChars *** bsToChars fix1 = go *** go
fix2 (x, NWP.FileInfo a b c) = fix2 (x, NWP.FileInfo a b c) =
(bsToChars x, FileInfo (bsToChars a) (bsToChars b) c) (go x, FileInfo (go a) (go b) c)
go = decodeUtf8With lenientDecode
-- | Get the sub application argument. -- | Get the sub application argument.
getYesodSub :: Monad m => GGHandler sub master m sub getYesodSub :: Monad m => GGHandler sub master m sub
@ -314,7 +321,7 @@ getYesod :: Monad m => GGHandler sub master m master
getYesod = handlerMaster `liftM` GHandler ask getYesod = handlerMaster `liftM` GHandler ask
-- | Get the URL rendering function. -- | Get the URL rendering function.
getUrlRender :: Monad m => GGHandler sub master m (Route master -> String) getUrlRender :: Monad m => GGHandler sub master m (Route master -> Text)
getUrlRender = do getUrlRender = do
x <- handlerRender `liftM` GHandler ask x <- handlerRender `liftM` GHandler ask
return $ flip x [] return $ flip x []
@ -322,7 +329,7 @@ getUrlRender = do
-- | The URL rendering function with query-string parameters. -- | The URL rendering function with query-string parameters.
getUrlRenderParams getUrlRenderParams
:: Monad m :: Monad m
=> GGHandler sub master m (Route master -> [(Text, Text)] -> String) => GGHandler sub master m (Route master -> [(Text, Text)] -> Text)
getUrlRenderParams = handlerRender `liftM` GHandler ask getUrlRenderParams = handlerRender `liftM` GHandler ask
-- | Get the route requested by the user. If this is a 404 response- where the -- | Get the route requested by the user. If this is a 404 response- where the
@ -339,7 +346,7 @@ getRouteToMaster = handlerToMaster `liftM` GHandler ask
-- 'GHandler' into an 'W.Application'. Should not be needed by users. -- 'GHandler' into an 'W.Application'. Should not be needed by users.
runHandler :: HasReps c runHandler :: HasReps c
=> GHandler sub master c => GHandler sub master c
-> (Route master -> [(Text, Text)] -> String) -> (Route master -> [(Text, Text)] -> Text)
-> Maybe (Route sub) -> Maybe (Route sub)
-> (Route sub -> Route master) -> (Route sub -> Route master)
-> master -> master
@ -350,7 +357,7 @@ runHandler handler mrender sroute tomr ma sa =
let toErrorHandler e = let toErrorHandler e =
case fromException e of case fromException e of
Just x -> x Just x -> x
Nothing -> InternalError $ show e Nothing -> InternalError $ T.pack $ show e
let hd = HandlerData let hd = HandlerData
{ handlerRequest = rr { handlerRequest = rr
, handlerSub = sa , handlerSub = sa
@ -384,7 +391,7 @@ runHandler handler mrender sroute tomr ma sa =
return $ YARPlain status (headers []) ct c finalSession return $ YARPlain status (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" (encodeUtf8 loc) : headers []
return $ YARPlain return $ YARPlain
(getRedirectStatus rt) hs typePlain emptyContent (getRedirectStatus rt) hs typePlain emptyContent
finalSession finalSession
@ -392,7 +399,7 @@ runHandler handler mrender sroute tomr ma sa =
(sendFile' ct fp) (sendFile' ct fp)
(handleError . toErrorHandler) (handleError . toErrorHandler)
HCCreated loc -> do HCCreated loc -> do
let hs = Header "Location" loc : headers [] let hs = Header "Location" (encodeUtf8 loc) : headers []
return $ YARPlain return $ YARPlain
H.status201 H.status201
hs hs
@ -427,13 +434,15 @@ 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 $ r url params
-- | Redirect to the given URL. -- | Redirect to the given URL.
redirectString :: Monad mo => RedirectType -> H.Ascii -> GGHandler sub master mo a redirectString, redirectText :: Monad mo => RedirectType -> Text -> GGHandler sub master mo a
redirectString rt = GHandler . lift . throwError . HCRedirect rt redirectText rt = GHandler . lift . throwError . HCRedirect rt
redirectString = redirectText
{-# DEPRECATED redirectString "Use redirectText instead" #-}
ultDestKey :: String ultDestKey :: Text
ultDestKey = "_ULT" ultDestKey = "_ULT"
-- | Sets the ultimate destination variable to the given route. -- | Sets the ultimate destination variable to the given route.
@ -446,7 +455,7 @@ setUltDest dest = do
setUltDestString $ render dest setUltDestString $ render dest
-- | Same as 'setUltDest', but use the given string. -- | Same as 'setUltDest', but use the given string.
setUltDestString :: Monad mo => String -> GGHandler sub master mo () setUltDestString :: Monad mo => Text -> GGHandler sub master mo ()
setUltDestString = setSession ultDestKey setUltDestString = setSession ultDestKey
-- | Same as 'setUltDest', but uses the current page. -- | Same as 'setUltDest', but uses the current page.
@ -462,8 +471,7 @@ setUltDest' = do
tm <- getRouteToMaster tm <- getRouteToMaster
gets' <- reqGetParams `liftM` handlerRequest `liftM` GHandler ask gets' <- reqGetParams `liftM` handlerRequest `liftM` GHandler ask
render <- getUrlRenderParams render <- getUrlRenderParams
let renderFIXME a b = render a $ map (TS.pack *** TS.pack) b setUltDestString $ render (tm r) gets'
setUltDestString $ renderFIXME (tm r) gets'
-- | Redirect to the ultimate destination in the user's session. Clear the -- | Redirect to the ultimate destination in the user's session. Clear the
-- value from the session. -- value from the session.
@ -476,16 +484,16 @@ 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) (redirectText rt) mdest
msgKey :: String msgKey :: Text
msgKey = "_MSG" msgKey = "_MSG"
-- | Sets a message in the user's session. -- | Sets a message in the user's session.
-- --
-- See 'getMessage'. -- See 'getMessage'.
setMessage :: Monad mo => Html -> GGHandler sub master mo () setMessage :: Monad mo => Html -> GGHandler sub master mo ()
setMessage = setSession msgKey . lbsToChars . renderHtml setMessage = setSession msgKey . T.concat . TL.toChunks . Text.Blaze.Renderer.Text.renderHtml
-- | Gets the message in the user's session, if available, and then clears the -- | Gets the message in the user's session, if available, and then clears the
-- variable. -- variable.
@ -493,7 +501,7 @@ setMessage = setSession msgKey . lbsToChars . renderHtml
-- See 'setMessage'. -- See 'setMessage'.
getMessage :: Monad mo => GGHandler sub master mo (Maybe Html) getMessage :: Monad mo => GGHandler sub master mo (Maybe Html)
getMessage = do getMessage = do
mmsg <- liftM (fmap preEscapedString) $ lookupSession msgKey mmsg <- liftM (fmap preEscapedText) $ lookupSession msgKey
deleteSession msgKey deleteSession msgKey
return mmsg return mmsg
@ -521,7 +529,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 $ 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
@ -542,11 +550,11 @@ badMethod = do
failure $ BadMethod $ 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 => Text -> m a
permissionDenied = failure . PermissionDenied permissionDenied = failure . PermissionDenied
-- | Return a 400 invalid arguments page. -- | Return a 400 invalid arguments page.
invalidArgs :: Failure ErrorResponse m => [String] -> m a invalidArgs :: Failure ErrorResponse m => [Text] -> m a
invalidArgs = failure . InvalidArgs invalidArgs = failure . InvalidArgs
------- Headers ------- Headers
@ -564,8 +572,8 @@ 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 => Text -> GGHandler sub master mo ()
setLanguage = setSession $ S8.unpack langKey setLanguage = setSession langKey
-- | Set an arbitrary response header. -- | Set an arbitrary response header.
setHeader :: Monad mo setHeader :: Monad mo
@ -601,13 +609,13 @@ expiresAt = setHeader "Expires" . S8.pack . formatRFC1123
-- and hashed cookie on the client. This ensures that all data is secure and -- and hashed cookie on the client. This ensures that all data is secure and
-- not tampered with. -- not tampered with.
setSession :: Monad mo setSession :: Monad mo
=> String -- ^ key => Text -- ^ key
-> String -- ^ value -> Text -- ^ value
-> GGHandler sub master mo () -> GGHandler sub master mo ()
setSession k = GHandler . lift . lift . lift . modify . modSession . Map.insert k setSession k = GHandler . lift . lift . lift . modify . modSession . Map.insert k
-- | Unsets a session variable. See 'setSession'. -- | Unsets a session variable. See 'setSession'.
deleteSession :: Monad mo => String -> GGHandler sub master mo () deleteSession :: Monad mo => Text -> GGHandler sub master mo ()
deleteSession = GHandler . lift . lift . lift . modify . modSession . Map.delete deleteSession = GHandler . lift . lift . lift . modify . modSession . Map.delete
modSession :: (SessionMap -> SessionMap) -> GHState -> GHState modSession :: (SessionMap -> SessionMap) -> GHState -> GHState
@ -640,7 +648,7 @@ localNoCurrent =
GHandler . local (\hd -> hd { handlerRoute = Nothing }) . unGHandler GHandler . local (\hd -> hd { handlerRoute = Nothing }) . unGHandler
-- | Lookup for session data. -- | Lookup for session data.
lookupSession :: Monad mo => ParamName -> GGHandler s m mo (Maybe ParamValue) lookupSession :: Monad mo => Text -> GGHandler s m mo (Maybe Text)
lookupSession n = GHandler $ do lookupSession n = GHandler $ do
m <- liftM ghsSession $ lift $ lift $ lift get m <- liftM ghsSession $ lift $ lift $ lift get
return $ Map.lookup n m return $ Map.lookup n m
@ -653,7 +661,7 @@ handlerToYAR :: (HasReps a, HasReps b)
=> m -- ^ master site foundation => m -- ^ master site foundation
-> s -- ^ sub site foundation -> s -- ^ sub site foundation
-> (Route s -> Route m) -> (Route s -> Route m)
-> (Route m -> [(Text, Text)] -> String) -- ^ url render FIXME -> (Route m -> [(Text, Text)] -> Text)
-> (ErrorResponse -> GHandler s m a) -> (ErrorResponse -> GHandler s m a)
-> Request -> Request
-> Maybe (Route s) -> Maybe (Route s)
@ -782,8 +790,7 @@ hamletToContent :: Monad mo
=> Hamlet (Route master) -> GGHandler sub master mo Content => Hamlet (Route master) -> GGHandler sub master mo Content
hamletToContent h = do hamletToContent h = do
render <- getUrlRenderParams render <- getUrlRenderParams
let renderFIXME a b = render a $ map (TS.pack *** TS.pack) b return $ toContent $ h render
return $ toContent $ h renderFIXME
-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
hamletToRepHtml :: Monad mo hamletToRepHtml :: Monad mo

17
Yesod/Internal.hs
View File

@ -41,6 +41,7 @@ import Data.List (nub)
import qualified Data.ByteString as S import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Encoding as T import qualified Data.Text.Encoding as T
import qualified Data.Text.Encoding.Error as T import qualified Data.Text.Encoding.Error as T
@ -54,6 +55,7 @@ import Control.Exception (Exception)
import qualified Network.HTTP.Types as H import qualified Network.HTTP.Types as H
import qualified Network.HTTP.Types as A import qualified Network.HTTP.Types as A
import Data.CaseInsensitive (CI) import Data.CaseInsensitive (CI)
import Data.String (IsString)
#if GHC7 #if GHC7
#define HAMLET hamlet #define HAMLET hamlet
@ -65,9 +67,9 @@ import Data.CaseInsensitive (CI)
-- from 'SpecialResponse' in that they allow for custom error pages. -- from 'SpecialResponse' in that they allow for custom error pages.
data ErrorResponse = data ErrorResponse =
NotFound NotFound
| InternalError String | InternalError Text
| InvalidArgs [String] | InvalidArgs [Text]
| PermissionDenied String | PermissionDenied Text
| BadMethod H.Method | BadMethod H.Method
deriving (Show, Eq, Typeable) deriving (Show, Eq, Typeable)
instance Exception ErrorResponse instance Exception ErrorResponse
@ -80,10 +82,10 @@ data Header =
| Header (CI A.Ascii) A.Ascii | Header (CI A.Ascii) A.Ascii
deriving (Eq, Show) deriving (Eq, Show)
langKey :: A.Ascii langKey :: IsString a => a
langKey = "_LANG" langKey = "_LANG"
data Location url = Local url | Remote String -- FIXME Text data Location url = Local url | Remote Text
deriving (Show, Eq) deriving (Show, Eq)
locationToHamlet :: Location url -> Hamlet url locationToHamlet :: Location url -> Hamlet url
locationToHamlet (Local url) = [HAMLET|\@{url} locationToHamlet (Local url) = [HAMLET|\@{url}
@ -111,6 +113,7 @@ newtype Head url = Head (Hamlet url)
newtype Body url = Body (Hamlet url) newtype Body url = Body (Hamlet url)
deriving Monoid deriving Monoid
-- FIXME remove these functions
lbsToChars :: L.ByteString -> String lbsToChars :: L.ByteString -> String
lbsToChars = LT.unpack . LT.decodeUtf8With T.lenientDecode lbsToChars = LT.unpack . LT.decodeUtf8With T.lenientDecode
@ -120,10 +123,10 @@ bsToChars = T.unpack . T.decodeUtf8With T.lenientDecode
charsToBs :: String -> S.ByteString charsToBs :: String -> S.ByteString
charsToBs = T.encodeUtf8 . T.pack charsToBs = T.encodeUtf8 . T.pack
nonceKey :: String nonceKey :: IsString a => a
nonceKey = "_NONCE" nonceKey = "_NONCE"
sessionName :: A.Ascii sessionName :: IsString a => a
sessionName = "_SESSION" sessionName = "_SESSION"
data GWData a = GWData data GWData a = GWData

3
Yesod/Internal/Dispatch.hs
View File

@ -24,6 +24,7 @@ import Data.Text (Text)
import Data.Monoid (mappend) import Data.Monoid (mappend)
import qualified Blaze.ByteString.Builder import qualified Blaze.ByteString.Builder
import qualified Blaze.ByteString.Builder.Char8 import qualified Blaze.ByteString.Builder.Char8
import Blaze.ByteString.Builder.Char.Utf8 (fromText)
import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Char8 as S8
{-| {-|
@ -86,7 +87,7 @@ sendRedirect y segments' env =
, ("Location", Blaze.ByteString.Builder.toByteString dest') , ("Location", Blaze.ByteString.Builder.toByteString dest')
] "Redirecting" ] "Redirecting"
where where
dest = joinPath y (Blaze.ByteString.Builder.fromByteString $ approot y) segments' [] dest = joinPath y (fromText $ approot y) segments' []
dest' = dest' =
if S.null (W.rawQueryString env) if S.null (W.rawQueryString env)
then dest then dest

28
Yesod/Internal/Request.hs
View File

@ -4,34 +4,37 @@ module Yesod.Internal.Request
) where ) where
import Yesod.Request import Yesod.Request
import Control.Arrow (first, (***)) import Control.Arrow (first, second)
import qualified Network.Wai.Parse as NWP import qualified Network.Wai.Parse as NWP
import Yesod.Internal import Yesod.Internal
import qualified Network.Wai as W import qualified Network.Wai as W
import System.Random (randomR, newStdGen) import System.Random (randomR, newStdGen)
import Web.Cookie (parseCookies) import Web.Cookie (parseCookiesText)
import Data.Monoid (mempty) import Data.Monoid (mempty)
import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Char8 as S8
import Data.Text (Text, pack)
import Network.HTTP.Types (queryToQueryText)
import Control.Monad (join)
import Data.Maybe (fromMaybe)
parseWaiRequest :: W.Request parseWaiRequest :: W.Request
-> [(String, String)] -- ^ session -> [(Text, Text)] -- ^ session
-> Maybe a -> Maybe a
-> IO Request -> IO Request
parseWaiRequest env session' key' = do parseWaiRequest env session' key' = do
let gets' = map (bsToChars *** maybe "" bsToChars) let gets' = queryToQueryText $ W.queryString env
$ W.queryString env
let reqCookie = maybe mempty id $ lookup "Cookie" let reqCookie = maybe mempty id $ lookup "Cookie"
$ W.requestHeaders env $ W.requestHeaders env
cookies' = parseCookies reqCookie cookies' = parseCookiesText reqCookie
acceptLang = lookup "Accept-Language" $ W.requestHeaders env acceptLang = lookup "Accept-Language" $ W.requestHeaders env
langs = map S8.unpack $ maybe [] NWP.parseHttpAccept acceptLang langs = map (pack . S8.unpack) $ maybe [] NWP.parseHttpAccept acceptLang
langs' = case lookup (S8.unpack langKey) session' of langs' = case lookup 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 -> S8.unpack x : langs' Just x -> x : langs'
langs''' = case lookup (S8.unpack langKey) gets' of langs''' = case join $ lookup 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
@ -39,8 +42,9 @@ parseWaiRequest env session' key' = do
(_, Just x) -> return $ Just x (_, Just x) -> return $ Just x
(_, Nothing) -> do (_, Nothing) -> do
g <- newStdGen g <- newStdGen
return $ Just $ fst $ randomString 10 g return $ Just $ pack $ fst $ randomString 10 g
return $ Request gets' cookies' env langs''' nonce let gets'' = map (second $ fromMaybe "") gets'
return $ Request gets'' cookies' env langs''' nonce
where where
randomString len = randomString len =
first (map toChar) . sequence' (replicate len (randomR (0, 61))) first (map toChar) . sequence' (replicate len (randomR (0, 61)))

12
Yesod/Internal/Session.hs
View File

@ -8,11 +8,13 @@ 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 Data.Text (Text, pack, unpack)
import Control.Arrow ((***))
encodeSession :: CS.Key encodeSession :: CS.Key
-> UTCTime -- ^ expire time -> UTCTime -- ^ expire time
-> ByteString -- ^ remote host -> ByteString -- ^ remote host
-> [(String, String)] -- ^ session -> [(Text, Text)] -- ^ session
-> ByteString -- ^ cookie value -> ByteString -- ^ 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'
@ -21,7 +23,7 @@ decodeSession :: CS.Key
-> UTCTime -- ^ current time -> UTCTime -- ^ current time
-> ByteString -- ^ remote host field -> ByteString -- ^ remote host field
-> ByteString -- ^ cookie value -> ByteString -- ^ cookie value
-> Maybe [(String, String)] -> Maybe [(Text, Text)]
decodeSession key now rhost encrypted = do decodeSession key now rhost encrypted = do
decrypted <- CS.decrypt key encrypted decrypted <- CS.decrypt key encrypted
SessionCookie expire rhost' session' <- SessionCookie expire rhost' session' <-
@ -30,14 +32,14 @@ decodeSession key now rhost encrypted = do
guard $ rhost' == rhost guard $ rhost' == rhost
return session' return session'
data SessionCookie = SessionCookie UTCTime ByteString [(String, String)] data SessionCookie = SessionCookie UTCTime ByteString [(Text, Text)]
deriving (Show, Read) deriving (Show, Read)
instance Serialize SessionCookie where instance Serialize SessionCookie where
put (SessionCookie a b c) = putTime a >> put b >> put c put (SessionCookie a b c) = putTime a >> put b >> put (map (unpack *** unpack) c)
get = do get = do
a <- getTime a <- getTime
b <- get b <- get
c <- get c <- map (pack *** pack) `fmap` get
return $ SessionCookie a b c return $ SessionCookie a b c
putTime :: Putter UTCTime putTime :: Putter UTCTime

48
Yesod/Request.hs
View File

@ -31,10 +31,6 @@ module Yesod.Request
, lookupPostParams , lookupPostParams
, lookupCookies , lookupCookies
, lookupFiles , lookupFiles
-- * Parameter type synonyms
, ParamName
, ParamValue
, ParamError
) where ) where
import qualified Network.Wai as W import qualified Network.Wai as W
@ -43,11 +39,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 Network.HTTP.Types as A import Data.Text (Text)
type ParamName = String
type ParamValue = String
type ParamError = String
-- FIXME perhaps remove RequestReader typeclass, include Request datatype in Handler -- FIXME perhaps remove RequestReader typeclass, include Request datatype in Handler
@ -70,7 +62,7 @@ class Monad m => RequestReader m where
-- * Accept-Language HTTP header. -- * Accept-Language HTTP header.
-- --
-- This is handled by parseWaiRequest (not exposed). -- This is handled by parseWaiRequest (not exposed).
languages :: RequestReader m => m [String] languages :: RequestReader m => m [Text]
languages = reqLangs `liftM` getRequest languages = reqLangs `liftM` getRequest
-- | Get the request\'s 'W.Request' value. -- | Get the request\'s 'W.Request' value.
@ -79,74 +71,74 @@ waiRequest = reqWaiRequest `liftM` getRequest
-- | A tuple containing both the POST parameters and submitted files. -- | A tuple containing both the POST parameters and submitted files.
type RequestBodyContents = type RequestBodyContents =
( [(ParamName, ParamValue)] ( [(Text, Text)]
, [(ParamName, FileInfo)] , [(Text, FileInfo)]
) )
data FileInfo = FileInfo data FileInfo = FileInfo
{ fileName :: String { fileName :: Text
, fileContentType :: String , fileContentType :: Text
, fileContent :: BL.ByteString , fileContent :: BL.ByteString
} }
deriving (Eq, Show) deriving (Eq, Show)
-- | The parsed request information. -- | The parsed request information.
data Request = Request data Request = Request
{ reqGetParams :: [(ParamName, ParamValue)] { reqGetParams :: [(Text, Text)]
, reqCookies :: [(A.Ascii, A.Ascii)] , reqCookies :: [(Text, Text)]
, reqWaiRequest :: W.Request , reqWaiRequest :: W.Request
-- | Languages which the client supports. -- | Languages which the client supports.
, reqLangs :: [String] , reqLangs :: [Text]
-- | A random, session-specific nonce used to prevent CSRF attacks. -- | A random, session-specific nonce used to prevent CSRF attacks.
, reqNonce :: Maybe String , reqNonce :: Maybe Text
} }
lookup' :: Eq a => a -> [(a, b)] -> [b] lookup' :: Eq a => a -> [(a, b)] -> [b]
lookup' a = map snd . filter (\x -> a == fst x) lookup' a = map snd . filter (\x -> a == fst x)
-- | Lookup for GET parameters. -- | Lookup for GET parameters.
lookupGetParams :: RequestReader m => ParamName -> m [ParamValue] lookupGetParams :: RequestReader m => Text -> m [Text]
lookupGetParams pn = do lookupGetParams pn = do
rr <- getRequest rr <- getRequest
return $ lookup' pn $ reqGetParams rr return $ lookup' pn $ reqGetParams rr
-- | Lookup for GET parameters. -- | Lookup for GET parameters.
lookupGetParam :: RequestReader m => ParamName -> m (Maybe ParamValue) lookupGetParam :: RequestReader m => Text -> m (Maybe Text)
lookupGetParam = liftM listToMaybe . lookupGetParams lookupGetParam = liftM listToMaybe . lookupGetParams
-- | Lookup for POST parameters. -- | Lookup for POST parameters.
lookupPostParams :: RequestReader m lookupPostParams :: RequestReader m
=> ParamName => Text
-> m [ParamValue] -> m [Text]
lookupPostParams pn = do lookupPostParams pn = do
(pp, _) <- runRequestBody (pp, _) <- runRequestBody
return $ lookup' pn pp return $ lookup' pn pp
lookupPostParam :: (MonadIO m, RequestReader m) lookupPostParam :: (MonadIO m, RequestReader m)
=> ParamName => Text
-> m (Maybe ParamValue) -> m (Maybe Text)
lookupPostParam = liftM listToMaybe . lookupPostParams lookupPostParam = liftM listToMaybe . lookupPostParams
-- | Lookup for POSTed files. -- | Lookup for POSTed files.
lookupFile :: (MonadIO m, RequestReader m) lookupFile :: (MonadIO m, RequestReader m)
=> ParamName => Text
-> m (Maybe FileInfo) -> m (Maybe FileInfo)
lookupFile = liftM listToMaybe . lookupFiles lookupFile = liftM listToMaybe . lookupFiles
-- | Lookup for POSTed files. -- | Lookup for POSTed files.
lookupFiles :: RequestReader m lookupFiles :: RequestReader m
=> ParamName => Text
-> m [FileInfo] -> m [FileInfo]
lookupFiles pn = do lookupFiles pn = do
(_, files) <- runRequestBody (_, files) <- runRequestBody
return $ lookup' pn files return $ lookup' pn files
-- | Lookup for cookie data. -- | Lookup for cookie data.
lookupCookie :: RequestReader m => A.Ascii -> m (Maybe A.Ascii) lookupCookie :: RequestReader m => Text -> m (Maybe Text)
lookupCookie = liftM listToMaybe . lookupCookies lookupCookie = liftM listToMaybe . lookupCookies
-- | Lookup for cookie data. -- | Lookup for cookie data.
lookupCookies :: RequestReader m => A.Ascii -> m [A.Ascii] lookupCookies :: RequestReader m => Text -> m [Text]
lookupCookies pn = do lookupCookies pn = do
rr <- getRequest rr <- getRequest
return $ lookup' pn $ reqCookies rr return $ lookup' pn $ reqCookies rr

15
Yesod/Widget.hs
View File

@ -38,6 +38,7 @@ module Yesod.Widget
import Data.Monoid import Data.Monoid
import Control.Monad.Trans.RWS import Control.Monad.Trans.RWS
import Text.Blaze (preEscapedText)
import Text.Hamlet import Text.Hamlet
import Text.Cassius import Text.Cassius
import Text.Julius import Text.Julius
@ -75,7 +76,7 @@ instance (Monad monad, a ~ ()) => HamletValue (GGWidget s m monad a) where
toHamletValue = runGWidget' toHamletValue = runGWidget'
htmlToHamletMonad = GWidget' . addHtml htmlToHamletMonad = GWidget' . addHtml
urlToHamletMonad url params = GWidget' $ urlToHamletMonad url params = GWidget' $
addHamlet $ \r -> preEscapedString (r url params) addHamlet $ \r -> preEscapedText (r url params)
fromHamletValue = GWidget' fromHamletValue = GWidget'
instance (Monad monad, a ~ ()) => Monad (HamletMonad (GGWidget s m monad a)) where instance (Monad monad, a ~ ()) => Monad (HamletMonad (GGWidget s m monad a)) where
return = GWidget' . return return = GWidget' . return
@ -130,17 +131,17 @@ addStylesheetAttrs :: Monad m => Route master -> [(Text, Text)] -> GGWidget sub
addStylesheetAttrs x y = GWidget $ tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty addStylesheetAttrs x y = GWidget $ tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty
-- | Link to the specified remote stylesheet. -- | Link to the specified remote stylesheet.
addStylesheetRemote :: Monad m => String -> GGWidget sub master m () addStylesheetRemote :: Monad m => Text -> GGWidget sub master m ()
addStylesheetRemote = flip addStylesheetRemoteAttrs [] addStylesheetRemote = flip addStylesheetRemoteAttrs []
-- | Link to the specified remote stylesheet. -- | Link to the specified remote stylesheet.
addStylesheetRemoteAttrs :: Monad m => String -> [(Text, Text)] -> GGWidget sub master m () addStylesheetRemoteAttrs :: Monad m => Text -> [(Text, Text)] -> GGWidget sub master m ()
addStylesheetRemoteAttrs x y = GWidget $ tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty addStylesheetRemoteAttrs x y = GWidget $ tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty
addStylesheetEither :: Monad m => Either (Route master) String -> GGWidget sub master m () addStylesheetEither :: Monad m => Either (Route master) Text -> GGWidget sub master m ()
addStylesheetEither = either addStylesheet addStylesheetRemote addStylesheetEither = either addStylesheet addStylesheetRemote
addScriptEither :: Monad m => Either (Route master) String -> GGWidget sub master m () addScriptEither :: Monad m => Either (Route master) Text -> GGWidget sub master m ()
addScriptEither = either addScript addScriptRemote addScriptEither = either addScript addScriptRemote
-- | Link to the specified local script. -- | Link to the specified local script.
@ -152,11 +153,11 @@ addScriptAttrs :: Monad m => Route master -> [(Text, Text)] -> GGWidget sub mast
addScriptAttrs x y = GWidget $ tell $ GWData mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty addScriptAttrs x y = GWidget $ tell $ GWData mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty
-- | Link to the specified remote script. -- | Link to the specified remote script.
addScriptRemote :: Monad m => String -> GGWidget sub master m () addScriptRemote :: Monad m => Text -> GGWidget sub master m ()
addScriptRemote = flip addScriptRemoteAttrs [] addScriptRemote = flip addScriptRemoteAttrs []
-- | Link to the specified remote script. -- | Link to the specified remote script.
addScriptRemoteAttrs :: Monad m => String -> [(Text, Text)] -> GGWidget sub master m () addScriptRemoteAttrs :: Monad m => Text -> [(Text, Text)] -> GGWidget sub master m ()
addScriptRemoteAttrs x y = GWidget $ tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty addScriptRemoteAttrs x y = GWidget $ tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty
-- | Include raw Javascript in the page's script tag. -- | Include raw Javascript in the page's script tag.

8
yesod-core.cabal
View File

@ -8,12 +8,12 @@ synopsis: Creation of type-safe, RESTful web applications.
description: description:
Yesod is a framework designed to foster creation of RESTful web application that have strong compile-time guarantees of correctness. It also affords space efficient code and portability to many deployment backends, from CGI to stand-alone serving. Yesod is a framework designed to foster creation of RESTful web application that have strong compile-time guarantees of correctness. It also affords space efficient code and portability to many deployment backends, from CGI to stand-alone serving.
. .
The Yesod documentation site <http://docs.yesodweb.com/> has much more information, tutorials and information on some of the supporting packages, like Hamlet and web-routes-quasi. The Yesod documentation site <http://www.yesodweb.com/> has much more information, tutorials and information on some of the supporting packages, like Hamlet and web-routes-quasi.
category: Web, Yesod category: Web, Yesod
stability: Stable stability: Stable
cabal-version: >= 1.6 cabal-version: >= 1.6
build-type: Simple build-type: Simple
homepage: http://docs.yesodweb.com/ homepage: http://www.yesodweb.com/
flag test flag test
description: Build the executable to run unit tests description: Build the executable to run unit tests
@ -34,7 +34,7 @@ library
, text >= 0.5 && < 0.12 , text >= 0.5 && < 0.12
, template-haskell , template-haskell
, web-routes-quasi >= 0.7 && < 0.8 , web-routes-quasi >= 0.7 && < 0.8
, hamlet >= 0.7.3 && < 0.8 , hamlet >= 0.8 && < 0.9
, blaze-builder >= 0.2.1 && < 0.4 , blaze-builder >= 0.2.1 && < 0.4
, transformers >= 0.2 && < 0.3 , transformers >= 0.2 && < 0.3
, clientsession >= 0.6 && < 0.7 , clientsession >= 0.6 && < 0.7
@ -45,7 +45,7 @@ library
, containers >= 0.2 && < 0.5 , containers >= 0.2 && < 0.5
, monad-control >= 0.2 && < 0.3 , monad-control >= 0.2 && < 0.3
, enumerator >= 0.4.7 && < 0.5 , enumerator >= 0.4.7 && < 0.5
, cookie >= 0.2 && < 0.3 , cookie >= 0.2.1 && < 0.3
, blaze-html >= 0.4 && < 0.5 , blaze-html >= 0.4 && < 0.5
, http-types >= 0.6 && < 0.7 , http-types >= 0.6 && < 0.7
, case-insensitive >= 0.2 && < 0.3 , case-insensitive >= 0.2 && < 0.3