Permalink
Browse files

Add <static> tag

  • Loading branch information...
1 parent af76f5b commit b6e941fcfffb1e7a5e2d79d59f662ebff92c10ce @gregorycollins gregorycollins committed May 13, 2010
View
@@ -18,6 +18,7 @@ Executable snap-website
Build-depends:
base >= 4,
bytestring,
+ containers,
directory,
filepath,
haskell98,
@@ -26,6 +27,7 @@ Executable snap-website
MonadCatchIO-transformers >= 0.2 && < 0.3,
monads-fd,
process,
+ random,
snap-core,
snap-server,
text,
View
@@ -6,6 +6,8 @@ module Main where
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.UTF8 as UTF8
+import Data.Map (Map)
+import qualified Data.Map as Map
import Data.Maybe
import qualified Data.Text as T
import Control.Applicative
@@ -14,6 +16,8 @@ import Control.Exception (throwIO, ErrorCall(..), SomeException)
import Control.Monad
import Control.Monad.CatchIO
import Control.Monad.Trans
+import Data.IORef
+import qualified Data.Set as Set
import Data.Typeable
import Prelude hiding (catch)
import Snap.Http.Server
@@ -25,9 +29,11 @@ import System.Directory
import System.Posix.Env
import System.Exit
import System.Process
+import System.Random
import Text.Templating.Heist
import qualified Text.XHtmlCombinators.Escape as XH
-import Text.XML.Expat.Tree
+import Text.XML.Expat.Cursor
+import Text.XML.Expat.Tree hiding (Node)
setLocaleToUTF8 :: IO ()
@@ -59,14 +65,15 @@ renderTmpl tsMVar n = do
templateServe :: TemplateState Snap
-> MVar (TemplateState Snap)
+ -> MVar (Map ByteString [Node])
-> Snap ()
-templateServe orig tsMVar = do
+templateServe orig tsMVar staticMVar = do
p
modifyResponse $ setContentType "text/html"
where
p = ifTop (renderTmpl tsMVar "index") <|>
- path "admin/reload" (reloadTemplates orig tsMVar) <|>
+ path "admin/reload" (reloadTemplates orig tsMVar staticMVar) <|>
(renderTmpl tsMVar . B.pack =<< getSafePath)
@@ -76,20 +83,27 @@ loadError str = "Error loading templates\n"++str
reloadTemplates :: TemplateState Snap
-> MVar (TemplateState Snap)
+ -> MVar (Map ByteString [Node])
-> Snap ()
-reloadTemplates origTs tsMVar = do
+reloadTemplates origTs tsMVar staticMVar = do
+ liftIO $ modifyMVar_ staticMVar (const $ return Map.empty)
ts <- liftIO $ loadTemplates "templates" origTs
either bad good ts
where
bad msg = do writeBS $ B.pack $ loadError msg ++ "Keeping old templates."
- good ts = do liftIO $ modifyMVar_ tsMVar (const $ return $ bindMarkdownTag ts)
+ good ts = do liftIO $ modifyMVar_ tsMVar (const $ bindMarkdownTag ts)
writeBS "Templates loaded successfully"
-site :: TemplateState Snap -> MVar (TemplateState Snap) -> Snap ()
-site origTs tsMVar = catch500 $
- withCompression $ h1
- <|> templateServe origTs tsMVar
- <|> h3
+
+site :: TemplateState Snap
+ -> MVar (TemplateState Snap)
+ -> MVar (Map ByteString [Node])
+ -> Snap ()
+site origTs tsMVar staticMVar =
+ catch500 $
+ withCompression $ h1
+ <|> templateServe origTs tsMVar staticMVar
+ <|> h3
catch500 :: Snap a -> Snap ()
@@ -114,8 +128,69 @@ h3 :: Snap ()
h3 = path "throwException" (throw $ ErrorCall "jlkfdjfldskjlf")
-bindMarkdownTag :: TemplateState Snap -> TemplateState Snap
-bindMarkdownTag = bindSplice "markdown" markdownSplice
+bindMarkdownTag :: TemplateState Snap -> IO (TemplateState Snap)
+bindMarkdownTag = return . bindSplice "markdown" markdownSplice
+
+
+bindStaticTag :: TemplateState Snap
+ -> IO (TemplateState Snap, MVar (Map ByteString [Node]))
+bindStaticTag ts = do
+ sr <- newIORef $ Set.empty
+ mv <- newMVar Map.empty
+
+ return $ (addOnLoadHook (assignIds sr) $
+ bindSplice "static" (staticSplice mv) ts,
+ mv)
+
+ where
+ staticSplice mv = do
+ tree <- getParamNode
+ let i = fromJust $ getAttribute tree "id"
+
+ mp <- liftIO $ readMVar mv
+
+ (mp',ns) <- do
+ let mbn = Map.lookup i mp
+ case mbn of
+ Nothing -> do
+ nodes' <- runNodeList $ getChildren tree
+ return $! (Map.insert i nodes' mp, nodes')
+ (Just n) -> do
+ stopRecursion
+ return $! (mp,n)
+
+ liftIO $ modifyMVar_ mv (const $ return mp')
+
+ return ns
+
+
+ generateId :: IO Int
+ generateId = getStdRandom random
+
+ assignIds setref = mapM f
+ where
+ f node = g $ fromTree node
+
+ getId = do
+ i <- liftM (B.pack . show) generateId
+ st <- readIORef setref
+ if Set.member i st
+ then getId
+ else do
+ writeIORef setref $ Set.insert i st
+ return i
+
+ g curs = do
+ let node = current curs
+ curs' <- if getName node == "static"
+ then do
+ i <- getId
+ return $ modifyContent (setAttribute "id" i) curs
+ else return curs
+ let mbc = nextDF curs'
+ maybe (return $ toTree curs') g mbc
+
+
data PandocMissingException = PandocMissingException
@@ -204,16 +279,20 @@ main = do
setLocaleToUTF8
- let origTs = bindMarkdownTag emptyTemplateState
- ts <- loadTemplates "templates" origTs
- either (\s -> putStrLn (loadError s) >> exitFailure) (const $ return ()) ts
- tsMVar <- newMVar $ either error bindMarkdownTag ts
+
+ (origTs,staticMVar) <- (bindMarkdownTag >=> bindStaticTag)
+ emptyTemplateState
+
+ ets <- loadTemplates "templates" origTs
+ let ts = either error id ets
+ either (\s -> putStrLn (loadError s) >> exitFailure) (const $ return ()) ets
+ tsMVar <- newMVar $ ts
(try $ httpServe "*" port "achilles"
(Just "access.log")
(Just "error.log")
- (site origTs tsMVar)) :: IO (Either SomeException ())
+ (site origTs tsMVar staticMVar)) :: IO (Either SomeException ())
threadDelay 1000000
putStrLn "exiting"
View
@@ -1,4 +1,5 @@
<apply template="page">
+ <static>
<div id="about" class="section left">
<div class="inner">
<h2>What is the Snap Framework?</h2>
@@ -110,4 +111,5 @@
</div><!--end mailing list -->
</div><!--end inner-->
</div><!--end project-status-->
+ </static>
</apply>
View
@@ -1,27 +1,30 @@
<apply template="page">
-<div id="about" class="section left">
- <div class="inner">
- <h2>Tutorials</h2>
- <ul>
- <li><a href="quickstart">Quick Start</a></li>
- <li><a href="tutorials/snap-api">Snap API Introduction</a></li>
- <li><a href="tutorials/heist">Heist Template Tutorial</a></li>
- </ul>
- </div>
+ <static>
+ <div id="about" class="section left">
+ <div class="inner">
+ <h2>Tutorials</h2>
+ <ul>
+ <li><a href="quickstart">Quick Start</a></li>
+ <li><a href="tutorials/snap-api">Snap API Introduction</a></li>
+ <li><a href="tutorials/heist">Heist Template Tutorial</a></li>
+ </ul>
+ </div>
- <div class="inner">
- <h2>Resources</h2>
- <ul><li><a href="/style-guide">Haskell Style Guide</a></li></ul>
- </div>
-</div>
-<div id="about" class="section left">
- <div class="inner">
- <h2>API Documentation</h2>
- <ul>
- <li><a href="docs/latest/snap-core/index.html">snap-core</a></li>
- <li><a href="docs/latest/snap-server/index.html">snap-server</a></li>
- <li><a href="docs/latest/heist/index.html">heist</a> <em>(experimental)</em></li>
- </ul>
- </div>
-</div>
+ <div class="inner">
+ <h2>Resources</h2>
+ <ul><li><a href="/style-guide">Haskell Style Guide</a></li></ul>
+ </div>
+ </div>
+ <div id="about" class="section left">
+ <div class="inner">
+ <h2>API Documentation</h2>
+ <ul>
+ <li><a href="docs/latest/snap-core/index.html">snap-core</a></li>
+ <li><a href="docs/latest/snap-server/index.html">snap-server</a></li>
+ <li><a href="docs/latest/heist/index.html">heist</a>
+ <em>(experimental)</em></li>
+ </ul>
+ </div>
+ </div>
+ </static>
</apply>
View
@@ -1,53 +1,54 @@
<apply template="page">
- <div class="section left">
- <div class="inner">
- <h2>Installing Snap</h2>
- <p>Snap is written in the <a href="http://www.haskell.org/">Haskell</a>
- programming language, and requires
- the <a href="http://www.haskell.org/ghc/">GHC</a> Haskell
- compiler.</p>
+ <static>
+ <div class="section left">
+ <div class="inner">
+ <h2>Installing Snap</h2>
+ <p>Snap is written in the <a href="http://www.haskell.org/">Haskell</a>
+ programming language, and requires
+ the <a href="http://www.haskell.org/ghc/">GHC</a> Haskell
+ compiler.</p>
- <p>The easiest way to get Snap is with Haskell's
- <a href="http://www.haskell.org/cabal/">Cabal</a> package manager. If
- you already have Cabal set up, then getting Snap should be as simple
- as running two commands:</p>
-<pre class="code">$ cabal update
-$ cabal install snap-server</pre>
+ <p>The easiest way to get Snap is with Haskell's
+ <a href="http://www.haskell.org/cabal/">Cabal</a> package manager. If
+ you already have Cabal set up, then getting Snap should be as simple
+ as running two commands:</p>
+ <pre class="code">$ cabal update
+ $ cabal install snap-server</pre>
- <p>If you don't have <tt>GHC</tt> and <tt>cabal</tt> installed, the
- easiest way to get them is with
- the <a href="http://hackage.haskell.org/platform/">Haskell Platform</a>
- binary installer.</p>
+ <p>If you don't have <tt>GHC</tt> and <tt>cabal</tt> installed, the
+ easiest way to get them is with
+ the <a href="http://hackage.haskell.org/platform/">Haskell Platform</a>
+ binary installer.</p>
- <p>After Snap is installed, check out the <a href="/quickstart">quick
- start</a> for instructions on getting your project started.</p>
+ <p>After Snap is installed, check out the <a href="/quickstart">quick
+ start</a> for instructions on getting your project started.</p>
+ </div>
</div>
- </div>
- <div class="section right">
- <div class="inner">
- <h2>Snap Packages</h2>
- <p>Snap is made up of three separate packages:</p>
+ <div class="section right">
+ <div class="inner">
+ <h2>Snap Packages</h2>
+ <p>Snap is made up of three separate packages:</p>
- <dl>
- <dt><tt>snap-core</tt></dt>
- <dd>Core type definitions (<tt>Snap</tt> monad, HTTP types, etc) and
- utilities for web
- handlers. <br/><span class="linklist">
- [ <a href="/docs/latest/snap-core/index.html"
- >api docs</a> |
+ <dl>
+ <dt><tt>snap-core</tt></dt>
+ <dd>Core type definitions (<tt>Snap</tt> monad, HTTP types, etc) and
+ utilities for web
+ handlers. <br/><span class="linklist">
+ [ <a href="/docs/latest/snap-core/index.html"
+ >api docs</a> |
<a href="http://hackage.haskell.org/package/snap-core"
>hackage</a> |
<a href="http://github.com/snapframework/snap-core"
>github</a> |
<a href="/docs/snap-core-hpc/hpc_index.html"
>test coverage report</a> ]</span></dd>
- <dt><tt>snap-server</tt></dt>
- <dd>An iteratee-based HTTP server library, which runs <tt>Snap</tt> web
- handlers. <br/><span class="linklist">
- [ <a href="/docs/latest/snap-server/index.html"
- >api docs</a> |
+ <dt><tt>snap-server</tt></dt>
+ <dd>An iteratee-based HTTP server library, which runs <tt>Snap</tt> web
+ handlers. <br/><span class="linklist">
+ [ <a href="/docs/latest/snap-server/index.html"
+ >api docs</a> |
<a href="http://hackage.haskell.org/package/snap-server"
>hackage</a> |
<a href="http://github.com/snapframework/snap-server"
@@ -56,17 +57,18 @@ $ cabal install snap-server</pre>
>test coverage report</a> ]</span></dd>
- <dt><tt>heist</tt> <strong>(experimental)</strong></dt>
- <dd>An xhtml-based templating engine, allowing Haskell functions to be
- bound to XML tags. <br/><span class="linklist">
- [ <a href="/docs/latest/heist/index.html" >api docs</a> |
+ <dt><tt>heist</tt> <strong>(experimental)</strong></dt>
+ <dd>An xhtml-based templating engine, allowing Haskell functions to be
+ bound to XML tags. <br/><span class="linklist">
+ [ <a href="/docs/latest/heist/index.html" >api docs</a> |
<a href="http://hackage.haskell.org/package/heist"
>hackage</a> |
<a href="http://github.com/snapframework/heist"
>github</a> |
<a href="/docs/heist-hpc/hpc_index.html"
>test coverage report</a> ]</span></dd>
- </dl>
+ </dl>
+ </div>
</div>
- </div>
+ </static>
</apply>
Oops, something went wrong.

0 comments on commit b6e941f

Please sign in to comment.