Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

support static page route parsing

  • Loading branch information...
commit df23b8f87694ecac319408e6861d803c99b6345f 1 parent 0eb62a9
@gregwebs gregwebs authored
View
21 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.
View
2  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
]
View
33 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
+ ]
View
1  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
View
86 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
Please sign in to comment.
Something went wrong with that request. Please try again.