diff --git a/yesod-core/Yesod/Dispatch.hs b/yesod-core/Yesod/Dispatch.hs index a7f33d79..627f011a 100644 --- a/yesod-core/Yesod/Dispatch.hs +++ b/yesod-core/Yesod/Dispatch.hs @@ -14,6 +14,7 @@ module Yesod.Dispatch , mkYesodSubData , mkYesodDispatch , mkYesodSubDispatch + , mkYesodStaticPages -- ** Path pieces , PathPiece (..) , PathMultiPiece (..) @@ -49,9 +50,29 @@ import Network.HTTP.Types (status301) import Yesod.Routes.TH import Yesod.Content (chooseRep) import Yesod.Routes.Parse +import Data.List (partition) type Texts = [Text] +mkYesodStaticPages :: String -> [StaticPageRoute] -> Q [Dec] +mkYesodStaticPages name routes = + let (staticGets, staticResources) = partition isGet routes + gets = ListE (map (LitE . StringL . toString) staticGets) + getsD = ValD (VarP (mkName "staticPageRoutePaths")) (NormalB gets) [] + in do yesod <- mkYesod name (map toResource staticResources) + return $ [getsD] ++ yesod + + where + isGet (StaticGet _) = True + isGet (StaticResource _) = False + toResource (StaticResource r) = r + toResource (StaticGet _) = error "expected resource" + toString (StaticGet str) = dropSlashes str + toString (StaticResource _) = error "did not expect resource" + dropSlashes str | last str == '/' = dropSlashes $ init str + | head str == '/' = dropSlashes $ tail str + | otherwise = str + -- | Generates URL datatype and site function for the given 'Resource's. This -- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter. -- Use 'parseRoutes' to create the 'Resource's. diff --git a/yesod-core/test/YesodCoreTest.hs b/yesod-core/test/YesodCoreTest.hs index 9a1d23c7..9eb2a84d 100644 --- a/yesod-core/test/YesodCoreTest.hs +++ b/yesod-core/test/YesodCoreTest.hs @@ -10,6 +10,7 @@ import YesodCoreTest.InternalRequest import YesodCoreTest.ErrorHandling import YesodCoreTest.Cache import qualified YesodCoreTest.Redirect as Redirect +import qualified YesodCoreTest.StaticPages as StaticPages import Test.Hspec @@ -25,4 +26,5 @@ specs = , errorHandlingTest , cacheTest , Redirect.specs + , StaticPages.specs ] diff --git a/yesod-core/test/YesodCoreTest/StaticPages.hs b/yesod-core/test/YesodCoreTest/StaticPages.hs new file mode 100644 index 00000000..b2b510ab --- /dev/null +++ b/yesod-core/test/YesodCoreTest/StaticPages.hs @@ -0,0 +1,33 @@ +{-# OPTIONS_GHC -fno-warn-unused-binds #-} +{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +module YesodCoreTest.StaticPages (specs) where + +import Test.Hspec +import Test.Hspec.HUnit () +import Test.HUnit + +import Yesod.Core +import Yesod.Routes.Parse (staticPageRoutes) + +data StaticPages = StaticPages + +mkYesodStaticPages "StaticPages" [staticPageRoutes| +/pages/ PageR +/pages/ + about + data + faq +|] + +instance Yesod StaticPages where approot _ = "" + +handlePageR :: Handler RepHtml +handlePageR = defaultLayout [whamlet|Hello World!|] + +specs :: [Spec] +specs = describe "staticPageRoutePaths" [ + it "lists static page routes" $ + ["pages","pages/about","pages/data","pages/faq"] @=? staticPageRoutePaths + ] diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index be247fad..6bdfab8a 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -127,6 +127,7 @@ test-suite tests , random ,HUnit ,QuickCheck >= 2 && < 3 + , yesod-routes >= 0.0 && < 0.1 ghc-options: -Wall source-repository head diff --git a/yesod-routes/Yesod/Routes/Parse.hs b/yesod-routes/Yesod/Routes/Parse.hs index b17e5fec..2dc93df7 100644 --- a/yesod-routes/Yesod/Routes/Parse.hs +++ b/yesod-routes/Yesod/Routes/Parse.hs @@ -7,11 +7,15 @@ module Yesod.Routes.Parse , parseRoutesNoCheck , parseRoutesFileNoCheck , parseType + , staticPageRoutes + , staticPageRoutesFile + , StaticPageRoute (..) ) where import Language.Haskell.TH.Syntax import Data.Maybe -import Data.Char (isUpper) +import Data.Char (isUpper, isSpace) +import Data.List (intercalate) import Language.Haskell.TH.Quote import qualified System.IO as SIO import Yesod.Routes.TH @@ -49,24 +53,82 @@ readUtf8File fp = do -- | Same as 'parseRoutes', but performs no overlap checking. parseRoutesNoCheck :: QuasiQuoter parseRoutesNoCheck = QuasiQuoter - { quoteExp = lift . resourcesFromString - } + { quoteExp = lift . resourcesFromString } + +-- | QuasiQuoter for 'staticPageRoutesFromString' +staticPageRoutes :: QuasiQuoter +staticPageRoutes = QuasiQuoter + { quoteExp = lift . staticPageRoutesFromString } + +-- | parse a file with 'staticPageRoutesFromString' +staticPageRoutesFile :: FilePath -> Q Exp +staticPageRoutesFile fp = do + s <- qRunIO $ readUtf8File fp + quoteExp staticPageRoutes s + +data StaticPageRoute = StaticGet String | StaticResource (Resource String) +instance Lift StaticPageRoute where + lift (StaticGet str) = [|StaticGet $(lift str)|] + lift (StaticResource r) = [|StaticResource $(lift r)|] + +-- | Convert a multi-line string to a set of routes. +-- like normal route parsing, but there are just route paths, no route constructors +-- This is a partial function which calls 'error' on invalid input. +staticPageRoutesFromString :: String -> [StaticPageRoute] +staticPageRoutesFromString = parseRoutesFromString staticPageRoute + where + staticPageRoute r [] = Just (StaticGet r) + staticPageRoute r rest = fmap StaticResource $ resourceFromLine r rest -- | 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 justResourceFromLine + +resourceFromLine :: String -> [String] -> Maybe (Resource String) +resourceFromLine fullRoute (constr:rest) = + let (pieces, mmulti) = piecesFromString $ drop1Slash fullRoute + disp = dispatchFromString rest mmulti + in Just $ Resource constr pieces disp +resourceFromLine _ [] = Nothing -- an indenter: there should be indented routes afterwards + + +justResourceFromLine :: String -> [String] -> Maybe (Resource String) +justResourceFromLine x xs = + case resourceFromLine x xs of + Nothing -> error $ "Invalid resource line: " ++ (intercalate " " (x:xs)) + r -> r + +-- | 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 (checkEndSlash route, route) + else (noIndent, noIndent ++ route) + in mkRoute fullRoute rest : parseLines newNoIndent ls + [] -> parseLines noIndent ls + parseLines _ [] = [] + + checkEndSlash route = + if last route /= '/' + then error "the route indenter was expected to have a slash: " ++ route + else route dispatchFromString :: [String] -> Maybe String -> Dispatch String dispatchFromString rest mmulti