fixup slashes

yesod-routes/Yesod/Routes/Parse.hs

@@ -7,15 +7,17 @@ module Yesod.Routes.Parse
     , parseRoutesNoCheck
     , parseRoutesFileNoCheck
     , parseType
+    , parseRoutePaths
     ) where
 
 import Language.Haskell.TH.Syntax
 import Data.Maybe
-import Data.Char (isUpper)
+import Data.Char (isUpper, isSpace)
 import Language.Haskell.TH.Quote
 import qualified System.IO as SIO
 import Yesod.Routes.TH
 import Yesod.Routes.Overlap (findOverlapNames)
+import System.FilePath.Posix ((</>))
 
 -- | A quasi-quoter to parse a string into a list of 'Resource's. Checks for
 -- overlapping routes, failing if present; use 'parseRoutesNoCheck' to skip the
@@ -49,24 +51,61 @@ readUtf8File fp = do
 -- | Same as 'parseRoutes', but performs no overlap checking.
 parseRoutesNoCheck :: QuasiQuoter
 parseRoutesNoCheck = QuasiQuoter
-    { quoteExp = lift . resourcesFromString
-    }
+    { quoteExp = lift . resourcesFromString }
+
+-- | Convert a multi-line string to a set of route paths.
+-- like normal route parsing, but there are just route paths, no route constructors or HTTP methods
+-- This can be used as a DSL for generating route paths that
+-- * closely matches your current routes file
+-- * allows indentation to imply prefixes
+--
+-- This is a partial function which calls 'error' on invalid input.
+parseRoutePaths :: String -> [String]
+parseRoutePaths = parseRoutesFromString staticPageRoute
+  where
+    staticPageRoute :: String -> [String] -> Maybe String
+    staticPageRoute r [] = Just $ stripEndSlash r
+    staticPageRoute r rest = error $ "line starting with: " ++ r ++ "\ndid not expect: " ++ show rest
+    stripEndSlash r = if last r == '/' then init r else r
 
 -- | Convert a multi-line string to a set of resources. See documentation for
 -- the format of this string. This is a partial function which calls 'error' on
 -- invalid input.
 resourcesFromString :: String -> [Resource String]
 resourcesFromString =
-    mapMaybe go . lines
+    parseRoutesFromString resourceFromLine
+
+resourceFromLine :: String -> [String] -> Maybe (Resource String)
+resourceFromLine fullRoute (constr:rest) =
+            let (pieces, mmulti) = piecesFromString $ fullRoute
+                disp = dispatchFromString rest mmulti
+             in Just $ Resource constr pieces disp
+resourceFromLine _ [] = Nothing -- an indenter: there should be indented routes afterwards
+
+
+-- | used by 'resourcesFromString' and 'staticPageRoutesFromString'
+parseRoutesFromString :: (String  -- ^ route pattern
+                      -> [String] -- ^ extra
+                      -> Maybe a)
+                      -> String -- ^ unparsed routes
+                      -> [a]
+parseRoutesFromString mkRoute =
+    catMaybes . (parseLines $ error "first route cannot be indented") . lines
   where
-    go s =
-        case takeWhile (/= "--") $ words s of
-            (pattern:constr:rest) ->
-                let (pieces, mmulti) = piecesFromString $ drop1Slash pattern
-                    disp = dispatchFromString rest mmulti
-                 in Just $ Resource constr pieces disp
-            [] -> Nothing
-            _ -> error $ "Invalid resource line: " ++ s
+    indents :: String -> Int
+    indents = length . takeWhile isSpace
+
+    parseLines noIndent (l:ls) =
+        case takeWhile (/= "--") $ words l of
+            (route:rest) ->
+                let (newNoIndent, fullRoute) =
+                        if indents l == 0
+                          -- important: the check is done lazily
+                          then (route, route)
+                          else (noIndent, noIndent </> route)
+                 in mkRoute (dropPreSlash fullRoute) rest : parseLines newNoIndent ls
+            [] -> parseLines noIndent ls
+    parseLines _ [] = []
 
 dispatchFromString :: [String] -> Maybe String -> Dispatch String
 dispatchFromString rest mmulti
@@ -78,9 +117,9 @@ dispatchFromString [_, _] Just{} =
     error "Subsites cannot have a multipiece"
 dispatchFromString rest _ = error $ "Invalid list of methods: " ++ show rest
 
-drop1Slash :: String -> String
-drop1Slash ('/':x) = x
-drop1Slash x = x
+dropPreSlash :: String -> String
+dropPreSlash ('/':x) = x
+dropPreSlash x = x
 
 piecesFromString :: String -> ([(CheckOverlap, Piece String)], Maybe String)
 piecesFromString "" = ([], Nothing)

yesod-routes/test/main.hs

@@ -10,16 +10,17 @@
 {-# LANGUAGE CPP #-}
 import Test.Hspec.Monadic
 import Test.Hspec.HUnit ()
-import Test.HUnit ((@?=))
+import Test.HUnit ((@?=), (@=?))
 import Data.Text (Text, pack, unpack, singleton)
 import Yesod.Routes.Dispatch hiding (Static, Dynamic)
 import Yesod.Routes.Class hiding (Route)
 import qualified Yesod.Routes.Class as YRC
 import qualified Yesod.Routes.Dispatch as D
-import Yesod.Routes.Parse (parseRoutesNoCheck)
+import Yesod.Routes.Parse (parseRoutesNoCheck, parseRoutePaths)
 import Yesod.Routes.Overlap (findOverlapNames)
 import Yesod.Routes.TH hiding (Dispatch)
 import Language.Haskell.TH.Syntax
+import Data.List (intercalate)
 
 class ToText a where
     toText :: a -> Text
@@ -224,7 +225,15 @@ thDispatchAlias master sub toMaster app404 handler405 method0 pieces0 =
 -}
 
 main :: IO ()
-main = hspecX $ do
+main = hspecX $  do
+    describe "parseRoutePaths" $
+        it "lists static page routes" $
+          ["pages","pages/about","pages/data","pages/faq"] @=? parseRoutePaths (intercalate "\n" [
+               "/pages/"
+              ,"       about"
+              ,"       data"
+              ,"       faq"
+              ])
     describe "justRoot" $ do
         it "dispatches correctly" $ test justRoot [] @?= Just 1
         it "fails correctly" $ test justRoot ["foo"] @?= Nothing

yesod-routes/yesod-routes.cabal

@@ -19,6 +19,7 @@ library
                    , containers                >= 0.2      && < 0.5
                    , template-haskell
                    , path-pieces               >= 0.1      && < 0.2
+                   , filepath                  >= 1
 
     exposed-modules: Yesod.Routes.Dispatch
                      Yesod.Routes.TH

yesod-static/Yesod/Static.hs

@@ -34,6 +34,8 @@ module Yesod.Static
       -- * Smart constructor
     , static
     , staticDevel
+    , staticAssumeHtml
+    , staticAssumeHtmlDevel
     , embed
       -- * Template Haskell helpers
     , staticFiles
@@ -90,7 +92,9 @@ import Network.Wai.Application.Static
     , fromFilePath
     , FilePath
     , ETagLookup
-    , webAppSettingsWithLookup
+    , webAppSettingsLookupConf
+    , WebAppLookupConf(..)
+    , defaultMimeTypeLookup
     )
 
 -- | Type used for the subsite with static contents.
@@ -106,8 +110,24 @@ type StaticRoute = Route Static
 -- added.
 static :: Prelude.FilePath -> IO Static
 static dir = do
-    hashLookup <- cachedETagLookup dir
-    return $ Static $ webAppSettingsWithLookup (toFilePath dir) hashLookup
+  hashLookup <- cachedETagLookup dir
+  staticFromSettings dir False hashLookup
+
+staticFromSettings :: Prelude.FilePath -> Bool -> ETagLookup -> IO Static
+staticFromSettings dir shouldAppend hashLookup = do
+    return $ Static $ webAppSettingsLookupConf WebAppLookupConf {
+      assumeHtml = shouldAppend,
+      prefixDir = (toFilePath dir),
+      etagLookup = hashLookup,
+      mimeTypeLookup = defaultMimeTypeLookup
+    }
+
+-- | same as static, but if there is no file extension in the request then assume html
+staticAssumeHtml :: Prelude.FilePath -> IO Static
+staticAssumeHtml dir = do
+  hashLookup <- cachedETagLookup dir
+  staticFromSettings dir True hashLookup
+
 
 -- | Same as 'static', but does not assumes that the files do not
 -- change and checks their modification time whenever a request
@@ -115,7 +135,13 @@ static dir = do
 staticDevel :: Prelude.FilePath -> IO Static
 staticDevel dir = do
     hashLookup <- cachedETagLookupDevel dir
-    return $ Static $ webAppSettingsWithLookup (toFilePath dir) hashLookup
+    staticFromSettings dir False hashLookup
+
+-- | same as staticDevel, but if there is no file extension in the request then assume html
+staticAssumeHtmlDevel :: Prelude.FilePath -> IO Static
+staticAssumeHtmlDevel dir = do
+    hashLookup <- cachedETagLookupDevel dir
+    staticFromSettings dir True hashLookup
 
 -- | Produce a 'Static' based on embedding all of the static
 -- files' contents in the executable at compile time.