approot, joinPath, a few others are Ascii
This commit is contained in:
parent
4bbbc78f2b
commit
a221c1c832
@ -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
|
||||||
|
|||||||
@ -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
|
||||||
|
|
||||||
|
|||||||
@ -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)]
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user