diff --git a/.gitignore b/.gitignore index 9c47e93c..64faee7b 100644 --- a/.gitignore +++ b/.gitignore @@ -8,3 +8,4 @@ cabal-dev/ yesod/foobar/ .virthualenv /vendor/ +/.shelly/ diff --git a/demo/appcache/AppCache.hs b/demo/appcache/AppCache.hs new file mode 100644 index 00000000..5283d17a --- /dev/null +++ b/demo/appcache/AppCache.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +module AppCache where + +import Control.Monad (when) +import Control.Monad.Trans.Writer +import Data.Hashable (hashWithSalt) +import Data.List (intercalate) +import qualified Data.Set as Set +import Data.Text (Text) +import Data.Text (pack) +import Language.Haskell.TH.Syntax +import Yesod.Core +import Yesod.Routes.TH + +newtype AppCache = AppCache { unAppCache :: Text } + +appCache :: [ResourceTree String] -> Q Exp +appCache trees = do + piecesSet <- execWriterT $ mapM_ (goTree id) trees + let body = unlines $ map toPath $ Set.toList piecesSet + hash = hashWithSalt 0 body + total = concat + [ "CACHE MANIFEST\n# Version: " + , show hash + , "\n\nCACHE:\n" + , body + ] + [|return (AppCache (pack total))|] + where + toPath [] = "/" + toPath x = concatMap ('/':) x + +goTree :: Monad m + => ([String] -> [String]) + -> ResourceTree String + -> WriterT (Set.Set [String]) m () +goTree front (ResourceLeaf res) = do + pieces' <- goPieces (resourceName res) $ resourcePieces res + when ("CACHE" `elem` resourceAttrs res) $ + tell $ Set.singleton $ front pieces' +goTree front (ResourceParent name pieces trees) = do + pieces' <- goPieces name pieces + mapM_ (goTree $ front . (pieces' ++)) trees + +goPieces :: Monad m => String -> [(CheckOverlap, Piece String)] -> m [String] +goPieces name = + mapM (goPiece . snd) + where + goPiece (Static s) = return s + goPiece (Dynamic _) = fail $ concat + [ "AppCache only applies to fully-static paths, but " + , name + , " has dynamic pieces." + ] + +instance ToContent AppCache where + toContent = toContent . unAppCache +instance ToTypedContent AppCache where + toTypedContent = TypedContent "text/cache-manifest" . toContent diff --git a/demo/appcache/Main.hs b/demo/appcache/Main.hs new file mode 100644 index 00000000..d48c6830 --- /dev/null +++ b/demo/appcache/Main.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +import AppCache +import Routes +import Yesod.Core + +instance Yesod App + +mkYesodDispatch "App" resourcesApp + +getHomeR :: Handler String +getHomeR = return "Hello" + +getSomethingR :: Handler String +getSomethingR = return "Hello" + +getAppCacheR :: Handler AppCache +getAppCacheR = $(appCache resourcesApp) + +main :: IO () +main = warp 3000 App diff --git a/demo/appcache/Routes.hs b/demo/appcache/Routes.hs new file mode 100644 index 00000000..78f2826b --- /dev/null +++ b/demo/appcache/Routes.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +module Routes where + +import Yesod.Core + +data App = App + +mkYesodData "App" [parseRoutes| +/ HomeR GET +/some/thing SomethingR GET !CACHE +/appcache AppCacheR GET +|] diff --git a/yesod-core/Yesod/Core/Internal/TH.hs b/yesod-core/Yesod/Core/Internal/TH.hs index 9ed273f1..c66a1849 100644 --- a/yesod-core/Yesod/Core/Internal/TH.hs +++ b/yesod-core/Yesod/Core/Internal/TH.hs @@ -44,13 +44,7 @@ mkYesodSubData name res = mkYesodDataGeneral name True res mkYesodDataGeneral :: String -> Bool -> [ResourceTree String] -> Q [Dec] mkYesodDataGeneral name isSub res = do let (name':rest) = words name - (x, _) <- mkYesodGeneral name' rest isSub res - let rname = mkName $ "resources" ++ name - eres <- lift res - let y = [ SigD rname $ ListT `AppT` (ConT ''ResourceTree `AppT` ConT ''String) - , FunD rname [Clause [] (NormalB eres) []] - ] - return $ x ++ y + fmap fst $ mkYesodGeneral name' rest isSub res -- | See 'mkYesodData'. mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec] @@ -71,10 +65,22 @@ mkYesodGeneral :: String -- ^ foundation type -> [ResourceTree String] -> Q([Dec],[Dec]) mkYesodGeneral name args isSub resS = do - renderRouteDec <- mkRenderRouteInstance site res - dispatchDec <- mkDispatchInstance site res - parse <- mkParseRouteInstance site res - return (parse : renderRouteDec ++ if isSub then [] else masterTypeSyns site, dispatchDec) + renderRouteDec <- mkRenderRouteInstance site res + dispatchDec <- mkDispatchInstance site res + parse <- mkParseRouteInstance site res + let rname = mkName $ "resources" ++ name + eres <- lift resS + let resourcesDec = + [ SigD rname $ ListT `AppT` (ConT ''ResourceTree `AppT` ConT ''String) + , FunD rname [Clause [] (NormalB eres) []] + ] + let dataDec = concat + [ [parse] + , renderRouteDec + , resourcesDec + , if isSub then [] else masterTypeSyns site + ] + return (dataDec, dispatchDec) where site = foldl' AppT (ConT $ mkName name) (map (VarT . mkName) args) res = map (fmap parseType) resS diff --git a/yesod-core/test/YesodCoreTest/MediaData.hs b/yesod-core/test/YesodCoreTest/MediaData.hs index 6a33fab3..9036d41f 100644 --- a/yesod-core/test/YesodCoreTest/MediaData.hs +++ b/yesod-core/test/YesodCoreTest/MediaData.hs @@ -8,5 +8,5 @@ import Yesod.Core data Y = Y mkYesodData "Y" [parseRoutes| / RootR GET -/static StaticR GET +/static StaticR !IGNORED GET !alsoIgnored |] diff --git a/yesod-routes/Yesod/Routes/Parse.hs b/yesod-routes/Yesod/Routes/Parse.hs index fc16eef3..3c53cdec 100644 --- a/yesod-routes/Yesod/Routes/Parse.hs +++ b/yesod-routes/Yesod/Routes/Parse.hs @@ -73,11 +73,22 @@ resourcesFromString = in ((ResourceParent (init constr) pieces children :), otherLines'') (pattern:constr:rest) -> let (pieces, mmulti) = piecesFromString $ drop1Slash pattern - disp = dispatchFromString rest mmulti - in ((ResourceLeaf (Resource constr pieces disp):), otherLines) + (attrs, rest') = takeAttrs rest + disp = dispatchFromString rest' mmulti + in ((ResourceLeaf (Resource constr pieces disp attrs):), otherLines) [] -> (id, otherLines) _ -> error $ "Invalid resource line: " ++ thisLine +-- | Take attributes out of the list and put them in the first slot in the +-- result tuple. +takeAttrs :: [String] -> ([String], [String]) +takeAttrs = + go id id + where + go x y [] = (x [], y []) + go x y (('!':attr):rest) = go (x . (attr:)) y rest + go x y (z:rest) = go x (y . (z:)) rest + dispatchFromString :: [String] -> Maybe String -> Dispatch String dispatchFromString rest mmulti | null rest = Methods mmulti [] diff --git a/yesod-routes/Yesod/Routes/TH/Types.hs b/yesod-routes/Yesod/Routes/TH/Types.hs index 2b69a594..d0a04052 100644 --- a/yesod-routes/Yesod/Routes/TH/Types.hs +++ b/yesod-routes/Yesod/Routes/TH/Types.hs @@ -39,16 +39,17 @@ data Resource typ = Resource { resourceName :: String , resourcePieces :: [(CheckOverlap, Piece typ)] , resourceDispatch :: Dispatch typ + , resourceAttrs :: [String] } deriving Show type CheckOverlap = Bool instance Functor Resource where - fmap f (Resource a b c) = Resource a (map (second $ fmap f) b) (fmap f c) + fmap f (Resource a b c d) = Resource a (map (second $ fmap f) b) (fmap f c) d instance Lift t => Lift (Resource t) where - lift (Resource a b c) = [|Resource $(lift a) $(lift b) $(lift c)|] + lift (Resource a b c d) = [|Resource a b c d|] data Piece typ = Static String | Dynamic typ deriving Show @@ -91,6 +92,6 @@ flatten :: [ResourceTree a] -> [FlatResource a] flatten = concatMap (go id) where - go front (ResourceLeaf (Resource a b c)) = [FlatResource (front []) a b c] + go front (ResourceLeaf (Resource a b c _)) = [FlatResource (front []) a b c] go front (ResourceParent name pieces children) = concatMap (go (front . ((name, pieces):))) children diff --git a/yesod-routes/test/main.hs b/yesod-routes/test/main.hs index 178449b1..9a45d502 100644 --- a/yesod-routes/test/main.hs +++ b/yesod-routes/test/main.hs @@ -106,11 +106,11 @@ getMySubParam _ = MySubParam do texts <- [t|[Text]|] let ress = map ResourceLeaf - [ Resource "RootR" [] $ Methods Nothing ["GET"] - , Resource "BlogPostR" (addCheck [Static "blog", Dynamic $ ConT ''Text]) $ Methods Nothing ["GET", "POST"] - , Resource "WikiR" (addCheck [Static "wiki"]) $ Methods (Just texts) [] - , Resource "SubsiteR" (addCheck [Static "subsite"]) $ Subsite (ConT ''MySub) "getMySub" - , Resource "SubparamR" (addCheck [Static "subparam", Dynamic $ ConT ''Int]) $ Subsite (ConT ''MySubParam) "getMySubParam" + [ Resource "RootR" [] (Methods Nothing ["GET"]) [] + , Resource "BlogPostR" (addCheck [Static "blog", Dynamic $ ConT ''Text]) (Methods Nothing ["GET", "POST"]) [] + , Resource "WikiR" (addCheck [Static "wiki"]) (Methods (Just texts) []) [] + , Resource "SubsiteR" (addCheck [Static "subsite"]) (Subsite (ConT ''MySub) "getMySub") [] + , Resource "SubparamR" (addCheck [Static "subparam", Dynamic $ ConT ''Int]) (Subsite (ConT ''MySubParam) "getMySubParam") [] ] addCheck = map ((,) True) rrinst <- mkRenderRouteInstance (ConT ''MyApp) ress