approot, joinPath, a few others are Ascii

This commit is contained in:
Michael Snoyman 2011-03-15 23:16:36 +02:00
parent 4bbbc78f2b
commit a221c1c832
3 changed files with 25 additions and 19 deletions

View File

@ -55,6 +55,7 @@ import qualified Data.Map as Map
import Data.Time import Data.Time
import Network.HTTP.Types (encodePath) import Network.HTTP.Types (encodePath)
import qualified Data.Text as TS import qualified Data.Text as TS
import qualified Data.Text.Encoding as TE
import qualified Data.Ascii as A import qualified Data.Ascii as A
#if GHC7 #if GHC7
@ -64,7 +65,7 @@ import qualified Data.Ascii as A
#endif #endif
class Eq u => RenderRoute u where class Eq u => RenderRoute u where
renderRoute :: u -> ([String], [(String, String)]) renderRoute :: u -> ([String], [(String, String)]) -- FIXME switch to Text?
-- | This class is automatically instantiated when you use the template haskell -- | This class is automatically instantiated when you use the template haskell
-- mkYesod function. You should never need to deal with it directly. -- mkYesod function. You should never need to deal with it directly.
@ -98,7 +99,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 -> String approot :: a -> A.Ascii
-- | 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.
@ -135,7 +136,7 @@ class RenderRoute (Route a) => Yesod a where
-- | Override the rendering function for a particular URL. One use case for -- | Override the rendering function for a particular URL. One use case for
-- this is to offload static hosting to a different domain name to avoid -- this is to offload static hosting to a different domain name to avoid
-- sending cookies. -- sending cookies.
urlRenderOverride :: a -> Route a -> Maybe String urlRenderOverride :: a -> Route a -> Maybe A.AsciiBuilder
urlRenderOverride _ _ = Nothing urlRenderOverride _ _ = Nothing
-- | Determine if a request is authorized or not. -- | Determine if a request is authorized or not.
@ -189,16 +190,15 @@ class RenderRoute (Route a) => Yesod a where
-- | Join the pieces of a path together into an absolute URL. This should -- | Join the pieces of a path together into an absolute URL. This should
-- be the inverse of 'splitPath'. -- be the inverse of 'splitPath'.
joinPath :: a joinPath :: a
-> String -- ^ application root -> A.AsciiBuilder -- ^ application root
-> [String] -- ^ path pieces FIXME Text -> [TS.Text] -- ^ path pieces FIXME Text
-> [(String, String)] -- ^ query string -> [(TS.Text, TS.Text)] -- ^ query string
-> String -> A.AsciiBuilder
joinPath _ ar pieces qs' = joinPath _ ar pieces qs' = ar `mappend` encodePath pieces qs
ar ++ A.toString (A.fromAsciiBuilder $ encodePath (map TS.pack pieces) qs)
where where
qs = map (charsToBs *** go) qs' qs = map (TE.encodeUtf8 *** go) qs'
go "" = Nothing go "" = Nothing
go x = Just $ charsToBs x go x = Just $ TE.encodeUtf8 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
@ -465,8 +465,10 @@ yesodRender :: Yesod y
-> [(String, String)] -> [(String, String)]
-> String -> String
yesodRender y u qs = yesodRender y u qs =
A.toString $ A.fromAsciiBuilder $
fromMaybe fromMaybe
(joinPath y (approot y) ps $ qs ++ qs') ( joinPath y (A.toAsciiBuilder $ approot y) (map TS.pack ps)
$ map (TS.pack *** TS.pack) $ qs ++ qs')
(urlRenderOverride y u) (urlRenderOverride y u)
where where
(ps, qs') = renderRoute u (ps, qs') = renderRoute u

View File

@ -38,7 +38,6 @@ import Text.Julius (Julius)
import Data.Monoid (Monoid (..), Last) import Data.Monoid (Monoid (..), Last)
import Data.List (nub) import Data.List (nub)
import Data.ByteString (ByteString)
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

View File

@ -17,12 +17,14 @@ import qualified Network.Wai as W
import Yesod.Core (yesodRunner, yesodDispatch) import Yesod.Core (yesodRunner, yesodDispatch)
import Data.List (foldl') import Data.List (foldl')
import Data.Char (toLower) import Data.Char (toLower)
import qualified Data.ByteString.Char8 as S8
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 Network.HTTP.Types (status301)
import qualified Data.Ascii as A import qualified Data.Ascii as A
import Data.Text (Text)
import Data.Monoid (mappend)
import qualified Blaze.ByteString.Builder
import qualified Blaze.ByteString.Builder.Char8
{-| {-|
@ -77,18 +79,21 @@ local routes.
-} -}
sendRedirect :: Yesod master => master -> [String] -> W.Application sendRedirect :: Yesod master => master -> [Text] -> W.Application
sendRedirect y segments' env = sendRedirect y segments' env =
return $ W.responseLBS status301 return $ W.responseLBS status301
[ ("Content-Type", "text/plain") [ ("Content-Type", "text/plain")
, ("Location", A.unsafeFromString $ dest') , ("Location", A.fromAsciiBuilder dest')
] "Redirecting" ] "Redirecting"
where where
dest = joinPath y (approot y) segments' [] dest = joinPath y (A.toAsciiBuilder $ approot y) segments' []
dest' = dest' =
if S.null (W.rawQueryString env) if S.null (W.rawQueryString env)
then dest then dest
else dest ++ '?' : S8.unpack (W.rawQueryString env) else A.unsafeFromBuilder
(A.toBuilder dest `mappend`
Blaze.ByteString.Builder.Char8.fromChar '?' `mappend`
Blaze.ByteString.Builder.fromByteString (W.rawQueryString env))
mkYesodDispatch' :: [((String, Pieces), Maybe String)] mkYesodDispatch' :: [((String, Pieces), Maybe String)]
-> [((String, Pieces), Maybe String)] -> [((String, Pieces), Maybe String)]