Add infrastructure to allow reloading of individual snaplets

Includes a heist reloader that reloads only templates without reloading the rest
of the site.

project_template/default/foo.cabal

@@ -27,7 +27,7 @@ Executable projname
     heist                     >= 0.12    && < 0.13,
     MonadCatchIO-transformers >= 0.2.1   && < 0.4,
     mtl                       >= 2       && < 3,
-    snap                      >= 0.11    && < 0.12,
+    snap                      >= 0.11    && < 0.13,
     snap-core                 >= 0.9     && < 0.11,
     snap-server               >= 0.9     && < 0.11,
     snap-loader-static        >= 0.9     && < 0.10,

project_template/tutorial/foo.cabal

@@ -22,7 +22,7 @@ Executable projname
     bytestring                >= 0.9.1   && < 0.11,
     MonadCatchIO-transformers >= 0.2.1   && < 0.4,
     mtl                       >= 2       && < 3,
-    snap                      >= 0.11    && < 0.12,
+    snap                      >= 0.11    && < 0.13,
     snap-core                 >= 0.9     && < 0.11,
     snap-server               >= 0.9     && < 0.11
 

snap.cabal

@@ -1,5 +1,5 @@
 name:           snap
-version:        0.11.3
+version:        0.12.0
 synopsis:       Top-level package for the Snap Web Framework
 description:
     This is the top-level package for the official Snap Framework libraries.
@@ -167,7 +167,7 @@ Library
     snap-core                 >= 0.9      && < 0.11,
     snap-server               >= 0.9      && < 0.11,
     stm                       >= 2.2      && < 2.5,
-    syb                       >= 0.1      && < 0.4,
+    syb                       >= 0.1      && < 0.5,
     text                      >= 0.11     && < 0.12,
     time                      >= 1.1      && < 1.5,
     transformers              >= 0.2      && < 0.4,

src/Snap/Snaplet.hs

@@ -101,7 +101,9 @@ module Snap.Snaplet
 
   -- * Handlers
   , Handler
+  , failIfNotLocal
   , reloadSite
+  , modifyMaster
   , bracketHandler
 
   -- * Serving Applications

src/Snap/Snaplet/Auth/SpliceHelpers.hs

@@ -52,14 +52,17 @@ import           Snap.Snaplet.Heist
 -- \<loggedInUser\>
 addAuthSplices
   :: HasHeist b
-  => SnapletLens b (AuthManager b)
+  => Snaplet (Heist b)
+  -> SnapletLens b (AuthManager b)
       -- ^ A lens reference to 'AuthManager'
   -> Initializer b v ()
-addAuthSplices auth = addSplices
-    [ ("ifLoggedIn", ifLoggedIn auth)
-    , ("ifLoggedOut", ifLoggedOut auth)
-    , ("loggedInUser", loggedInUser auth)
-    ]
+addAuthSplices h auth = addConfig h $ mempty
+    { hcInterpretedSplices = [ ("ifLoggedIn", ifLoggedIn auth)
+                             , ("ifLoggedOut", ifLoggedOut auth)
+                             , ("loggedInUser", loggedInUser auth)
+                             ]
+    , hcCompiledSplices = compiledAuthSplices auth
+    }
 
 
 ------------------------------------------------------------------------------

src/Snap/Snaplet/Heist.hs

@@ -13,14 +13,14 @@ module Snap.Snaplet.Heist
   -- $initializerSection
   , heistInit
   , heistInit'
+  , Unclassed.heistReloader
   , Unclassed.setInterpreted
   , Unclassed.getCurHeistConfig 
   , addTemplates
   , addTemplatesAt
   , Unclassed.addConfig
   , modifyHeistState
   , withHeistState
-  , addSplices
 
   -- * Handler Functions
   -- $handlerSection
@@ -81,7 +81,7 @@ import           Snap.Snaplet.HeistNoClass ( heistInit
 -- >
 -- > appInit = makeSnaplet "app" "" Nothing $ do
 -- >     h <- nestSnaplet "heist" heist $ heistInit "templates"
--- >     addSplices myAppSplices
+-- >     addConfig h heistConfigWithMyAppSplices
 -- >     return $ App h
 class HasHeist b where
     -- | A lens to the Heist snaplet.  The b parameter to Heist will
@@ -124,19 +124,6 @@ addTemplatesAt h pfx p =
     withTop' heistLens (Unclassed.addTemplatesAt h pfx p)
 
 
-------------------------------------------------------------------------------
--- | Allows snaplets to add interpreted splices.
---
--- NOTE: The splices added with this function will not work if you render your
--- templates with cRender.  To add splices that work with cRender, you have to
--- use the addConfig function to add compiled splices or load time splices.
-addSplices :: (HasHeist b)
-           => [(Text, Unclassed.SnapletISplice b)]
-               -- ^ Splices to bind
-           -> Initializer b v ()
-addSplices = Unclassed.addSplices' heistLens
-
-
 ------------------------------------------------------------------------------
 -- | More general function allowing arbitrary HeistState modification.
 modifyHeistState :: (HasHeist b)
@@ -161,8 +148,8 @@ withHeistState = Unclassed.withHeistState' heistLens
 -- rendering that checks the preferred rendering mode and chooses
 -- appropriately.  Functions beginning with a 'c' prefix use compiled template
 -- rendering.  The other functions use the older interpreted rendering.
--- Splices added with addSplices will only work if you use interpreted
--- rendering.
+-- Interpreted splices added with addConfig will only work if you use
+-- interpreted rendering.
 --
 -- The generic functions are useful if you are writing general snaplets that
 -- use heist, but need to work for applications that use either interpreted

src/Snap/Snaplet/Heist/Internal.hs

@@ -1,6 +1,7 @@
 module Snap.Snaplet.Heist.Internal where
 
 import           Prelude hiding ((.), id)
+import           Control.Lens
 import           Data.IORef
 import           Heist
 import           Heist.Splices.Cache
@@ -20,8 +21,10 @@ data Heist b = Configuring
                  { _heistConfig :: IORef (HeistConfig (Handler b b), DefaultMode)
                  }
              | Running
-                 { _heistState    :: HeistState (Handler b b)
-                 , _heistCTS      :: CacheTagState
-                 , _defMode       :: DefaultMode
+                 { _masterConfig :: HeistConfig (Handler b b)
+                 , _heistState   :: HeistState (Handler b b)
+                 , _heistCTS     :: CacheTagState
+                 , _defMode      :: DefaultMode
                  }
 
+makeLenses ''Heist

src/Snap/Snaplet/Heist/Interpreted.hs

@@ -21,7 +21,6 @@ module Snap.Snaplet.Heist.Interpreted
   , addConfig
   , modifyHeistState
   , withHeistState
-  , addSplices
 
   -- * Handler Functions
   -- $handlerSection

src/Snap/Snaplet/HeistNoClass.hs

@@ -19,6 +19,7 @@ module Snap.Snaplet.HeistNoClass
   , DefaultMode(..)
   , heistInit
   , heistInit'
+  , heistReloader
   , setInterpreted
   , getCurHeistConfig 
   , clearHeistCache
@@ -29,8 +30,6 @@ module Snap.Snaplet.HeistNoClass
   , modifyHeistState'
   , withHeistState
   , withHeistState'
-  , addSplices
-  , addSplices'
 
   , gRender
   , gRenderAs
@@ -95,7 +94,7 @@ changeState :: (HeistState (Handler a a) -> HeistState (Handler a a))
             -> Heist a
 changeState _ (Configuring _)  =
     error "changeState: HeistState has not been initialized"
-changeState f (Running hs cts dm) = Running (f hs) cts dm
+changeState f (Running hc hs cts dm) = Running hc (f hs) cts dm
 
 
 ------------------------------------------------------------------------------
@@ -106,6 +105,22 @@ clearHeistCache :: Heist b -> IO ()
 clearHeistCache = clearCacheTagState . _heistCTS
 
 
+------------------------------------------------------------------------------
+-- | Handler that triggers a template reload.  For large sites, this can be
+-- desireable because it may be much quicker than the full site reload
+-- provided at the /admin/reload route.  This allows you to reload only the
+-- heist templates  This handler is automatically set up by heistInit, but if
+-- you use heistInit', then you can create your own route with it.
+heistReloader :: Handler b (Heist b) ()
+heistReloader = do
+    h <- get
+    ehs <- liftIO $ runEitherT $ initHeist $ _masterConfig h
+    either (writeText . T.pack . unlines)
+           (\hs -> do writeText "Heist reloaded."
+                      modifyMaster $ set heistState hs h)
+           ehs
+
+
                          -----------------------------
                          -- SnapletSplice functions --
                          -----------------------------
@@ -130,14 +145,17 @@ type SnapletISplice b = SnapletHeist b (Handler b b) Template
 ------------------------------------------------------------------------------
 -- | The 'Initializer' for 'Heist'. This function is a convenience wrapper
 -- around `heistInit'` that uses defaultHeistState and sets up routes for all
--- the templates.
+-- the templates.  It sets up a \"heistReload\" route that reloads the heist
+-- templates when you request it from localhost.
 heistInit :: FilePath
               -- ^ Path to templates
           -> SnapletInit b (Heist b)
 heistInit templateDir = do
     makeSnaplet "heist" "" Nothing $ do
         hs <- heistInitWorker templateDir defaultConfig
-        addRoutes [ ("", heistServe) ]
+        addRoutes [ ("", heistServe)
+                  , ("heistReload", failIfNotLocal heistReloader)
+                  ]
         return hs
   where
     defaultConfig = mempty { hcLoadTimeSplices = defaultLoadTimeSplices }
@@ -157,8 +175,8 @@ heistInit' templateDir initialConfig =
 
 
 ------------------------------------------------------------------------------
--- | Internal worker function used by variantsof heistInit.  This is necessary
--- because of the divide between SnapletInit and Initializer.
+-- | Internal worker function used by variants of heistInit.  This is
+-- necessary because of the divide between SnapletInit and Initializer.
 heistInitWorker :: FilePath
                 -> HeistConfig (Handler b b)
                 -> Initializer b (Heist b) (Heist b)
@@ -167,14 +185,18 @@ heistInitWorker templateDir initialConfig = do
     let tDir = snapletPath </> templateDir
     templates <- liftIO $ runEitherT (loadTemplates tDir) >>=
                           either (error . concat) return
-    let config = initialConfig `mappend` mempty { hcTemplates = templates }
     printInfo $ T.pack $ unwords
         [ "...loaded"
         , (show $ Map.size templates)
         , "templates from"
         , tDir
         ]
+    let config = initialConfig `mappend`
+                 mempty { hcTemplateLocations = [loadTemplates tDir] }
     ref <- liftIO $ newIORef (config, Compiled)
+
+    -- FIXME This runs after all the initializers, but before post init
+    -- hooks registered by other snaplets.
     addPostInitHook finalLoadHook
     return $ Configuring ref
 
@@ -200,10 +222,10 @@ finalLoadHook :: Heist b -> EitherT Text IO (Heist b)
 finalLoadHook (Configuring ref) = do
     (hc,dm) <- lift $ readIORef ref
     (hs,cts) <- toTextErrors $ initHeistWithCacheTag hc
-    return $ Running hs cts dm
+    return $ Running hc hs cts dm
   where
     toTextErrors = bimapEitherT (T.pack . intercalate "\n") id
-finalLoadHook (Running _ _ _) = left "finalLoadHook called while running"
+finalLoadHook (Running _ _ _ _) = left "finalLoadHook called while running"
 
 
 ------------------------------------------------------------------------------
@@ -236,10 +258,10 @@ addTemplatesAt h urlPrefix templateDir = do
     rootUrl <- getSnapletRootURL
     let fullPrefix = (T.unpack $ decodeUtf8 rootUrl) </>
                      (T.unpack $ decodeUtf8 urlPrefix)
-        addPrefix = return . addTemplatePathPrefix
-                               (encodeUtf8 $ T.pack fullPrefix)
+        addPrefix = addTemplatePathPrefix
+                      (encodeUtf8 $ T.pack fullPrefix)
     ts <- liftIO $ runEitherT (loadTemplates templateDir) >>=
-                   either (error . concat) addPrefix
+                   either (error . concat) return
     printInfo $ T.pack $ unwords
         [ "...adding"
         , (show $ Map.size ts)
@@ -248,8 +270,10 @@ addTemplatesAt h urlPrefix templateDir = do
         , "with route prefix"
         , fullPrefix ++ "/"
         ]
+    let locations = [liftM addPrefix $ loadTemplates templateDir]
+        hc' = mempty { hcTemplateLocations = locations }
     liftIO $ atomicModifyIORef (_heistConfig $ view snapletValue h)
-        (\(hc,dm) -> ((hc `mappend` mempty { hcTemplates = ts }, dm), ()))
+        (\(hc,dm) -> ((hc `mappend` hc', dm), ()))
 
 
 getCurHeistConfig :: Snaplet (Heist b)
@@ -258,7 +282,7 @@ getCurHeistConfig h = case view snapletValue h of
     Configuring ref -> do
         (hc, _) <- liftIO $ readIORef ref
         return hc
-    Running _ _ _ ->
+    Running _ _ _ _ ->
         error "Can't get HeistConfig after heist is initialized."
 
 
@@ -304,27 +328,11 @@ addConfig h hc = case view snapletValue h of
     Configuring ref ->
         liftIO $ atomicModifyIORef ref
                    (\(hc1,dm) -> ((hc1 `mappend` hc, dm), ()))
-    Running _ _ _ -> do
+    Running _ _ _ _ -> do
         printInfo "finalLoadHook called while running"
         error "this shouldn't happen"
 
 
-------------------------------------------------------------------------------
-addSplices' :: SnapletLens (Snaplet b) (Heist b)
-            -> [(Text, SnapletISplice b)]
-            -> Initializer b v ()
-addSplices' heist splices = do
-    withTop' heist $ addPostInitHook $
-        return . changeState (I.bindSplices splices)
-
-
-------------------------------------------------------------------------------
-addSplices :: SnapletLens b (Heist b)
-           -> [(Text, SnapletISplice b)]
-           -> Initializer b v ()
-addSplices heist splices = addSplices' (subSnaplet heist) splices
-
-
                             -----------------------
                             -- Handler functions --
                             -----------------------
@@ -335,7 +343,7 @@ iRenderHelper :: Maybe MIMEType
              -> ByteString
              -> Handler b (Heist b) ()
 iRenderHelper c t = do
-    (Running hs _ _) <- get
+    (Running _ hs _ _) <- get
     withTop' id $ I.renderTemplate hs t >>= maybe pass serve
   where
     serve (b, mime) = do
@@ -349,7 +357,7 @@ cRenderHelper :: Maybe MIMEType
               -> ByteString
               -> Handler b (Heist b) ()
 cRenderHelper c t = do
-    (Running hs _ _) <- get
+    (Running _ hs _ _) <- get
     withTop' id $ maybe pass serve $ C.renderTemplate hs t
   where
     serve (b, mime) = do