Browse files

Merge branch 'master' of git.snapframework.com:snap

  • Loading branch information...
2 parents 0923faa + 5d47444 commit f156b4994c4ad68e2db993a8293e579845d1fe16 @gregorycollins gregorycollins committed Feb 5, 2011
Showing with 96 additions and 116 deletions.
  1. +2 −3 snap.cabal
  2. +35 −32 src/Snap/Extension.hs
  3. +18 −10 src/Snap/Extension/Heist.hs
  4. +39 −26 src/Snap/Extension/Heist/Impl.hs
  5. +0 −44 src/Snap/Heist.hs
  6. +2 −1 src/Snap/StarterTH.hs
View
5 snap.cabal
@@ -38,8 +38,7 @@ Library
Snap.Extension.Heist.Impl,
Snap.Extension.Loader.Devel,
Snap.Extension.Server,
- Snap.Extension,
- Snap.Heist
+ Snap.Extension
other-modules:
Snap.Extension.Loader.Devel.Evaluator,
@@ -55,7 +54,7 @@ Library
filepath >= 1.1 && <1.3,
MonadCatchIO-transformers >= 0.2.1 && < 0.3,
snap-core == 0.4.*,
- heist >= 0.4 && < 0.5,
+ heist >= 0.5 && < 0.6,
hint >= 0.3.3.1 && < 0.4,
template-haskell >= 2.3 && < 2.6,
time >= 1.0 && < 1.3
View
67 src/Snap/Extension.hs
@@ -82,9 +82,9 @@ import System.IO
implementations live in Snap.Extension.Session.HDBC,
Snap.Extension.Session.MongoDB and Snap.Extension.Session.CookieStore.
- Keeping this in mind, there are a number of things you need to do to use Snap
- extensions in your application. Let's walk through how to set up a simple
- application with the Heist extension turned on.
+ Keeping this in mind, there are a number of things you need to do to use
+ Snap extensions in your application. Let's walk through how to set up a
+ simple application with the Heist extension turned on.
-}
@@ -112,11 +112,11 @@ data AppState = AppState
{ heistState :: HeistState App }
@
- An important thing to note is that the -State types that we use in the fields
- of AppState are specific to each implementation of a extension's interface.
- That is, Snap.Extension.Session.HDBC will export a different SessionState to
- Snap.Extension.Session.CookieStore, whose internal representation might be
- completely different.
+ An important thing to note is that the -State types that we use in the
+ fields of AppState are specific to each implementation of a extension's
+ interface. That is, Snap.Extension.Session.HDBC will export a different
+ SessionState to Snap.Extension.Session.CookieStore, whose internal
+ representation might be completely different.
This state is what the extension's implementation needs to be able to do its
job.
@@ -130,13 +130,13 @@ data AppState = AppState
actually get to use this interface and all the functionality that these
extensions export? What is actually being extended?
- We use the interface provided by an extension inside our application's monad,
- App. Snap extensions extend our App with new functionality by allowing us to
- user their exported functions inside of our handlers. For example, the Heist
- extension provides the function:
+ We use the interface provided by an extension inside our application's
+ monad, App. Snap extensions extend our App with new functionality by
+ allowing us to user their exported functions inside of our handlers. For
+ example, the Heist extension provides the function:
- @render :: MonadHeist m => ByteString -> m ()@ that renders a template by its
- name.
+ @render :: MonadHeist m => ByteString -> m ()@ that renders a template by
+ its name.
Is App a 'MonadHeist'? Well, not quite yet. Any 'MonadReader' which is also
a 'MonadSnap' whose environment contains a 'HeistState' is a 'MonadHeist'.
@@ -215,23 +215,24 @@ main = do
quickHttpServe site `finally` cleanup
@
- You'll notice we're using 'defaultReloadHandler'. This is a function exported
- by "Snap.Extension" with the type signature
+ You'll notice we're using 'defaultReloadHandler'. This is a function
+ exported by "Snap.Extension" with the type signature
@MonadSnap m => IO [(ByteString, Maybe ByteString)] -> m ()@ It takes the
reload action returned by 'runInitializer' and returns a 'Snap' action which
- renders a simple page showing how the reload went. To avoid denial-of-service
- attacks, the reload handler only works for requests made from the local host.
+ renders a simple page showing how the reload went. To avoid denial of
+ service attacks, the reload handler only works for requests made from the
+ local host.
-}
{- $httpserve
This is, of course, a lot of avoidable boilerplate. Snap extensions framework
- comes with another module "Snap.Extension.Server", which provides an interface
- mimicking that of "Snap.Http.Server". Their function names clash, so if you
- need to use both of them in the same module, use a qualified import. Using
- this module, the example above becomes:
+ comes with another module "Snap.Extension.Server", which provides an
+ interface mimicking that of "Snap.Http.Server". Their function names clash,
+ so if you need to use both of them in the same module, use a qualified
+ import. Using this module, the example above becomes:
@
import Snap.Extension.Server
@@ -248,7 +249,7 @@ main = quickHttpServe appRunner site
defaults augmented with any options specified on the command-line. The
default reload handler path in this case is "admin/reload".
- If you wanted to change this to nullReloadHandler, this is what you would do:
+ If you wanted to change this to nullReloadHandler, you would do this:
@
import Snap.Extension.Server
@@ -366,9 +367,9 @@ runInitializer
-- ^ A web handler in your application's monad
-> IO (Snap (), IO (), IO [(ByteString, Maybe ByteString)])
-- ^ Returns a 'Snap' handler, a cleanup action, and a reload action. The
- -- list returned by the reload action is for error reporting. There is one
- -- tuple in the list for each Snap extension; the first element of the
- -- tuple is the name of the Snap extension, and the second is a Maybe
+ -- list returned by the reload action is for error reporting. There is
+ -- one tuple in the list for each Snap extension; the first element of
+ -- the tuple is the name of the Snap extension, and the second is a Maybe
-- which contains Nothing if there was no error reloading that extension
-- and a Just with the ByteString containing the error message if there
-- was.
@@ -422,9 +423,10 @@ runInitializerWithoutReloadAction i se = do
------------------------------------------------------------------------------
instance Functor Initializer where
- fmap f (Initializer r) = Initializer $ \v -> r v >>= \e -> return $ case e of
- Left s -> Left $ f s
- Right (SCR s a b) -> Right $ SCR (f s) a b
+ fmap f (Initializer r) = Initializer $ \v -> r v >>= \e -> return $
+ case e of
+ Left s -> Left $ f s
+ Right (SCR s a b) -> Right $ SCR (f s) a b
------------------------------------------------------------------------------
@@ -450,9 +452,10 @@ instance MonadIO Initializer where
join' :: Initializer (Initializer s) -> Initializer s
join' (Initializer r) = Initializer $ \v -> r v >>= \e -> case e of
Left (Initializer r') -> r' v
- Right (SCR (Initializer r') a b) -> r' v >>= \e' -> return $ Right $ case e' of
- Left s -> SCR s a b
- Right (SCR s a' b') -> SCR s (a' >> a) (liftM2 (++) b b')
+ Right (SCR (Initializer r') a b) -> r' v >>= \e' -> return $ Right $
+ case e' of
+ Left s -> SCR s a b
+ Right (SCR s a' b') -> SCR s (a' >> a) (liftM2 (++) b b')
------------------------------------------------------------------------------
View
28 src/Snap/Extension/Heist.hs
@@ -1,5 +1,6 @@
+{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
{-|
@@ -13,22 +14,25 @@ and 'render' into a single function call.
and can be used to turn your application's monad into a 'MonadHeist'.
'MonadHeist' is unusual among Snap extensions in that it's a multi-parameter
-typeclass. The last parameter is your application's monad, and the first is the
-monad you want the 'TemplateState' to use. This is usually, but not always,
-also your application's monad.
+typeclass. The last parameter is your application's monad, and the first is
+the monad you want the 'TemplateState' to use. This is usually, but not
+always, also your application's monad.
This module should not be used directly. Instead, import
"Snap.Extension.Heist.Impl" in your application.
-}
-module Snap.Extension.Heist
+module Snap.Extension.Heist
( MonadHeist(..)
, renderWithSplices ) where
import Control.Applicative
import Data.ByteString (ByteString)
+import qualified Data.ByteString.Char8 as B
+import Data.Text (Text)
import Snap.Types
+import Snap.Util.FileServe
import Text.Templating.Heist
@@ -40,6 +44,10 @@ class (Monad n, MonadSnap m) => MonadHeist n m | m -> n where
-- this returns 'empty'.
render :: ByteString -> m ()
+ -- | Renders a template as the given content type. If the given template
+ -- is not found, this returns 'empty'.
+ renderAs :: ByteString -> ByteString -> m ()
+
-- | Runs an action with a modified 'TemplateState'. You might want to use
-- this if you had a set of splices which were customised for a specific
-- action. To do that you would do:
@@ -50,7 +58,7 @@ class (Monad n, MonadSnap m) => MonadHeist n m | m -> n where
-- | Analogous to 'fileServe'. If the template specified in the request
-- path is not found, it returns 'empty'.
heistServe :: m ()
- heistServe = fmap rqPathInfo getRequest >>= render
+ heistServe = ifTop (render "index") <|> (render . B.pack =<< getSafePath)
-- | Analogous to 'fileServeSingle'. If the given template is not found,
-- this throws an error.
@@ -60,12 +68,12 @@ class (Monad n, MonadSnap m) => MonadHeist n m | m -> n where
------------------------------------------------------------------------------
--- | Helper function for common use case:
+-- | Helper function for common use case:
-- Render a template with a given set of splices.
-renderWithSplices
- :: (MonadHeist n m)
+renderWithSplices
+ :: (MonadHeist n m)
=> ByteString -- ^ Template to render
- -> [(ByteString, Splice n)] -- ^ Splice mapping
+ -> [(Text, Splice n)] -- ^ Splice mapping
-> m ()
renderWithSplices t sps = heistLocal bsps $ render t
where bsps = bindSplices sps
View
65 src/Snap/Extension/Heist/Impl.hs
@@ -47,8 +47,8 @@ interfaces from any other Snap Extension.
-}
module Snap.Extension.Heist.Impl
- (
-
+ (
+
-- * Heist State Definitions
HeistState
, HasHeistState(..)
@@ -63,7 +63,9 @@ module Snap.Extension.Heist.Impl
import Control.Concurrent.MVar
import Control.Monad.Reader
-import qualified Data.ByteString as B
+import Data.ByteString (ByteString)
+import Data.Maybe
+import Data.Text (Text)
import Snap.Extension
import Snap.Extension.Heist
import Snap.Types
@@ -73,7 +75,7 @@ import Text.Templating.Heist.Splices.Static
------------------------------------------------------------------------------
-- | Your application's state must include a 'HeistState' in order for your
--- application to be a 'MonadHeist'.
+-- application to be a 'MonadHeist'.
--
-- Unlike other @-State@ types, this is of kind @(* -> *) -> *@. Unless you're
-- developing your own Snap Extension which has its own internal 'HeistState',
@@ -140,58 +142,69 @@ instance MonadSnap m => InitializerState (HeistState m) where
------------------------------------------------------------------------------
-instance HasHeistState (SnapExtend s) s => MonadHeist (SnapExtend s) (SnapExtend s) where
- render t = do
- (HeistState _ _ tsMVar _ modifier) <- asks getHeistState
- ts <- liftIO $ fmap modifier $ readMVar tsMVar
- renderTemplate ts t >>= maybe pass (\html -> do
- modifyResponse $ setContentType "text/html; charset=utf-8"
- modifyResponse $ setContentLength (fromIntegral $ B.length html)
- writeBS html)
+instance HasHeistState (SnapExtend s) s
+ => MonadHeist (SnapExtend s) (SnapExtend s) where
+ render t = do
+ hs <- asks getHeistState
+ renderHelper hs Nothing t
+
+ renderAs c t = do
+ hs <- asks getHeistState
+ renderHelper hs (Just c) t
heistLocal f = local $ modifyHeistState $ \s ->
s { _modifier = f . _modifier s }
------------------------------------------------------------------------------
instance HasHeistState m s => MonadHeist m (ReaderT s m) where
- render t = ReaderT $ \s -> do
- let (HeistState _ _ tsMVar _ modifier) = getHeistState s
- ts <- liftIO $ fmap modifier $ readMVar tsMVar
- renderTemplate ts t >>= maybe pass (\html -> do
- modifyResponse $ setContentType "text/html; charset=utf-8"
- modifyResponse $ setContentLength (fromIntegral $ B.length html)
- writeBS html)
+ render t = ReaderT $ \s -> renderHelper (getHeistState s) Nothing t
+
+ renderAs c t = ReaderT $ \s -> renderHelper (getHeistState s) (Just c) t
heistLocal f = local $ modifyHeistState $ \s ->
s { _modifier = f . _modifier s }
------------------------------------------------------------------------------
+renderHelper :: (MonadSnap m)
+ => HeistState m
+ -> Maybe MIMEType
+ -> ByteString
+ -> m ()
+renderHelper hs c t = do
+ let (HeistState _ _ tsMVar _ modifier) = hs
+ ts <- liftIO $ fmap modifier $ readMVar tsMVar
+ renderTemplate ts t >>= maybe pass (\(b,mime) -> do
+ modifyResponse $ setContentType $ fromMaybe mime c
+ writeBuilder b)
+
+
+------------------------------------------------------------------------------
-- | Take your application's state and register these splices in it so
-- that you don't have to re-list them in every handler. Should be called from
-- inside your application's 'Initializer'.
--
-- Typical use cases are dynamically generated components that are present in
--- many of your views.
+-- many of your views.
--
-- Example Usage:
--
-- @
-- appInit :: Initializer AppState
-- appInit = do
-- hs <- heistInitializer \"templates\"
--- registerSplices hs $
+-- registerSplices hs $
-- [ (\"tabs\", tabsSplice)
--- , (\"loginLogout\", loginLogoutSplice) ]
+-- , (\"loginLogout\", loginLogoutSplice) ]
-- @
registerSplices
- :: (MonadSnap m, MonadIO n)
- => HeistState m
+ :: (MonadSnap m, MonadIO n)
+ => HeistState m
-- ^ Heist state that you are going to embed in your application's state.
- -> [(B.ByteString, Splice m)]
+ -> [(Text, Splice m)]
-- ^ Your splices.
-> n ()
registerSplices s sps = liftIO $ do
let mv = _tsMVar s
- modifyMVar_ mv $ (return . bindSplices sps)
+ modifyMVar_ mv $ (return . bindSplices sps)
View
44 src/Snap/Heist.hs
@@ -1,44 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
--- | This module contains convenience functions for helping render
--- Heist templates from Snap.
-module Snap.Heist where
-
-------------------------------------------------------------------------------
-import Control.Applicative
-import Data.ByteString.Char8 (ByteString)
-import qualified Data.ByteString.Char8 as B
-import Snap.Types
-import Snap.Util.FileServe
-import Text.Templating.Heist
-
-
-------------------------------------------------------------------------------
--- | This is a convenience function. It calls 'render' with the
--- content type set to @text/html; charset=utf-8@.
-renderHtml :: (MonadSnap m) => TemplateState m -> ByteString -> m ()
-renderHtml = render "text/html; charset=utf-8"
-
-
-------------------------------------------------------------------------------
--- | Renders a template with the provided content type. If the
--- template cannot be loaded, 'pass' is called and the next handler is tried.
-render :: (MonadSnap m)
- => ByteString -- ^ the content type to include in the response
- -> TemplateState m -- ^ the TemplateState that contains the template
- -> ByteString -- ^ the name of the template
- -> m ()
-render contentType ts template = do
- bytes <- renderTemplate ts template
- flip (maybe pass) bytes $ \x -> do
- modifyResponse $ setContentType contentType
- . setContentLength (fromIntegral $ B.length x)
- writeBS x
-
-
-------------------------------------------------------------------------------
--- | Handles the rendering of any template in TemplateState.
-handleAllTemplates :: (MonadSnap m)
- => TemplateState m -> m ()
-handleAllTemplates ts =
- ifTop (renderHtml ts "index") <|>
- (renderHtml ts . B.pack =<< getSafePath)
View
3 src/Snap/StarterTH.hs
@@ -19,7 +19,8 @@ type DirData = FilePath
------------------------------------------------------------------------------
-- Gets all the directorys in a DirTree
getDirs :: [FilePath] -> DirTree a -> [FilePath]
-getDirs prefix (Dir n c) = (intercalate "/" (reverse (n:prefix))) : concatMap (getDirs (n:prefix)) c
+getDirs prefix (Dir n c) = (intercalate "/" (reverse (n:prefix))) :
+ concatMap (getDirs (n:prefix)) c
getDirs _ (File _ _) = []
getDirs _ (Failed _ _) = []

0 comments on commit f156b49

Please sign in to comment.