Permalink
Browse files

Add infrastructure to allow reloading of individual snaplets

Includes a heist reloader that reloads only templates without reloading the rest
of the site.
  • Loading branch information...
1 parent 2de01d6 commit a9292b5fa5e18b9e3f95ae0df60b80592cfca839 @mightybyte mightybyte committed Mar 25, 2013
@@ -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,
@@ -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
View
@@ -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,
View
@@ -101,7 +101,9 @@ module Snap.Snaplet
-- * Handlers
, Handler
+ , failIfNotLocal
, reloadSite
+ , modifyMaster
, bracketHandler
-- * Serving Applications
@@ -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
+ }
------------------------------------------------------------------------------
View
@@ -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
@@ -125,19 +125,6 @@ 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)
=> (HeistState (Handler b b) -> HeistState (Handler b 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
@@ -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
@@ -21,7 +21,6 @@ module Snap.Snaplet.Heist.Interpreted
, addConfig
, modifyHeistState
, withHeistState
- , addSplices
-- * Handler Functions
-- $handlerSection
@@ -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
Oops, something went wrong.

0 comments on commit a9292b5

Please sign in to comment.