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

Precede null path segments with dashes (#421)

Browse Source
This commit is contained in:
Michael Snoyman 2012-09-21 14:23:38 +03:00
parent c6aa648884
commit cf4fed8cb9
4 changed files with 60 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
yesod-core/Yesod/Internal/Core.hs
View File

@ -227,10 +227,13 @@ $doctype 5
cleanPath :: a -> [Text] -> Either [Text] [Text] cleanPath :: a -> [Text] -> Either [Text] [Text]
cleanPath _ s = cleanPath _ s =
if corrected == s if corrected == s
then Right s then Right $ map dropDash s
else Left corrected else Left corrected
where where
corrected = filter (not . T.null) s corrected = filter (not . T.null) s
dropDash t
| T.all (== '-') t = T.drop 1 t
| otherwise = t
-- | Builds an absolute URL by concatenating the application root with the -- | Builds an absolute URL by concatenating the application root with the
-- pieces of a path and a query string, if any. -- pieces of a path and a query string, if any.
@ -240,12 +243,16 @@ $doctype 5
-> [T.Text] -- ^ path pieces -> [T.Text] -- ^ path pieces
-> [(T.Text, T.Text)] -- ^ query string -> [(T.Text, T.Text)] -- ^ query string
-> Builder -> Builder
joinPath _ ar pieces' qs' = fromText ar `mappend` encodePath pieces qs joinPath _ ar pieces' qs' =
fromText ar `mappend` encodePath pieces qs
where where
pieces = if null pieces' then [""] else pieces' pieces = if null pieces' then [""] else map addDash pieces'
qs = map (TE.encodeUtf8 *** go) qs' qs = map (TE.encodeUtf8 *** go) qs'
go "" = Nothing go "" = Nothing
go x = Just $ TE.encodeUtf8 x go x = Just $ TE.encodeUtf8 x
addDash t
| T.all (== '-') t = T.cons '-' t
| otherwise = t
-- | 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

13
yesod-core/test/YesodCoreTest/CleanPath.hs
View File

@ -14,6 +14,11 @@ import Network.HTTP.Types (status200, decodePathSegments)
import qualified Data.ByteString.Lazy.Char8 as L8 import qualified Data.ByteString.Lazy.Char8 as L8
import qualified Data.Text as TS import qualified Data.Text as TS
import qualified Data.Text.Encoding as TE
import Control.Arrow ((***))
import Network.HTTP.Types (encodePath)
import Data.Monoid (mappend)
import Blaze.ByteString.Builder.Char.Utf8 (fromText)
data Subsite = Subsite data Subsite = Subsite
@ -52,6 +57,14 @@ instance Yesod Y where
where where
corrected = filter (not . TS.null) s corrected = filter (not . TS.null) s
joinPath Y ar pieces' qs' =
fromText ar `mappend` encodePath pieces qs
where
pieces = if null pieces' then [""] else pieces'
qs = map (TE.encodeUtf8 *** go) qs'
go "" = Nothing
go x = Just $ TE.encodeUtf8 x
getFooR :: Handler RepPlain getFooR :: Handler RepPlain
getFooR = return $ RepPlain "foo" getFooR = return $ RepPlain "foo"

35
yesod-core/test/YesodCoreTest/Links.hs
View File

@ -8,11 +8,17 @@ import Test.Hspec.HUnit ()
import Yesod.Core hiding (Request) import Yesod.Core hiding (Request)
import Text.Hamlet import Text.Hamlet
import Network.Wai
import Network.Wai.Test import Network.Wai.Test
import Data.Text (Text)
import Control.Monad.IO.Class (liftIO)
import Blaze.ByteString.Builder (toByteString)
data Y = Y data Y = Y
mkYesod "Y" [parseRoutes| mkYesod "Y" [parseRoutes|
/ RootR GET / RootR GET
/single/#Text TextR GET
/multi/*Texts TextsR GET
|] |]
instance Yesod Y instance Yesod Y
@ -20,9 +26,16 @@ instance Yesod Y
getRootR :: Handler RepHtml getRootR :: Handler RepHtml
getRootR = defaultLayout $ toWidget [hamlet|<a href=@{RootR}>|] getRootR = defaultLayout $ toWidget [hamlet|<a href=@{RootR}>|]
getTextR :: Text -> Handler RepHtml
getTextR foo = defaultLayout $ toWidget [hamlet|%#{foo}%|]
getTextsR :: [Text] -> Handler RepHtml
getTextsR foos = defaultLayout $ toWidget [hamlet|%#{show foos}%|]
linksTest :: Spec linksTest :: Spec
linksTest = describe "Test.Links" $ do linksTest = describe "Test.Links" $ do
it "linkToHome" case_linkToHome it "linkToHome" case_linkToHome
it "blank path pieces" case_blanks
runner :: Session () -> IO () runner :: Session () -> IO ()
runner f = toWaiApp Y >>= runSession f runner f = toWaiApp Y >>= runSession f
@ -31,3 +44,25 @@ case_linkToHome :: IO ()
case_linkToHome = runner $ do case_linkToHome = runner $ do
res <- request defaultRequest res <- request defaultRequest
assertBody "<!DOCTYPE html>\n<html><head><title></title></head><body><a href=\"/\"></a>\n</body></html>" res assertBody "<!DOCTYPE html>\n<html><head><title></title></head><body><a href=\"/\"></a>\n</body></html>" res
case_blanks :: IO ()
case_blanks = runner $ do
liftIO $ do
let go r =
let (ps, qs) = renderRoute r
in toByteString $ joinPath Y "" ps qs
(go $ TextR "-") `shouldBe` "/single/--"
(go $ TextR "") `shouldBe` "/single/-"
(go $ TextsR ["", "-", "foo", "", "bar"]) `shouldBe` "/multi/-/--/foo/-/bar"
res1 <- request defaultRequest
{ pathInfo = ["single", "-"]
, rawPathInfo = "dummy1"
}
assertBody "<!DOCTYPE html>\n<html><head><title></title></head><body>%%</body></html>" res1
res2 <- request defaultRequest
{ pathInfo = ["multi", "foo", "-", "bar"]
, rawPathInfo = "dummy2"
}
assertBody "<!DOCTYPE html>\n<html><head><title></title></head><body>%[&quot;foo&quot;,&quot;&quot;,&quot;bar&quot;]%</body></html>" res2

2
yesod-core/yesod-core.cabal
View File

@ -119,8 +119,10 @@ test-suite tests
,text ,text
,http-types ,http-types
, random , random
, blaze-builder
,HUnit ,HUnit
,QuickCheck >= 2 && < 3 ,QuickCheck >= 2 && < 3
,transformers
ghc-options: -Wall ghc-options: -Wall
source-repository head source-repository head