diff --git a/yesod-core/Yesod/Internal/Core.hs b/yesod-core/Yesod/Internal/Core.hs
index 6562e6b8..23c48fa1 100644
--- a/yesod-core/Yesod/Internal/Core.hs
+++ b/yesod-core/Yesod/Internal/Core.hs
@@ -227,10 +227,13 @@ $doctype 5
cleanPath :: a -> [Text] -> Either [Text] [Text]
cleanPath _ s =
if corrected == s
- then Right s
+ then Right $ map dropDash s
else Left corrected
where
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
-- pieces of a path and a query string, if any.
@@ -240,12 +243,16 @@ $doctype 5
-> [T.Text] -- ^ path pieces
-> [(T.Text, T.Text)] -- ^ query string
-> Builder
- joinPath _ ar pieces' qs' = fromText ar `mappend` encodePath pieces qs
+ joinPath _ ar pieces' qs' =
+ fromText ar `mappend` encodePath pieces qs
where
- pieces = if null pieces' then [""] else pieces'
+ pieces = if null pieces' then [""] else map addDash pieces'
qs = map (TE.encodeUtf8 *** go) qs'
go "" = Nothing
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
-- external file. The most common case of this is stashing CSS and
diff --git a/yesod-core/test/YesodCoreTest/CleanPath.hs b/yesod-core/test/YesodCoreTest/CleanPath.hs
index 99637af4..572551cb 100644
--- a/yesod-core/test/YesodCoreTest/CleanPath.hs
+++ b/yesod-core/test/YesodCoreTest/CleanPath.hs
@@ -14,6 +14,11 @@ import Network.HTTP.Types (status200, decodePathSegments)
import qualified Data.ByteString.Lazy.Char8 as L8
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
@@ -52,6 +57,14 @@ instance Yesod Y where
where
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 = return $ RepPlain "foo"
diff --git a/yesod-core/test/YesodCoreTest/Links.hs b/yesod-core/test/YesodCoreTest/Links.hs
index 611e17d5..ddb95931 100644
--- a/yesod-core/test/YesodCoreTest/Links.hs
+++ b/yesod-core/test/YesodCoreTest/Links.hs
@@ -8,11 +8,17 @@ import Test.Hspec.HUnit ()
import Yesod.Core hiding (Request)
import Text.Hamlet
+import Network.Wai
import Network.Wai.Test
+import Data.Text (Text)
+import Control.Monad.IO.Class (liftIO)
+import Blaze.ByteString.Builder (toByteString)
data Y = Y
mkYesod "Y" [parseRoutes|
/ RootR GET
+/single/#Text TextR GET
+/multi/*Texts TextsR GET
|]
instance Yesod Y
@@ -20,9 +26,16 @@ instance Yesod Y
getRootR :: Handler RepHtml
getRootR = defaultLayout $ toWidget [hamlet||]
+getTextR :: Text -> Handler RepHtml
+getTextR foo = defaultLayout $ toWidget [hamlet|%#{foo}%|]
+
+getTextsR :: [Text] -> Handler RepHtml
+getTextsR foos = defaultLayout $ toWidget [hamlet|%#{show foos}%|]
+
linksTest :: Spec
linksTest = describe "Test.Links" $ do
it "linkToHome" case_linkToHome
+ it "blank path pieces" case_blanks
runner :: Session () -> IO ()
runner f = toWaiApp Y >>= runSession f
@@ -31,3 +44,25 @@ case_linkToHome :: IO ()
case_linkToHome = runner $ do
res <- request defaultRequest
assertBody "\n\n" 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 "\n%%" res1
+
+ res2 <- request defaultRequest
+ { pathInfo = ["multi", "foo", "-", "bar"]
+ , rawPathInfo = "dummy2"
+ }
+ assertBody "\n%["foo","","bar"]%" res2
diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal
index c157ea20..2a741bf5 100644
--- a/yesod-core/yesod-core.cabal
+++ b/yesod-core/yesod-core.cabal
@@ -119,8 +119,10 @@ test-suite tests
,text
,http-types
, random
+ , blaze-builder
,HUnit
,QuickCheck >= 2 && < 3
+ ,transformers
ghc-options: -Wall
source-repository head