Route attributes/appcache example #518

.gitignore

@@ -8,3 +8,4 @@ cabal-dev/
 yesod/foobar/
 .virthualenv
 /vendor/
+/.shelly/

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

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

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
+|]

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
 

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
 |]

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 []

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

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